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         cp2++;
6098         *(cp1++) = *cp2;
6099     }
6100     if (*cp2 == ':') {
6101       *(cp1++) = '/';
6102       if (*(cp2+1) == '[') cp2++;
6103     }
6104     else if (*cp2 == ']' || *cp2 == '>') {
6105       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6106     }
6107     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
6108       *(cp1++) = '/';
6109       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6110         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6111                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6112         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6113             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6114       }
6115       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6116         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6117         cp2 += 2;
6118       }
6119     }
6120     else if (*cp2 == '-') {
6121       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6122         while (*cp2 == '-') {
6123           cp2++;
6124           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6125         }
6126         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
6127           if (ts) Safefree(rslt);                        /* filespecs like */
6128           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
6129           return NULL;
6130         }
6131       }
6132       else *(cp1++) = *cp2;
6133     }
6134     else *(cp1++) = *cp2;
6135   }
6136   while (*cp2) *(cp1++) = *(cp2++);
6137   *cp1 = '\0';
6138
6139   /* This still leaves /000000/ when working with a
6140    * VMS device root or concealed root.
6141    */
6142   {
6143   int ulen;
6144   char * zeros;
6145
6146       ulen = strlen(rslt);
6147
6148       /* Get rid of "000000/ in rooted filespecs */
6149       if (ulen > 7) {
6150         zeros = strstr(rslt, "/000000/");
6151         if (zeros != NULL) {
6152           int mlen;
6153           mlen = ulen - (zeros - rslt) - 7;
6154           memmove(zeros, &zeros[7], mlen);
6155           ulen = ulen - 7;
6156           rslt[ulen] = '\0';
6157         }
6158       }
6159   }
6160
6161   return rslt;
6162
6163 }  /* end of do_tounixspec() */
6164 /*}}}*/
6165 /* External entry points */
6166 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
6167   { return do_tounixspec(spec,buf,0, NULL); }
6168 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
6169   { return do_tounixspec(spec,buf,1, NULL); }
6170 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
6171   { return do_tounixspec(spec,buf,0, utf8_fl); }
6172 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
6173   { return do_tounixspec(spec,buf,1, utf8_fl); }
6174
6175 #if __CRTL_VER >= 70200000 && !defined(__VAX)
6176
6177 /*
6178  This procedure is used to identify if a path is based in either
6179  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
6180  it returns the OpenVMS format directory for it.
6181
6182  It is expecting specifications of only '/' or '/xxxx/'
6183
6184  If a posix root does not exist, or 'xxxx' is not a directory
6185  in the posix root, it returns a failure.
6186
6187  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
6188
6189  It is used only internally by posix_to_vmsspec_hardway().
6190  */
6191
6192 static int posix_root_to_vms
6193   (char *vmspath, int vmspath_len,
6194    const char *unixpath,
6195    const int * utf8_fl) {
6196 int sts;
6197 struct FAB myfab = cc$rms_fab;
6198 struct NAML mynam = cc$rms_naml;
6199 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6200  struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6201 char *esa;
6202 char *vms_delim;
6203 int dir_flag;
6204 int unixlen;
6205
6206     dir_flag = 0;
6207     unixlen = strlen(unixpath);
6208     if (unixlen == 0) {
6209       vmspath[0] = '\0';
6210       return RMS$_FNF;
6211     }
6212
6213 #if __CRTL_VER >= 80200000
6214   /* If not a posix spec already, convert it */
6215   if (decc_posix_compliant_pathnames) {
6216     if (strncmp(unixpath,"\"^UP^",5) != 0) {
6217       sprintf(vmspath,"\"^UP^%s\"",unixpath);
6218     }
6219     else {
6220       /* This is already a VMS specification, no conversion */
6221       unixlen--;
6222       strncpy(vmspath,unixpath, vmspath_len);
6223     }
6224   }
6225   else
6226 #endif
6227   {
6228   int path_len;
6229   int i,j;
6230
6231      /* Check to see if this is under the POSIX root */
6232      if (decc_disable_posix_root) {
6233         return RMS$_FNF;
6234      }
6235
6236      /* Skip leading / */
6237      if (unixpath[0] == '/') {
6238         unixpath++;
6239         unixlen--;
6240      }
6241
6242
6243      strcpy(vmspath,"SYS$POSIX_ROOT:");
6244
6245      /* If this is only the / , or blank, then... */
6246      if (unixpath[0] == '\0') {
6247         /* by definition, this is the answer */
6248         return SS$_NORMAL;
6249      }
6250
6251      /* Need to look up a directory */
6252      vmspath[15] = '[';
6253      vmspath[16] = '\0';
6254
6255      /* Copy and add '^' escape characters as needed */
6256      j = 16;
6257      i = 0;
6258      while (unixpath[i] != 0) {
6259      int k;
6260
6261         j += copy_expand_unix_filename_escape
6262             (&vmspath[j], &unixpath[i], &k, utf8_fl);
6263         i += k;
6264      }
6265
6266      path_len = strlen(vmspath);
6267      if (vmspath[path_len - 1] == '/')
6268         path_len--;
6269      vmspath[path_len] = ']';
6270      path_len++;
6271      vmspath[path_len] = '\0';
6272
6273   }
6274   vmspath[vmspath_len] = 0;
6275   if (unixpath[unixlen - 1] == '/')
6276   dir_flag = 1;
6277   esa = PerlMem_malloc(VMS_MAXRSS);
6278   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6279   myfab.fab$l_fna = vmspath;
6280   myfab.fab$b_fns = strlen(vmspath);
6281   myfab.fab$l_naml = &mynam;
6282   mynam.naml$l_esa = NULL;
6283   mynam.naml$b_ess = 0;
6284   mynam.naml$l_long_expand = esa;
6285   mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
6286   mynam.naml$l_rsa = NULL;
6287   mynam.naml$b_rss = 0;
6288   if (decc_efs_case_preserve)
6289     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6290 #ifdef NAML$M_OPEN_SPECIAL
6291   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6292 #endif
6293
6294   /* Set up the remaining naml fields */
6295   sts = sys$parse(&myfab);
6296
6297   /* It failed! Try again as a UNIX filespec */
6298   if (!(sts & 1)) {
6299     PerlMem_free(esa);
6300     return sts;
6301   }
6302
6303    /* get the Device ID and the FID */
6304    sts = sys$search(&myfab);
6305    /* on any failure, returned the POSIX ^UP^ filespec */
6306    if (!(sts & 1)) {
6307       PerlMem_free(esa);
6308       return sts;
6309    }
6310    specdsc.dsc$a_pointer = vmspath;
6311    specdsc.dsc$w_length = vmspath_len;
6312
6313    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6314    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6315    sts = lib$fid_to_name
6316       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6317
6318   /* on any failure, returned the POSIX ^UP^ filespec */
6319   if (!(sts & 1)) {
6320      /* This can happen if user does not have permission to read directories */
6321      if (strncmp(unixpath,"\"^UP^",5) != 0)
6322        sprintf(vmspath,"\"^UP^%s\"",unixpath);
6323      else
6324        strcpy(vmspath, unixpath);
6325   }
6326   else {
6327     vmspath[specdsc.dsc$w_length] = 0;
6328
6329     /* Are we expecting a directory? */
6330     if (dir_flag != 0) {
6331     int i;
6332     char *eptr;
6333
6334       eptr = NULL;
6335
6336       i = specdsc.dsc$w_length - 1;
6337       while (i > 0) {
6338       int zercnt;
6339         zercnt = 0;
6340         /* Version must be '1' */
6341         if (vmspath[i--] != '1')
6342           break;
6343         /* Version delimiter is one of ".;" */
6344         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6345           break;
6346         i--;
6347         if (vmspath[i--] != 'R')
6348           break;
6349         if (vmspath[i--] != 'I')
6350           break;
6351         if (vmspath[i--] != 'D')
6352           break;
6353         if (vmspath[i--] != '.')
6354           break;
6355         eptr = &vmspath[i+1];
6356         while (i > 0) {
6357           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
6358             if (vmspath[i-1] != '^') {
6359               if (zercnt != 6) {
6360                 *eptr = vmspath[i];
6361                 eptr[1] = '\0';
6362                 vmspath[i] = '.';
6363                 break;
6364               }
6365               else {
6366                 /* Get rid of 6 imaginary zero directory filename */
6367                 vmspath[i+1] = '\0';
6368               }
6369             }
6370           }
6371           if (vmspath[i] == '0')
6372             zercnt++;
6373           else
6374             zercnt = 10;
6375           i--;
6376         }
6377         break;
6378       }
6379     }
6380   }
6381   PerlMem_free(esa);
6382   return sts;
6383 }
6384
6385 /* /dev/mumble needs to be handled special.
6386    /dev/null becomes NLA0:, And there is the potential for other stuff
6387    like /dev/tty which may need to be mapped to something.
6388 */
6389
6390 static int
6391 slash_dev_special_to_vms
6392    (const char * unixptr,
6393     char * vmspath,
6394     int vmspath_len)
6395 {
6396 char * nextslash;
6397 int len;
6398 int cmp;
6399 int islnm;
6400
6401     unixptr += 4;
6402     nextslash = strchr(unixptr, '/');
6403     len = strlen(unixptr);
6404     if (nextslash != NULL)
6405         len = nextslash - unixptr;
6406     cmp = strncmp("null", unixptr, 5);
6407     if (cmp == 0) {
6408         if (vmspath_len >= 6) {
6409             strcpy(vmspath, "_NLA0:");
6410             return SS$_NORMAL;
6411         }
6412     }
6413 }
6414
6415
6416 /* The built in routines do not understand perl's special needs, so
6417     doing a manual conversion from UNIX to VMS
6418
6419     If the utf8_fl is not null and points to a non-zero value, then
6420     treat 8 bit characters as UTF-8.
6421
6422     The sequence starting with '$(' and ending with ')' will be passed
6423     through with out interpretation instead of being escaped.
6424
6425   */
6426 static int posix_to_vmsspec_hardway
6427   (char *vmspath, int vmspath_len,
6428    const char *unixpath,
6429    int dir_flag,
6430    int * utf8_fl) {
6431
6432 char *esa;
6433 const char *unixptr;
6434 const char *unixend;
6435 char *vmsptr;
6436 const char *lastslash;
6437 const char *lastdot;
6438 int unixlen;
6439 int vmslen;
6440 int dir_start;
6441 int dir_dot;
6442 int quoted;
6443 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6444 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6445
6446   if (utf8_fl != NULL)
6447     *utf8_fl = 0;
6448
6449   unixptr = unixpath;
6450   dir_dot = 0;
6451
6452   /* Ignore leading "/" characters */
6453   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
6454     unixptr++;
6455   }
6456   unixlen = strlen(unixptr);
6457
6458   /* Do nothing with blank paths */
6459   if (unixlen == 0) {
6460     vmspath[0] = '\0';
6461     return SS$_NORMAL;
6462   }
6463
6464   quoted = 0;
6465   /* This could have a "^UP^ on the front */
6466   if (strncmp(unixptr,"\"^UP^",5) == 0) {
6467     quoted = 1;
6468     unixptr+= 5;
6469     unixlen-= 5;
6470   }
6471
6472   lastslash = strrchr(unixptr,'/');
6473   lastdot = strrchr(unixptr,'.');
6474   unixend = strrchr(unixptr,'\"');
6475   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
6476     unixend = unixptr + unixlen;
6477   }
6478
6479   /* last dot is last dot or past end of string */
6480   if (lastdot == NULL)
6481     lastdot = unixptr + unixlen;
6482
6483   /* if no directories, set last slash to beginning of string */
6484   if (lastslash == NULL) {
6485     lastslash = unixptr;
6486   }
6487   else {
6488     /* Watch out for trailing "." after last slash, still a directory */
6489     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
6490       lastslash = unixptr + unixlen;
6491     }
6492
6493     /* Watch out for traiing ".." after last slash, still a directory */
6494     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
6495       lastslash = unixptr + unixlen;
6496     }
6497
6498     /* dots in directories are aways escaped */
6499     if (lastdot < lastslash)
6500       lastdot = unixptr + unixlen;
6501   }
6502
6503   /* if (unixptr < lastslash) then we are in a directory */
6504
6505   dir_start = 0;
6506
6507   vmsptr = vmspath;
6508   vmslen = 0;
6509
6510   /* Start with the UNIX path */
6511   if (*unixptr != '/') {
6512     /* relative paths */
6513
6514     /* If allowing logical names on relative pathnames, then handle here */
6515     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
6516         !decc_posix_compliant_pathnames) {
6517     char * nextslash;
6518     int seg_len;
6519     char * trn;
6520     int islnm;
6521
6522         /* Find the next slash */
6523         nextslash = strchr(unixptr,'/');
6524
6525         esa = PerlMem_malloc(vmspath_len);
6526         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6527
6528         trn = PerlMem_malloc(VMS_MAXRSS);
6529         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6530
6531         if (nextslash != NULL) {
6532
6533             seg_len = nextslash - unixptr;
6534             strncpy(esa, unixptr, seg_len);
6535             esa[seg_len] = 0;
6536         }
6537         else {
6538             strcpy(esa, unixptr);
6539             seg_len = strlen(unixptr);
6540         }
6541         /* trnlnm(section) */
6542         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
6543
6544         if (islnm) {
6545             /* Now fix up the directory */
6546
6547             /* Split up the path to find the components */
6548             sts = vms_split_path
6549                   (trn,
6550                    &v_spec,
6551                    &v_len,
6552                    &r_spec,
6553                    &r_len,
6554                    &d_spec,
6555                    &d_len,
6556                    &n_spec,
6557                    &n_len,
6558                    &e_spec,
6559                    &e_len,
6560                    &vs_spec,
6561                    &vs_len);
6562
6563             while (sts == 0) {
6564             char * strt;
6565             int cmp;
6566
6567                 /* A logical name must be a directory  or the full
6568                    specification.  It is only a full specification if
6569                    it is the only component */
6570                 if ((unixptr[seg_len] == '\0') ||
6571                     (unixptr[seg_len+1] == '\0')) {
6572
6573                     /* Is a directory being required? */
6574                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
6575                         /* Not a logical name */
6576                         break;
6577                     }
6578
6579
6580                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
6581                         /* This must be a directory */
6582                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
6583                             strcpy(vmsptr, esa);
6584                             vmslen=strlen(vmsptr);
6585                             vmsptr[vmslen] = ':';
6586                             vmslen++;
6587                             vmsptr[vmslen] = '\0';
6588                             return SS$_NORMAL;
6589                         }
6590                     }
6591
6592                 }
6593
6594
6595                 /* must be dev/directory - ignore version */
6596                 if ((n_len + e_len) != 0)
6597                     break;
6598
6599                 /* transfer the volume */
6600                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
6601                     strncpy(vmsptr, v_spec, v_len);
6602                     vmsptr += v_len;
6603                     vmsptr[0] = '\0';
6604                     vmslen += v_len;
6605                 }
6606
6607                 /* unroot the rooted directory */
6608                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
6609                     r_spec[0] = '[';
6610                     r_spec[r_len - 1] = ']';
6611
6612                     /* This should not be there, but nothing is perfect */
6613                     if (r_len > 9) {
6614                         cmp = strcmp(&r_spec[1], "000000.");
6615                         if (cmp == 0) {
6616                             r_spec += 7;
6617                             r_spec[7] = '[';
6618                             r_len -= 7;
6619                             if (r_len == 2)
6620                                 r_len = 0;
6621                         }
6622                     }
6623                     if (r_len > 0) {
6624                         strncpy(vmsptr, r_spec, r_len);
6625                         vmsptr += r_len;
6626                         vmslen += r_len;
6627                         vmsptr[0] = '\0';
6628                     }
6629                 }
6630                 /* Bring over the directory. */
6631                 if ((d_len > 0) &&
6632                     ((d_len + vmslen) < vmspath_len)) {
6633                     d_spec[0] = '[';
6634                     d_spec[d_len - 1] = ']';
6635                     if (d_len > 9) {
6636                         cmp = strcmp(&d_spec[1], "000000.");
6637                         if (cmp == 0) {
6638                             d_spec += 7;
6639                             d_spec[7] = '[';
6640                             d_len -= 7;
6641                             if (d_len == 2)
6642                                 d_len = 0;
6643                         }
6644                     }
6645
6646                     if (r_len > 0) {
6647                         /* Remove the redundant root */
6648                         if (r_len > 0) {
6649                             /* remove the ][ */
6650                             vmsptr--;
6651                             vmslen--;
6652                             d_spec++;
6653                             d_len--;
6654                         }
6655                         strncpy(vmsptr, d_spec, d_len);
6656                             vmsptr += d_len;
6657                             vmslen += d_len;
6658                             vmsptr[0] = '\0';
6659                     }
6660                 }
6661                 break;
6662             }
6663         }
6664
6665         PerlMem_free(esa);
6666         PerlMem_free(trn);
6667     }
6668
6669     if (lastslash > unixptr) {
6670     int dotdir_seen;
6671
6672       /* skip leading ./ */
6673       dotdir_seen = 0;
6674       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
6675         dotdir_seen = 1;
6676         unixptr++;
6677         unixptr++;
6678       }
6679
6680       /* Are we still in a directory? */
6681       if (unixptr <= lastslash) {
6682         *vmsptr++ = '[';
6683         vmslen = 1;
6684         dir_start = 1;
6685
6686         /* if not backing up, then it is relative forward. */
6687         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
6688               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
6689           *vmsptr++ = '.';
6690           vmslen++;
6691           dir_dot = 1;
6692           }
6693        }
6694        else {
6695          if (dotdir_seen) {
6696            /* Perl wants an empty directory here to tell the difference
6697             * between a DCL commmand and a filename
6698             */
6699           *vmsptr++ = '[';
6700           *vmsptr++ = ']';
6701           vmslen = 2;
6702         }
6703       }
6704     }
6705     else {
6706       /* Handle two special files . and .. */
6707       if (unixptr[0] == '.') {
6708         if (&unixptr[1] == unixend) {
6709           *vmsptr++ = '[';
6710           *vmsptr++ = ']';
6711           vmslen += 2;
6712           *vmsptr++ = '\0';
6713           return SS$_NORMAL;
6714         }
6715         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
6716           *vmsptr++ = '[';
6717           *vmsptr++ = '-';
6718           *vmsptr++ = ']';
6719           vmslen += 3;
6720           *vmsptr++ = '\0';
6721           return SS$_NORMAL;
6722         }
6723       }
6724     }
6725   }
6726   else {        /* Absolute PATH handling */
6727   int sts;
6728   char * nextslash;
6729   int seg_len;
6730     /* Need to find out where root is */
6731
6732     /* In theory, this procedure should never get an absolute POSIX pathname
6733      * that can not be found on the POSIX root.
6734      * In practice, that can not be relied on, and things will show up
6735      * here that are a VMS device name or concealed logical name instead.
6736      * So to make things work, this procedure must be tolerant.
6737      */
6738     esa = PerlMem_malloc(vmspath_len);
6739     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6740
6741     sts = SS$_NORMAL;
6742     nextslash = strchr(&unixptr[1],'/');
6743     seg_len = 0;
6744     if (nextslash != NULL) {
6745     int cmp;
6746       seg_len = nextslash - &unixptr[1];
6747       strncpy(vmspath, unixptr, seg_len + 1);
6748       vmspath[seg_len+1] = 0;
6749       cmp = 1;
6750       if (seg_len == 3) {
6751         cmp = strncmp(vmspath, "dev", 4);
6752         if (cmp == 0) {
6753             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
6754             if (sts = SS$_NORMAL)
6755                 return SS$_NORMAL;
6756         }
6757       }
6758       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
6759     }
6760
6761     if ($VMS_STATUS_SUCCESS(sts)) {
6762       /* This is verified to be a real path */
6763
6764       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
6765       if ($VMS_STATUS_SUCCESS(sts)) {
6766         strcpy(vmspath, esa);
6767         vmslen = strlen(vmspath);
6768         vmsptr = vmspath + vmslen;
6769         unixptr++;
6770         if (unixptr < lastslash) {
6771         char * rptr;
6772           vmsptr--;
6773           *vmsptr++ = '.';
6774           dir_start = 1;
6775           dir_dot = 1;
6776           if (vmslen > 7) {
6777           int cmp;
6778             rptr = vmsptr - 7;
6779             cmp = strcmp(rptr,"000000.");
6780             if (cmp == 0) {
6781               vmslen -= 7;
6782               vmsptr -= 7;
6783               vmsptr[1] = '\0';
6784             } /* removing 6 zeros */
6785           } /* vmslen < 7, no 6 zeros possible */
6786         } /* Not in a directory */
6787       } /* Posix root found */
6788       else {
6789         /* No posix root, fall back to default directory */
6790         strcpy(vmspath, "SYS$DISK:[");
6791         vmsptr = &vmspath[10];
6792         vmslen = 10;
6793         if (unixptr > lastslash) {
6794            *vmsptr = ']';
6795            vmsptr++;
6796            vmslen++;
6797         }
6798         else {
6799            dir_start = 1;
6800         }
6801       }
6802     } /* end of verified real path handling */
6803     else {
6804     int add_6zero;
6805     int islnm;
6806
6807       /* Ok, we have a device or a concealed root that is not in POSIX
6808        * or we have garbage.  Make the best of it.
6809        */
6810
6811       /* Posix to VMS destroyed this, so copy it again */
6812       strncpy(vmspath, &unixptr[1], seg_len);
6813       vmspath[seg_len] = 0;
6814       vmslen = seg_len;
6815       vmsptr = &vmsptr[vmslen];
6816       islnm = 0;
6817
6818       /* Now do we need to add the fake 6 zero directory to it? */
6819       add_6zero = 1;
6820       if ((*lastslash == '/') && (nextslash < lastslash)) {
6821         /* No there is another directory */
6822         add_6zero = 0;
6823       }
6824       else {
6825       int trnend;
6826       int cmp;
6827
6828         /* now we have foo:bar or foo:[000000]bar to decide from */
6829         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
6830
6831         if (!islnm && !decc_posix_compliant_pathnames) {
6832
6833             cmp = strncmp("bin", vmspath, 4);
6834             if (cmp == 0) {
6835                 /* bin => SYS$SYSTEM: */
6836                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
6837             }
6838             else {
6839                 /* tmp => SYS$SCRATCH: */
6840                 cmp = strncmp("tmp", vmspath, 4);
6841                 if (cmp == 0) {
6842                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
6843                 }
6844             }
6845         }
6846
6847         trnend = islnm ? islnm - 1 : 0;
6848
6849         /* if this was a logical name, ']' or '>' must be present */
6850         /* if not a logical name, then assume a device and hope. */
6851         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
6852
6853         /* if log name and trailing '.' then rooted - treat as device */
6854         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
6855
6856         /* Fix me, if not a logical name, a device lookup should be
6857          * done to see if the device is file structured.  If the device
6858          * is not file structured, the 6 zeros should not be put on.
6859          *
6860          * As it is, perl is occasionally looking for dev:[000000]tty.
6861          * which looks a little strange.
6862          *
6863          * Not that easy to detect as "/dev" may be file structured with
6864          * special device files.
6865          */
6866
6867         if ((add_6zero == 0) && (*nextslash == '/') &&
6868             (&nextslash[1] == unixend)) {
6869           /* No real directory present */
6870           add_6zero = 1;
6871         }
6872       }
6873
6874       /* Put the device delimiter on */
6875       *vmsptr++ = ':';
6876       vmslen++;
6877       unixptr = nextslash;
6878       unixptr++;
6879
6880       /* Start directory if needed */
6881       if (!islnm || add_6zero) {
6882         *vmsptr++ = '[';
6883         vmslen++;
6884         dir_start = 1;
6885       }
6886
6887       /* add fake 000000] if needed */
6888       if (add_6zero) {
6889         *vmsptr++ = '0';
6890         *vmsptr++ = '0';
6891         *vmsptr++ = '0';
6892         *vmsptr++ = '0';
6893         *vmsptr++ = '0';
6894         *vmsptr++ = '0';
6895         *vmsptr++ = ']';
6896         vmslen += 7;
6897         dir_start = 0;
6898       }
6899
6900     } /* non-POSIX translation */
6901     PerlMem_free(esa);
6902   } /* End of relative/absolute path handling */
6903
6904   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
6905   int dash_flag;
6906   int in_cnt;
6907   int out_cnt;
6908
6909     dash_flag = 0;
6910
6911     if (dir_start != 0) {
6912
6913       /* First characters in a directory are handled special */
6914       while ((*unixptr == '/') ||
6915              ((*unixptr == '.') &&
6916               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
6917                 (&unixptr[1]==unixend)))) {
6918       int loop_flag;
6919
6920         loop_flag = 0;
6921
6922         /* Skip redundant / in specification */
6923         while ((*unixptr == '/') && (dir_start != 0)) {
6924           loop_flag = 1;
6925           unixptr++;
6926           if (unixptr == lastslash)
6927             break;
6928         }
6929         if (unixptr == lastslash)
6930           break;
6931
6932         /* Skip redundant ./ characters */
6933         while ((*unixptr == '.') &&
6934                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
6935           loop_flag = 1;
6936           unixptr++;
6937           if (unixptr == lastslash)
6938             break;
6939           if (*unixptr == '/')
6940             unixptr++;
6941         }
6942         if (unixptr == lastslash)
6943           break;
6944
6945         /* Skip redundant ../ characters */
6946         while ((*unixptr == '.') && (unixptr[1] == '.') &&
6947              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
6948           /* Set the backing up flag */
6949           loop_flag = 1;
6950           dir_dot = 0;
6951           dash_flag = 1;
6952           *vmsptr++ = '-';
6953           vmslen++;
6954           unixptr++; /* first . */
6955           unixptr++; /* second . */
6956           if (unixptr == lastslash)
6957             break;
6958           if (*unixptr == '/') /* The slash */
6959             unixptr++;
6960         }
6961         if (unixptr == lastslash)
6962           break;
6963
6964         /* To do: Perl expects /.../ to be translated to [...] on VMS */
6965         /* Not needed when VMS is pretending to be UNIX. */
6966
6967         /* Is this loop stuck because of too many dots? */
6968         if (loop_flag == 0) {
6969           /* Exit the loop and pass the rest through */
6970           break;
6971         }
6972       }
6973
6974       /* Are we done with directories yet? */
6975       if (unixptr >= lastslash) {
6976
6977         /* Watch out for trailing dots */
6978         if (dir_dot != 0) {
6979             vmslen --;
6980             vmsptr--;
6981         }
6982         *vmsptr++ = ']';
6983         vmslen++;
6984         dash_flag = 0;
6985         dir_start = 0;
6986         if (*unixptr == '/')
6987           unixptr++;
6988       }
6989       else {
6990         /* Have we stopped backing up? */
6991         if (dash_flag) {
6992           *vmsptr++ = '.';
6993           vmslen++;
6994           dash_flag = 0;
6995           /* dir_start continues to be = 1 */
6996         }
6997         if (*unixptr == '-') {
6998           *vmsptr++ = '^';
6999           *vmsptr++ = *unixptr++;
7000           vmslen += 2;
7001           dir_start = 0;
7002
7003           /* Now are we done with directories yet? */
7004           if (unixptr >= lastslash) {
7005
7006             /* Watch out for trailing dots */
7007             if (dir_dot != 0) {
7008               vmslen --;
7009               vmsptr--;
7010             }
7011
7012             *vmsptr++ = ']';
7013             vmslen++;
7014             dash_flag = 0;
7015             dir_start = 0;
7016           }
7017         }
7018       }
7019     }
7020
7021     /* All done? */
7022     if (unixptr >= unixend)
7023       break;
7024
7025     /* Normal characters - More EFS work probably needed */
7026     dir_start = 0;
7027     dir_dot = 0;
7028
7029     switch(*unixptr) {
7030     case '/':
7031         /* remove multiple / */
7032         while (unixptr[1] == '/') {
7033            unixptr++;
7034         }
7035         if (unixptr == lastslash) {
7036           /* Watch out for trailing dots */
7037           if (dir_dot != 0) {
7038             vmslen --;
7039             vmsptr--;
7040           }
7041           *vmsptr++ = ']';
7042         }
7043         else {
7044           dir_start = 1;
7045           *vmsptr++ = '.';
7046           dir_dot = 1;
7047
7048           /* To do: Perl expects /.../ to be translated to [...] on VMS */
7049           /* Not needed when VMS is pretending to be UNIX. */
7050
7051         }
7052         dash_flag = 0;
7053         if (unixptr != unixend)
7054           unixptr++;
7055         vmslen++;
7056         break;
7057     case '.':
7058         if ((unixptr < lastdot) || (unixptr < lastslash) ||
7059             (&unixptr[1] == unixend)) {
7060           *vmsptr++ = '^';
7061           *vmsptr++ = '.';
7062           vmslen += 2;
7063           unixptr++;
7064
7065           /* trailing dot ==> '^..' on VMS */
7066           if (unixptr == unixend) {
7067             *vmsptr++ = '.';
7068             vmslen++;
7069             unixptr++;
7070           }
7071           break;
7072         }
7073
7074         *vmsptr++ = *unixptr++;
7075         vmslen ++;
7076         break;
7077     case '"':
7078         if (quoted && (&unixptr[1] == unixend)) {
7079             unixptr++;
7080             break;
7081         }
7082         in_cnt = copy_expand_unix_filename_escape
7083                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7084         vmsptr += out_cnt;
7085         unixptr += in_cnt;
7086         break;
7087     case '~':
7088     case ';':
7089     case '\\':
7090     case '?':
7091     case ' ':
7092     default:
7093         in_cnt = copy_expand_unix_filename_escape
7094                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7095         vmsptr += out_cnt;
7096         unixptr += in_cnt;
7097         break;
7098     }
7099   }
7100
7101   /* Make sure directory is closed */
7102   if (unixptr == lastslash) {
7103     char *vmsptr2;
7104     vmsptr2 = vmsptr - 1;
7105
7106     if (*vmsptr2 != ']') {
7107       *vmsptr2--;
7108
7109       /* directories do not end in a dot bracket */
7110       if (*vmsptr2 == '.') {
7111         vmsptr2--;
7112
7113         /* ^. is allowed */
7114         if (*vmsptr2 != '^') {
7115           vmsptr--; /* back up over the dot */
7116         }
7117       }
7118       *vmsptr++ = ']';
7119     }
7120   }
7121   else {
7122     char *vmsptr2;
7123     /* Add a trailing dot if a file with no extension */
7124     vmsptr2 = vmsptr - 1;
7125     if ((vmslen > 1) &&
7126         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
7127         (*vmsptr2 != ')') && (*lastdot != '.')) {
7128         *vmsptr++ = '.';
7129         vmslen++;
7130     }
7131   }
7132
7133   *vmsptr = '\0';
7134   return SS$_NORMAL;
7135 }
7136 #endif
7137
7138  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
7139 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
7140 {
7141 char * result;
7142 int utf8_flag;
7143
7144    /* If a UTF8 flag is being passed, honor it */
7145    utf8_flag = 0;
7146    if (utf8_fl != NULL) {
7147      utf8_flag = *utf8_fl;
7148     *utf8_fl = 0;
7149    }
7150
7151    if (utf8_flag) {
7152      /* If there is a possibility of UTF8, then if any UTF8 characters
7153         are present, then they must be converted to VTF-7
7154       */
7155      result = strcpy(rslt, path); /* FIX-ME */
7156    }
7157    else
7158      result = strcpy(rslt, path);
7159
7160    return result;
7161 }
7162
7163
7164 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
7165 static char *mp_do_tovmsspec
7166    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
7167   static char __tovmsspec_retbuf[VMS_MAXRSS];
7168   char *rslt, *dirend;
7169   char *lastdot;
7170   char *vms_delim;
7171   register char *cp1;
7172   const char *cp2;
7173   unsigned long int infront = 0, hasdir = 1;
7174   int rslt_len;
7175   int no_type_seen;
7176   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7177   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7178
7179   if (path == NULL) return NULL;
7180   rslt_len = VMS_MAXRSS-1;
7181   if (buf) rslt = buf;
7182   else if (ts) Newx(rslt, VMS_MAXRSS, char);
7183   else rslt = __tovmsspec_retbuf;
7184
7185   /* '.' and '..' are "[]" and "[-]" for a quick check */
7186   if (path[0] == '.') {
7187     if (path[1] == '\0') {
7188       strcpy(rslt,"[]");
7189       if (utf8_flag != NULL)
7190         *utf8_flag = 0;
7191       return rslt;
7192     }
7193     else {
7194       if (path[1] == '.' && path[2] == '\0') {
7195         strcpy(rslt,"[-]");
7196         if (utf8_flag != NULL)
7197            *utf8_flag = 0;
7198         return rslt;
7199       }
7200     }
7201   }
7202
7203    /* Posix specifications are now a native VMS format */
7204   /*--------------------------------------------------*/
7205 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7206   if (decc_posix_compliant_pathnames) {
7207     if (strncmp(path,"\"^UP^",5) == 0) {
7208       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7209       return rslt;
7210     }
7211   }
7212 #endif
7213
7214   /* This is really the only way to see if this is already in VMS format */
7215   sts = vms_split_path
7216        (path,
7217         &v_spec,
7218         &v_len,
7219         &r_spec,
7220         &r_len,
7221         &d_spec,
7222         &d_len,
7223         &n_spec,
7224         &n_len,
7225         &e_spec,
7226         &e_len,
7227         &vs_spec,
7228         &vs_len);
7229   if (sts == 0) {
7230     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
7231        replacement, because the above parse just took care of most of
7232        what is needed to do vmspath when the specification is already
7233        in VMS format.
7234
7235        And if it is not already, it is easier to do the conversion as
7236        part of this routine than to call this routine and then work on
7237        the result.
7238      */
7239
7240     /* If VMS punctuation was found, it is already VMS format */
7241     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
7242       if (utf8_flag != NULL)
7243         *utf8_flag = 0;
7244       strcpy(rslt, path);
7245       return rslt;
7246     }
7247     /* Now, what to do with trailing "." cases where there is no
7248        extension?  If this is a UNIX specification, and EFS characters
7249        are enabled, then the trailing "." should be converted to a "^.".
7250        But if this was already a VMS specification, then it should be
7251        left alone.
7252
7253        So in the case of ambiguity, leave the specification alone.
7254      */
7255
7256
7257     /* If there is a possibility of UTF8, then if any UTF8 characters
7258         are present, then they must be converted to VTF-7
7259      */
7260     if (utf8_flag != NULL)
7261       *utf8_flag = 0;
7262     strcpy(rslt, path);
7263     return rslt;
7264   }
7265
7266   dirend = strrchr(path,'/');
7267
7268   if (dirend == NULL) {
7269      /* If we get here with no UNIX directory delimiters, then this is
7270         not a complete file specification, either garbage a UNIX glob
7271         specification that can not be converted to a VMS wildcard, or
7272         it a UNIX shell macro.  MakeMaker wants these passed through AS-IS,
7273         so apparently other programs expect this also.
7274
7275         utf8 flag setting needs to be preserved.
7276       */
7277       strcpy(rslt, path);
7278       return rslt;
7279   }
7280
7281 /* If POSIX mode active, handle the conversion */
7282 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7283   if (decc_efs_charset) {
7284     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7285     return rslt;
7286   }
7287 #endif
7288
7289   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
7290     if (!*(dirend+2)) dirend +=2;
7291     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7292     if (decc_efs_charset == 0) {
7293       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7294     }
7295   }
7296
7297   cp1 = rslt;
7298   cp2 = path;
7299   lastdot = strrchr(cp2,'.');
7300   if (*cp2 == '/') {
7301     char *trndev;
7302     int islnm, rooted;
7303     STRLEN trnend;
7304
7305     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7306     if (!*(cp2+1)) {
7307       if (decc_disable_posix_root) {
7308         strcpy(rslt,"sys$disk:[000000]");
7309       }
7310       else {
7311         strcpy(rslt,"sys$posix_root:[000000]");
7312       }
7313       if (utf8_flag != NULL)
7314         *utf8_flag = 0;
7315       return rslt;
7316     }
7317     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7318     *cp1 = '\0';
7319     trndev = PerlMem_malloc(VMS_MAXRSS);
7320     if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7321     islnm =  my_trnlnm(rslt,trndev,0);
7322
7323      /* DECC special handling */
7324     if (!islnm) {
7325       if (strcmp(rslt,"bin") == 0) {
7326         strcpy(rslt,"sys$system");
7327         cp1 = rslt + 10;
7328         *cp1 = 0;
7329         islnm =  my_trnlnm(rslt,trndev,0);
7330       }
7331       else if (strcmp(rslt,"tmp") == 0) {
7332         strcpy(rslt,"sys$scratch");
7333         cp1 = rslt + 11;
7334         *cp1 = 0;
7335         islnm =  my_trnlnm(rslt,trndev,0);
7336       }
7337       else if (!decc_disable_posix_root) {
7338         strcpy(rslt, "sys$posix_root");
7339         cp1 = rslt + 13;
7340         *cp1 = 0;
7341         cp2 = path;
7342         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7343         islnm =  my_trnlnm(rslt,trndev,0);
7344       }
7345       else if (strcmp(rslt,"dev") == 0) {
7346         if (strncmp(cp2,"/null", 5) == 0) {
7347           if ((cp2[5] == 0) || (cp2[5] == '/')) {
7348             strcpy(rslt,"NLA0");
7349             cp1 = rslt + 4;
7350             *cp1 = 0;
7351             cp2 = cp2 + 5;
7352             islnm =  my_trnlnm(rslt,trndev,0);
7353           }
7354         }
7355       }
7356     }
7357
7358     trnend = islnm ? strlen(trndev) - 1 : 0;
7359     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
7360     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
7361     /* If the first element of the path is a logical name, determine
7362      * whether it has to be translated so we can add more directories. */
7363     if (!islnm || rooted) {
7364       *(cp1++) = ':';
7365       *(cp1++) = '[';
7366       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
7367       else cp2++;
7368     }
7369     else {
7370       if (cp2 != dirend) {
7371         strcpy(rslt,trndev);
7372         cp1 = rslt + trnend;
7373         if (*cp2 != 0) {
7374           *(cp1++) = '.';
7375           cp2++;
7376         }
7377       }
7378       else {
7379         if (decc_disable_posix_root) {
7380           *(cp1++) = ':';
7381           hasdir = 0;
7382         }
7383       }
7384     }
7385     PerlMem_free(trndev);
7386   }
7387   else {
7388     *(cp1++) = '[';
7389     if (*cp2 == '.') {
7390       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
7391         cp2 += 2;         /* skip over "./" - it's redundant */
7392         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
7393       }
7394       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7395         *(cp1++) = '-';                                 /* "../" --> "-" */
7396         cp2 += 3;
7397       }
7398       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
7399                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
7400         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7401         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
7402         cp2 += 4;
7403       }
7404       else if ((cp2 != lastdot) || (lastdot < dirend)) {
7405         /* Escape the extra dots in EFS file specifications */
7406         *(cp1++) = '^';
7407       }
7408       if (cp2 > dirend) cp2 = dirend;
7409     }
7410     else *(cp1++) = '.';
7411   }
7412   for (; cp2 < dirend; cp2++) {
7413     if (*cp2 == '/') {
7414       if (*(cp2-1) == '/') continue;
7415       if (*(cp1-1) != '.') *(cp1++) = '.';
7416       infront = 0;
7417     }
7418     else if (!infront && *cp2 == '.') {
7419       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
7420       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
7421       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7422         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
7423         else if (*(cp1-2) == '[') *(cp1-1) = '-';
7424         else {  /* back up over previous directory name */
7425           cp1--;
7426           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
7427           if (*(cp1-1) == '[') {
7428             memcpy(cp1,"000000.",7);
7429             cp1 += 7;
7430           }
7431         }
7432         cp2 += 2;
7433         if (cp2 == dirend) break;
7434       }
7435       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
7436                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
7437         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
7438         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7439         if (!*(cp2+3)) {
7440           *(cp1++) = '.';  /* Simulate trailing '/' */
7441           cp2 += 2;  /* for loop will incr this to == dirend */
7442         }
7443         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
7444       }
7445       else {
7446         if (decc_efs_charset == 0)
7447           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
7448         else {
7449           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
7450           *(cp1++) = '.';
7451         }
7452       }
7453     }
7454     else {
7455       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
7456       if (*cp2 == '.') {
7457         if (decc_efs_charset == 0)
7458           *(cp1++) = '_';
7459         else {
7460           *(cp1++) = '^';
7461           *(cp1++) = '.';
7462         }
7463       }
7464       else                  *(cp1++) =  *cp2;
7465       infront = 1;
7466     }
7467   }
7468   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
7469   if (hasdir) *(cp1++) = ']';
7470   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
7471   /* fixme for ODS5 */
7472   no_type_seen = 0;
7473   if (cp2 > lastdot)
7474     no_type_seen = 1;
7475   while (*cp2) {
7476     switch(*cp2) {
7477     case '?':
7478         if (decc_efs_charset == 0)
7479           *(cp1++) = '%';
7480         else
7481           *(cp1++) = '?';
7482         cp2++;
7483     case ' ':
7484         *(cp1)++ = '^';
7485         *(cp1)++ = '_';
7486         cp2++;
7487         break;
7488     case '.':
7489         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
7490             decc_readdir_dropdotnotype) {
7491           *(cp1)++ = '^';
7492           *(cp1)++ = '.';
7493           cp2++;
7494
7495           /* trailing dot ==> '^..' on VMS */
7496           if (*cp2 == '\0') {
7497             *(cp1++) = '.';
7498             no_type_seen = 0;
7499           }
7500         }
7501         else {
7502           *(cp1++) = *(cp2++);
7503           no_type_seen = 0;
7504         }
7505         break;
7506     case '$':
7507          /* This could be a macro to be passed through */
7508         *(cp1++) = *(cp2++);
7509         if (*cp2 == '(') {
7510         const char * save_cp2;
7511         char * save_cp1;
7512         int is_macro;
7513
7514             /* paranoid check */
7515             save_cp2 = cp2;
7516             save_cp1 = cp1;
7517             is_macro = 0;
7518
7519             /* Test through */
7520             *(cp1++) = *(cp2++);
7521             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7522                 *(cp1++) = *(cp2++);
7523                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7524                     *(cp1++) = *(cp2++);
7525                 }
7526                 if (*cp2 == ')') {
7527                     *(cp1++) = *(cp2++);
7528                     is_macro = 1;
7529                 }
7530             }
7531             if (is_macro == 0) {
7532                 /* Not really a macro - never mind */
7533                 cp2 = save_cp2;
7534                 cp1 = save_cp1;
7535             }
7536         }
7537         break;
7538     case '\"':
7539     case '~':
7540     case '`':
7541     case '!':
7542     case '#':
7543     case '%':
7544     case '^':
7545     case '&':
7546     case '(':
7547     case ')':
7548     case '=':
7549     case '+':
7550     case '\'':
7551     case '@':
7552     case '[':
7553     case ']':
7554     case '{':
7555     case '}':
7556     case ':':
7557     case '\\':
7558     case '|':
7559     case '<':
7560     case '>':
7561         *(cp1++) = '^';
7562         *(cp1++) = *(cp2++);
7563         break;
7564     case ';':
7565         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
7566          * which is wrong.  UNIX notation should be ".dir." unless
7567          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
7568          * changing this behavior could break more things at this time.
7569          * efs character set effectively does not allow "." to be a version
7570          * delimiter as a further complication about changing this.
7571          */
7572         if (decc_filename_unix_report != 0) {
7573           *(cp1++) = '^';
7574         }
7575         *(cp1++) = *(cp2++);
7576         break;
7577     default:
7578         *(cp1++) = *(cp2++);
7579     }
7580   }
7581   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
7582   char *lcp1;
7583     lcp1 = cp1;
7584     lcp1--;
7585      /* Fix me for "^]", but that requires making sure that you do
7586       * not back up past the start of the filename
7587       */
7588     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
7589       *cp1++ = '.';
7590   }
7591   *cp1 = '\0';
7592
7593   if (utf8_flag != NULL)
7594     *utf8_flag = 0;
7595   return rslt;
7596
7597 }  /* end of do_tovmsspec() */
7598 /*}}}*/
7599 /* External entry points */
7600 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
7601   { return do_tovmsspec(path,buf,0,NULL); }
7602 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
7603   { return do_tovmsspec(path,buf,1,NULL); }
7604 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7605   { return do_tovmsspec(path,buf,0,utf8_fl); }
7606 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7607   { return do_tovmsspec(path,buf,1,utf8_fl); }
7608
7609 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
7610 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7611   static char __tovmspath_retbuf[VMS_MAXRSS];
7612   int vmslen;
7613   char *pathified, *vmsified, *cp;
7614
7615   if (path == NULL) return NULL;
7616   pathified = PerlMem_malloc(VMS_MAXRSS);
7617   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7618   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7619     PerlMem_free(pathified);
7620     return NULL;
7621   }
7622
7623   vmsified = NULL;
7624   if (buf == NULL)
7625      Newx(vmsified, VMS_MAXRSS, char);
7626   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
7627     PerlMem_free(pathified);
7628     if (vmsified) Safefree(vmsified);
7629     return NULL;
7630   }
7631   PerlMem_free(pathified);
7632   if (buf) {
7633     return buf;
7634   }
7635   else if (ts) {
7636     vmslen = strlen(vmsified);
7637     Newx(cp,vmslen+1,char);
7638     memcpy(cp,vmsified,vmslen);
7639     cp[vmslen] = '\0';
7640     Safefree(vmsified);
7641     return cp;
7642   }
7643   else {
7644     strcpy(__tovmspath_retbuf,vmsified);
7645     Safefree(vmsified);
7646     return __tovmspath_retbuf;
7647   }
7648
7649 }  /* end of do_tovmspath() */
7650 /*}}}*/
7651 /* External entry points */
7652 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
7653   { return do_tovmspath(path,buf,0, NULL); }
7654 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
7655   { return do_tovmspath(path,buf,1, NULL); }
7656 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
7657   { return do_tovmspath(path,buf,0,utf8_fl); }
7658 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
7659   { return do_tovmspath(path,buf,1,utf8_fl); }
7660
7661
7662 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
7663 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7664   static char __tounixpath_retbuf[VMS_MAXRSS];
7665   int unixlen;
7666   char *pathified, *unixified, *cp;
7667
7668   if (path == NULL) return NULL;
7669   pathified = PerlMem_malloc(VMS_MAXRSS);
7670   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7671   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7672     PerlMem_free(pathified);
7673     return NULL;
7674   }
7675
7676   unixified = NULL;
7677   if (buf == NULL) {
7678       Newx(unixified, VMS_MAXRSS, char);
7679   }
7680   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
7681     PerlMem_free(pathified);
7682     if (unixified) Safefree(unixified);
7683     return NULL;
7684   }
7685   PerlMem_free(pathified);
7686   if (buf) {
7687     return buf;
7688   }
7689   else if (ts) {
7690     unixlen = strlen(unixified);
7691     Newx(cp,unixlen+1,char);
7692     memcpy(cp,unixified,unixlen);
7693     cp[unixlen] = '\0';
7694     Safefree(unixified);
7695     return cp;
7696   }
7697   else {
7698     strcpy(__tounixpath_retbuf,unixified);
7699     Safefree(unixified);
7700     return __tounixpath_retbuf;
7701   }
7702
7703 }  /* end of do_tounixpath() */
7704 /*}}}*/
7705 /* External entry points */
7706 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
7707   { return do_tounixpath(path,buf,0,NULL); }
7708 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
7709   { return do_tounixpath(path,buf,1,NULL); }
7710 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7711   { return do_tounixpath(path,buf,0,utf8_fl); }
7712 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7713   { return do_tounixpath(path,buf,1,utf8_fl); }
7714
7715 /*
7716  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
7717  *
7718  *****************************************************************************
7719  *                                                                           *
7720  *  Copyright (C) 1989-1994 by                                               *
7721  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
7722  *                                                                           *
7723  *  Permission is hereby  granted for the reproduction of this software,     *
7724  *  on condition that this copyright notice is included in the reproduction, *
7725  *  and that such reproduction is not for purposes of profit or material     *
7726  *  gain.                                                                    *
7727  *                                                                           *
7728  *  27-Aug-1994 Modified for inclusion in perl5                              *
7729  *              by Charles Bailey  bailey@newman.upenn.edu                   *
7730  *****************************************************************************
7731  */
7732
7733 /*
7734  * getredirection() is intended to aid in porting C programs
7735  * to VMS (Vax-11 C).  The native VMS environment does not support
7736  * '>' and '<' I/O redirection, or command line wild card expansion,
7737  * or a command line pipe mechanism using the '|' AND background
7738  * command execution '&'.  All of these capabilities are provided to any
7739  * C program which calls this procedure as the first thing in the
7740  * main program.
7741  * The piping mechanism will probably work with almost any 'filter' type
7742  * of program.  With suitable modification, it may useful for other
7743  * portability problems as well.
7744  *
7745  * Author:  Mark Pizzolato      mark@infocomm.com
7746  */
7747 struct list_item
7748     {
7749     struct list_item *next;
7750     char *value;
7751     };
7752
7753 static void add_item(struct list_item **head,
7754                      struct list_item **tail,
7755                      char *value,
7756                      int *count);
7757
7758 static void mp_expand_wild_cards(pTHX_ char *item,
7759                                 struct list_item **head,
7760                                 struct list_item **tail,
7761                                 int *count);
7762
7763 static int background_process(pTHX_ int argc, char **argv);
7764
7765 static void pipe_and_fork(pTHX_ char **cmargv);
7766
7767 /*{{{ void getredirection(int *ac, char ***av)*/
7768 static void
7769 mp_getredirection(pTHX_ int *ac, char ***av)
7770 /*
7771  * Process vms redirection arg's.  Exit if any error is seen.
7772  * If getredirection() processes an argument, it is erased
7773  * from the vector.  getredirection() returns a new argc and argv value.
7774  * In the event that a background command is requested (by a trailing "&"),
7775  * this routine creates a background subprocess, and simply exits the program.
7776  *
7777  * Warning: do not try to simplify the code for vms.  The code
7778  * presupposes that getredirection() is called before any data is
7779  * read from stdin or written to stdout.
7780  *
7781  * Normal usage is as follows:
7782  *
7783  *      main(argc, argv)
7784  *      int             argc;
7785  *      char            *argv[];
7786  *      {
7787  *              getredirection(&argc, &argv);
7788  *      }
7789  */
7790 {
7791     int                 argc = *ac;     /* Argument Count         */
7792     char                **argv = *av;   /* Argument Vector        */
7793     char                *ap;            /* Argument pointer       */
7794     int                 j;              /* argv[] index           */
7795     int                 item_count = 0; /* Count of Items in List */
7796     struct list_item    *list_head = 0; /* First Item in List       */
7797     struct list_item    *list_tail;     /* Last Item in List        */
7798     char                *in = NULL;     /* Input File Name          */
7799     char                *out = NULL;    /* Output File Name         */
7800     char                *outmode = "w"; /* Mode to Open Output File */
7801     char                *err = NULL;    /* Error File Name          */
7802     char                *errmode = "w"; /* Mode to Open Error File  */
7803     int                 cmargc = 0;     /* Piped Command Arg Count  */
7804     char                **cmargv = NULL;/* Piped Command Arg Vector */
7805
7806     /*
7807      * First handle the case where the last thing on the line ends with
7808      * a '&'.  This indicates the desire for the command to be run in a
7809      * subprocess, so we satisfy that desire.
7810      */
7811     ap = argv[argc-1];
7812     if (0 == strcmp("&", ap))
7813        exit(background_process(aTHX_ --argc, argv));
7814     if (*ap && '&' == ap[strlen(ap)-1])
7815         {
7816         ap[strlen(ap)-1] = '\0';
7817        exit(background_process(aTHX_ argc, argv));
7818         }
7819     /*
7820      * Now we handle the general redirection cases that involve '>', '>>',
7821      * '<', and pipes '|'.
7822      */
7823     for (j = 0; j < argc; ++j)
7824         {
7825         if (0 == strcmp("<", argv[j]))
7826             {
7827             if (j+1 >= argc)
7828                 {
7829                 fprintf(stderr,"No input file after < on command line");
7830                 exit(LIB$_WRONUMARG);
7831                 }
7832             in = argv[++j];
7833             continue;
7834             }
7835         if ('<' == *(ap = argv[j]))
7836             {
7837             in = 1 + ap;
7838             continue;
7839             }
7840         if (0 == strcmp(">", ap))
7841             {
7842             if (j+1 >= argc)
7843                 {
7844                 fprintf(stderr,"No output file after > on command line");
7845                 exit(LIB$_WRONUMARG);
7846                 }
7847             out = argv[++j];
7848             continue;
7849             }
7850         if ('>' == *ap)
7851             {
7852             if ('>' == ap[1])
7853                 {
7854                 outmode = "a";
7855                 if ('\0' == ap[2])
7856                     out = argv[++j];
7857                 else
7858                     out = 2 + ap;
7859                 }
7860             else
7861                 out = 1 + ap;
7862             if (j >= argc)
7863                 {
7864                 fprintf(stderr,"No output file after > or >> on command line");
7865                 exit(LIB$_WRONUMARG);
7866                 }
7867             continue;
7868             }
7869         if (('2' == *ap) && ('>' == ap[1]))
7870             {
7871             if ('>' == ap[2])
7872                 {
7873                 errmode = "a";
7874                 if ('\0' == ap[3])
7875                     err = argv[++j];
7876                 else
7877                     err = 3 + ap;
7878                 }
7879             else
7880                 if ('\0' == ap[2])
7881                     err = argv[++j];
7882                 else
7883                     err = 2 + ap;
7884             if (j >= argc)
7885                 {
7886                 fprintf(stderr,"No output file after 2> or 2>> on command line");
7887                 exit(LIB$_WRONUMARG);
7888                 }
7889             continue;
7890             }
7891         if (0 == strcmp("|", argv[j]))
7892             {
7893             if (j+1 >= argc)
7894                 {
7895                 fprintf(stderr,"No command into which to pipe on command line");
7896                 exit(LIB$_WRONUMARG);
7897                 }
7898             cmargc = argc-(j+1);
7899             cmargv = &argv[j+1];
7900             argc = j;
7901             continue;
7902             }
7903         if ('|' == *(ap = argv[j]))
7904             {
7905             ++argv[j];
7906             cmargc = argc-j;
7907             cmargv = &argv[j];
7908             argc = j;
7909             continue;
7910             }
7911         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
7912         }
7913     /*
7914      * Allocate and fill in the new argument vector, Some Unix's terminate
7915      * the list with an extra null pointer.
7916      */
7917     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
7918     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7919     *av = argv;
7920     for (j = 0; j < item_count; ++j, list_head = list_head->next)
7921         argv[j] = list_head->value;
7922     *ac = item_count;
7923     if (cmargv != NULL)
7924         {
7925         if (out != NULL)
7926             {
7927             fprintf(stderr,"'|' and '>' may not both be specified on command line");
7928             exit(LIB$_INVARGORD);
7929             }
7930         pipe_and_fork(aTHX_ cmargv);
7931         }
7932
7933     /* Check for input from a pipe (mailbox) */
7934
7935     if (in == NULL && 1 == isapipe(0))
7936         {
7937         char mbxname[L_tmpnam];
7938         long int bufsize;
7939         long int dvi_item = DVI$_DEVBUFSIZ;
7940         $DESCRIPTOR(mbxnam, "");
7941         $DESCRIPTOR(mbxdevnam, "");
7942
7943         /* Input from a pipe, reopen it in binary mode to disable       */
7944         /* carriage control processing.                                 */
7945
7946         fgetname(stdin, mbxname);
7947         mbxnam.dsc$a_pointer = mbxname;
7948         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
7949         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
7950         mbxdevnam.dsc$a_pointer = mbxname;
7951         mbxdevnam.dsc$w_length = sizeof(mbxname);
7952         dvi_item = DVI$_DEVNAM;
7953         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
7954         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
7955         set_errno(0);
7956         set_vaxc_errno(1);
7957         freopen(mbxname, "rb", stdin);
7958         if (errno != 0)
7959             {
7960             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
7961             exit(vaxc$errno);
7962             }
7963         }
7964     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
7965         {
7966         fprintf(stderr,"Can't open input file %s as stdin",in);
7967         exit(vaxc$errno);
7968         }
7969     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
7970         {
7971         fprintf(stderr,"Can't open output file %s as stdout",out);
7972         exit(vaxc$errno);
7973         }
7974         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
7975
7976     if (err != NULL) {
7977         if (strcmp(err,"&1") == 0) {
7978             dup2(fileno(stdout), fileno(stderr));
7979             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
7980         } else {
7981         FILE *tmperr;
7982         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
7983             {
7984             fprintf(stderr,"Can't open error file %s as stderr",err);
7985             exit(vaxc$errno);
7986             }
7987             fclose(tmperr);
7988            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
7989                 {
7990                 exit(vaxc$errno);
7991                 }
7992             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
7993         }
7994         }
7995 #ifdef ARGPROC_DEBUG
7996     PerlIO_printf(Perl_debug_log, "Arglist:\n");
7997     for (j = 0; j < *ac;  ++j)
7998         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
7999 #endif
8000    /* Clear errors we may have hit expanding wildcards, so they don't
8001       show up in Perl's $! later */
8002    set_errno(0); set_vaxc_errno(1);
8003 }  /* end of getredirection() */
8004 /*}}}*/
8005
8006 static void add_item(struct list_item **head,
8007                      struct list_item **tail,
8008                      char *value,
8009                      int *count)
8010 {
8011     if (*head == 0)
8012         {
8013         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8014         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8015         *tail = *head;
8016         }
8017     else {
8018         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8019         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8020         *tail = (*tail)->next;
8021         }
8022     (*tail)->value = value;
8023     ++(*count);
8024 }
8025
8026 static void mp_expand_wild_cards(pTHX_ char *item,
8027                               struct list_item **head,
8028                               struct list_item **tail,
8029                               int *count)
8030 {
8031 int expcount = 0;
8032 unsigned long int context = 0;
8033 int isunix = 0;
8034 int item_len = 0;
8035 char *had_version;
8036 char *had_device;
8037 int had_directory;
8038 char *devdir,*cp;
8039 char *vmsspec;
8040 $DESCRIPTOR(filespec, "");
8041 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
8042 $DESCRIPTOR(resultspec, "");
8043 unsigned long int lff_flags = 0;
8044 int sts;
8045 int rms_sts;
8046
8047 #ifdef VMS_LONGNAME_SUPPORT
8048     lff_flags = LIB$M_FIL_LONG_NAMES;
8049 #endif
8050
8051     for (cp = item; *cp; cp++) {
8052         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
8053         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
8054     }
8055     if (!*cp || isspace(*cp))
8056         {
8057         add_item(head, tail, item, count);
8058         return;
8059         }
8060     else
8061         {
8062      /* "double quoted" wild card expressions pass as is */
8063      /* From DCL that means using e.g.:                  */
8064      /* perl program """perl.*"""                        */
8065      item_len = strlen(item);
8066      if ( '"' == *item && '"' == item[item_len-1] )
8067        {
8068        item++;
8069        item[item_len-2] = '\0';
8070        add_item(head, tail, item, count);
8071        return;
8072        }
8073      }
8074     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
8075     resultspec.dsc$b_class = DSC$K_CLASS_D;
8076     resultspec.dsc$a_pointer = NULL;
8077     vmsspec = PerlMem_malloc(VMS_MAXRSS);
8078     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8079     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
8080       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
8081     if (!isunix || !filespec.dsc$a_pointer)
8082       filespec.dsc$a_pointer = item;
8083     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
8084     /*
8085      * Only return version specs, if the caller specified a version
8086      */
8087     had_version = strchr(item, ';');
8088     /*
8089      * Only return device and directory specs, if the caller specifed either.
8090      */
8091     had_device = strchr(item, ':');
8092     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
8093
8094     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
8095                                  (&filespec, &resultspec, &context,
8096                                   &defaultspec, 0, &rms_sts, &lff_flags)))
8097         {
8098         char *string;
8099         char *c;
8100
8101         string = PerlMem_malloc(resultspec.dsc$w_length+1);
8102         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8103         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
8104         string[resultspec.dsc$w_length] = '\0';
8105         if (NULL == had_version)
8106             *(strrchr(string, ';')) = '\0';
8107         if ((!had_directory) && (had_device == NULL))
8108             {
8109             if (NULL == (devdir = strrchr(string, ']')))
8110                 devdir = strrchr(string, '>');
8111             strcpy(string, devdir + 1);
8112             }
8113         /*
8114          * Be consistent with what the C RTL has already done to the rest of
8115          * the argv items and lowercase all of these names.
8116          */
8117         if (!decc_efs_case_preserve) {
8118             for (c = string; *c; ++c)
8119             if (isupper(*c))
8120                 *c = tolower(*c);
8121         }
8122         if (isunix) trim_unixpath(string,item,1);
8123         add_item(head, tail, string, count);
8124         ++expcount;
8125     }
8126     PerlMem_free(vmsspec);
8127     if (sts != RMS$_NMF)
8128         {
8129         set_vaxc_errno(sts);
8130         switch (sts)
8131             {
8132             case RMS$_FNF: case RMS$_DNF:
8133                 set_errno(ENOENT); break;
8134             case RMS$_DIR:
8135                 set_errno(ENOTDIR); break;
8136             case RMS$_DEV:
8137                 set_errno(ENODEV); break;
8138             case RMS$_FNM: case RMS$_SYN:
8139                 set_errno(EINVAL); break;
8140             case RMS$_PRV:
8141                 set_errno(EACCES); break;
8142             default:
8143                 _ckvmssts_noperl(sts);
8144             }
8145         }
8146     if (expcount == 0)
8147         add_item(head, tail, item, count);
8148     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
8149     _ckvmssts_noperl(lib$find_file_end(&context));
8150 }
8151
8152 static int child_st[2];/* Event Flag set when child process completes   */
8153
8154 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
8155
8156 static unsigned long int exit_handler(int *status)
8157 {
8158 short iosb[4];
8159
8160     if (0 == child_st[0])
8161         {
8162 #ifdef ARGPROC_DEBUG
8163         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
8164 #endif
8165         fflush(stdout);     /* Have to flush pipe for binary data to    */
8166                             /* terminate properly -- <tp@mccall.com>    */
8167         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
8168         sys$dassgn(child_chan);
8169         fclose(stdout);
8170         sys$synch(0, child_st);
8171         }
8172     return(1);
8173 }
8174
8175 static void sig_child(int chan)
8176 {
8177 #ifdef ARGPROC_DEBUG
8178     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
8179 #endif
8180     if (child_st[0] == 0)
8181         child_st[0] = 1;
8182 }
8183
8184 static struct exit_control_block exit_block =
8185     {
8186     0,
8187     exit_handler,
8188     1,
8189     &exit_block.exit_status,
8190     0
8191     };
8192
8193 static void
8194 pipe_and_fork(pTHX_ char **cmargv)
8195 {
8196     PerlIO *fp;
8197     struct dsc$descriptor_s *vmscmd;
8198     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
8199     int sts, j, l, ismcr, quote, tquote = 0;
8200
8201     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
8202     vms_execfree(vmscmd);
8203
8204     j = l = 0;
8205     p = subcmd;
8206     q = cmargv[0];
8207     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
8208               && toupper(*(q+2)) == 'R' && !*(q+3);
8209
8210     while (q && l < MAX_DCL_LINE_LENGTH) {
8211         if (!*q) {
8212             if (j > 0 && quote) {
8213                 *p++ = '"';
8214                 l++;
8215             }
8216             q = cmargv[++j];
8217             if (q) {
8218                 if (ismcr && j > 1) quote = 1;
8219                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
8220                 *p++ = ' ';
8221                 l++;
8222                 if (quote || tquote) {
8223                     *p++ = '"';
8224                     l++;
8225                 }
8226             }
8227         } else {
8228             if ((quote||tquote) && *q == '"') {
8229                 *p++ = '"';
8230                 l++;
8231             }
8232             *p++ = *q++;
8233             l++;
8234         }
8235     }
8236     *p = '\0';
8237
8238     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
8239     if (fp == Nullfp) {
8240         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
8241     }
8242 }
8243
8244 static int background_process(pTHX_ int argc, char **argv)
8245 {
8246 char command[MAX_DCL_SYMBOL + 1] = "$";
8247 $DESCRIPTOR(value, "");
8248 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
8249 static $DESCRIPTOR(null, "NLA0:");
8250 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
8251 char pidstring[80];
8252 $DESCRIPTOR(pidstr, "");
8253 int pid;
8254 unsigned long int flags = 17, one = 1, retsts;
8255 int len;
8256
8257     strcat(command, argv[0]);
8258     len = strlen(command);
8259     while (--argc && (len < MAX_DCL_SYMBOL))
8260         {
8261         strcat(command, " \"");
8262         strcat(command, *(++argv));
8263         strcat(command, "\"");
8264         len = strlen(command);
8265         }
8266     value.dsc$a_pointer = command;
8267     value.dsc$w_length = strlen(value.dsc$a_pointer);
8268     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
8269     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
8270     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
8271         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8272     }
8273     else {
8274         _ckvmssts_noperl(retsts);
8275     }
8276 #ifdef ARGPROC_DEBUG
8277     PerlIO_printf(Perl_debug_log, "%s\n", command);
8278 #endif
8279     sprintf(pidstring, "%08X", pid);
8280     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8281     pidstr.dsc$a_pointer = pidstring;
8282     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8283     lib$set_symbol(&pidsymbol, &pidstr);
8284     return(SS$_NORMAL);
8285 }
8286 /*}}}*/
8287 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8288
8289
8290 /* OS-specific initialization at image activation (not thread startup) */
8291 /* Older VAXC header files lack these constants */
8292 #ifndef JPI$_RIGHTS_SIZE
8293 #  define JPI$_RIGHTS_SIZE 817
8294 #endif
8295 #ifndef KGB$M_SUBSYSTEM
8296 #  define KGB$M_SUBSYSTEM 0x8
8297 #endif
8298
8299 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8300
8301 /*{{{void vms_image_init(int *, char ***)*/
8302 void
8303 vms_image_init(int *argcp, char ***argvp)
8304 {
8305   char eqv[LNM$C_NAMLENGTH+1] = "";
8306   unsigned int len, tabct = 8, tabidx = 0;
8307   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8308   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8309   unsigned short int dummy, rlen;
8310   struct dsc$descriptor_s **tabvec;
8311 #if defined(PERL_IMPLICIT_CONTEXT)
8312   pTHX = NULL;
8313 #endif
8314   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
8315                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
8316                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8317                                  {          0,                0,    0,      0} };
8318
8319 #ifdef KILL_BY_SIGPRC
8320     Perl_csighandler_init();
8321 #endif
8322
8323   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8324   _ckvmssts_noperl(iosb[0]);
8325   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8326     if (iprv[i]) {           /* Running image installed with privs? */
8327       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
8328       will_taint = TRUE;
8329       break;
8330     }
8331   }
8332   /* Rights identifiers might trigger tainting as well. */
8333   if (!will_taint && (rlen || rsz)) {
8334     while (rlen < rsz) {
8335       /* We didn't get all the identifiers on the first pass.  Allocate a
8336        * buffer much larger than $GETJPI wants (rsz is size in bytes that
8337        * were needed to hold all identifiers at time of last call; we'll
8338        * allocate that many unsigned long ints), and go back and get 'em.
8339        * If it gave us less than it wanted to despite ample buffer space,
8340        * something's broken.  Is your system missing a system identifier?
8341        */
8342       if (rsz <= jpilist[1].buflen) {
8343          /* Perl_croak accvios when used this early in startup. */
8344          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
8345                          rsz, (unsigned long) jpilist[1].buflen,
8346                          "Check your rights database for corruption.\n");
8347          exit(SS$_ABORT);
8348       }
8349       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
8350       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
8351       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8352       jpilist[1].buflen = rsz * sizeof(unsigned long int);
8353       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
8354       _ckvmssts_noperl(iosb[0]);
8355     }
8356     mask = jpilist[1].bufadr;
8357     /* Check attribute flags for each identifier (2nd longword); protected
8358      * subsystem identifiers trigger tainting.
8359      */
8360     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
8361       if (mask[i] & KGB$M_SUBSYSTEM) {
8362         will_taint = TRUE;
8363         break;
8364       }
8365     }
8366     if (mask != rlst) PerlMem_free(mask);
8367   }
8368
8369   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
8370    * logical, some versions of the CRTL will add a phanthom /000000/
8371    * directory.  This needs to be removed.
8372    */
8373   if (decc_filename_unix_report) {
8374   char * zeros;
8375   int ulen;
8376     ulen = strlen(argvp[0][0]);
8377     if (ulen > 7) {
8378       zeros = strstr(argvp[0][0], "/000000/");
8379       if (zeros != NULL) {
8380         int mlen;
8381         mlen = ulen - (zeros - argvp[0][0]) - 7;
8382         memmove(zeros, &zeros[7], mlen);
8383         ulen = ulen - 7;
8384         argvp[0][0][ulen] = '\0';
8385       }
8386     }
8387     /* It also may have a trailing dot that needs to be removed otherwise
8388      * it will be converted to VMS mode incorrectly.
8389      */
8390     ulen--;
8391     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
8392       argvp[0][0][ulen] = '\0';
8393   }
8394
8395   /* We need to use this hack to tell Perl it should run with tainting,
8396    * since its tainting flag may be part of the PL_curinterp struct, which
8397    * hasn't been allocated when vms_image_init() is called.
8398    */
8399   if (will_taint) {
8400     char **newargv, **oldargv;
8401     oldargv = *argvp;
8402     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
8403     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8404     newargv[0] = oldargv[0];
8405     newargv[1] = PerlMem_malloc(3 * sizeof(char));
8406     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8407     strcpy(newargv[1], "-T");
8408     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
8409     (*argcp)++;
8410     newargv[*argcp] = NULL;
8411     /* We orphan the old argv, since we don't know where it's come from,
8412      * so we don't know how to free it.
8413      */
8414     *argvp = newargv;
8415   }
8416   else {  /* Did user explicitly request tainting? */
8417     int i;
8418     char *cp, **av = *argvp;
8419     for (i = 1; i < *argcp; i++) {
8420       if (*av[i] != '-') break;
8421       for (cp = av[i]+1; *cp; cp++) {
8422         if (*cp == 'T') { will_taint = 1; break; }
8423         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
8424                   strchr("DFIiMmx",*cp)) break;
8425       }
8426       if (will_taint) break;
8427     }
8428   }
8429
8430   for (tabidx = 0;
8431        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
8432        tabidx++) {
8433     if (!tabidx) {
8434       tabvec = (struct dsc$descriptor_s **)
8435             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
8436       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8437     }
8438     else if (tabidx >= tabct) {
8439       tabct += 8;
8440       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
8441       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8442     }
8443     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8444     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8445     tabvec[tabidx]->dsc$w_length  = 0;
8446     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
8447     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
8448     tabvec[tabidx]->dsc$a_pointer = NULL;
8449     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
8450   }
8451   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
8452
8453   getredirection(argcp,argvp);
8454 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
8455   {
8456 # include <reentrancy.h>
8457   decc$set_reentrancy(C$C_MULTITHREAD);
8458   }
8459 #endif
8460   return;
8461 }
8462 /*}}}*/
8463
8464
8465 /* trim_unixpath()
8466  * Trim Unix-style prefix off filespec, so it looks like what a shell
8467  * glob expansion would return (i.e. from specified prefix on, not
8468  * full path).  Note that returned filespec is Unix-style, regardless
8469  * of whether input filespec was VMS-style or Unix-style.
8470  *
8471  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
8472  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
8473  * vector of options; at present, only bit 0 is used, and if set tells
8474  * trim unixpath to try the current default directory as a prefix when
8475  * presented with a possibly ambiguous ... wildcard.
8476  *
8477  * Returns !=0 on success, with trimmed filespec replacing contents of
8478  * fspec, and 0 on failure, with contents of fpsec unchanged.
8479  */
8480 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
8481 int
8482 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
8483 {
8484   char *unixified, *unixwild,
8485        *template, *base, *end, *cp1, *cp2;
8486   register int tmplen, reslen = 0, dirs = 0;
8487
8488   unixwild = PerlMem_malloc(VMS_MAXRSS);
8489   if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
8490   if (!wildspec || !fspec) return 0;
8491   template = unixwild;
8492   if (strpbrk(wildspec,"]>:") != NULL) {
8493     if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
8494         PerlMem_free(unixwild);
8495         return 0;
8496     }
8497   }
8498   else {
8499     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
8500     unixwild[VMS_MAXRSS-1] = 0;
8501   }
8502   unixified = PerlMem_malloc(VMS_MAXRSS);
8503   if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
8504   if (strpbrk(fspec,"]>:") != NULL) {
8505     if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
8506         PerlMem_free(unixwild);
8507         PerlMem_free(unixified);
8508         return 0;
8509     }
8510     else base = unixified;
8511     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
8512      * check to see that final result fits into (isn't longer than) fspec */
8513     reslen = strlen(fspec);
8514   }
8515   else base = fspec;
8516
8517   /* No prefix or absolute path on wildcard, so nothing to remove */
8518   if (!*template || *template == '/') {
8519     PerlMem_free(unixwild);
8520     if (base == fspec) {
8521         PerlMem_free(unixified);
8522         return 1;
8523     }
8524     tmplen = strlen(unixified);
8525     if (tmplen > reslen) {
8526         PerlMem_free(unixified);
8527         return 0;  /* not enough space */
8528     }
8529     /* Copy unixified resultant, including trailing NUL */
8530     memmove(fspec,unixified,tmplen+1);
8531     PerlMem_free(unixified);
8532     return 1;
8533   }
8534
8535   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
8536   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
8537     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
8538     for (cp1 = end ;cp1 >= base; cp1--)
8539       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
8540         { cp1++; break; }
8541     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
8542     PerlMem_free(unixified);
8543     PerlMem_free(unixwild);
8544     return 1;
8545   }
8546   else {
8547     char *tpl, *lcres;
8548     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
8549     int ells = 1, totells, segdirs, match;
8550     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
8551                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8552
8553     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
8554     totells = ells;
8555     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
8556     tpl = PerlMem_malloc(VMS_MAXRSS);
8557     if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
8558     if (ellipsis == template && opts & 1) {
8559       /* Template begins with an ellipsis.  Since we can't tell how many
8560        * directory names at the front of the resultant to keep for an
8561        * arbitrary starting point, we arbitrarily choose the current
8562        * default directory as a starting point.  If it's there as a prefix,
8563        * clip it off.  If not, fall through and act as if the leading
8564        * ellipsis weren't there (i.e. return shortest possible path that
8565        * could match template).
8566        */
8567       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
8568           PerlMem_free(tpl);
8569           PerlMem_free(unixified);
8570           PerlMem_free(unixwild);
8571           return 0;
8572       }
8573       if (!decc_efs_case_preserve) {
8574         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8575           if (_tolower(*cp1) != _tolower(*cp2)) break;
8576       }
8577       segdirs = dirs - totells;  /* Min # of dirs we must have left */
8578       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
8579       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
8580         memmove(fspec,cp2+1,end - cp2);
8581         PerlMem_free(tpl);
8582         PerlMem_free(unixified);
8583         PerlMem_free(unixwild);
8584         return 1;
8585       }
8586     }
8587     /* First off, back up over constant elements at end of path */
8588     if (dirs) {
8589       for (front = end ; front >= base; front--)
8590          if (*front == '/' && !dirs--) { front++; break; }
8591     }
8592     lcres = PerlMem_malloc(VMS_MAXRSS);
8593     if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
8594     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
8595          cp1++,cp2++) {
8596             if (!decc_efs_case_preserve) {
8597                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
8598             }
8599             else {
8600                 *cp2 = *cp1;
8601             }
8602     }
8603     if (cp1 != '\0') {
8604         PerlMem_free(tpl);
8605         PerlMem_free(unixified);
8606         PerlMem_free(unixwild);
8607         PerlMem_free(lcres);
8608         return 0;  /* Path too long. */
8609     }
8610     lcend = cp2;
8611     *cp2 = '\0';  /* Pick up with memcpy later */
8612     lcfront = lcres + (front - base);
8613     /* Now skip over each ellipsis and try to match the path in front of it. */
8614     while (ells--) {
8615       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
8616         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
8617             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
8618       if (cp1 < template) break; /* template started with an ellipsis */
8619       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
8620         ellipsis = cp1; continue;
8621       }
8622       wilddsc.dsc$a_pointer = tpl;
8623       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
8624       nextell = cp1;
8625       for (segdirs = 0, cp2 = tpl;
8626            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
8627            cp1++, cp2++) {
8628          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
8629          else {
8630             if (!decc_efs_case_preserve) {
8631               *cp2 = _tolower(*cp1);  /* else lowercase for match */
8632             }
8633             else {
8634               *cp2 = *cp1;  /* else preserve case for match */
8635             }
8636          }
8637          if (*cp2 == '/') segdirs++;
8638       }
8639       if (cp1 != ellipsis - 1) {
8640           PerlMem_free(tpl);
8641           PerlMem_free(unixified);
8642           PerlMem_free(unixwild);
8643           PerlMem_free(lcres);
8644           return 0; /* Path too long */
8645       }
8646       /* Back up at least as many dirs as in template before matching */
8647       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
8648         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
8649       for (match = 0; cp1 > lcres;) {
8650         resdsc.dsc$a_pointer = cp1;
8651         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
8652           match++;
8653           if (match == 1) lcfront = cp1;
8654         }
8655         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
8656       }
8657       if (!match) {
8658         PerlMem_free(tpl);
8659         PerlMem_free(unixified);
8660         PerlMem_free(unixwild);
8661         PerlMem_free(lcres);
8662         return 0;  /* Can't find prefix ??? */
8663       }
8664       if (match > 1 && opts & 1) {
8665         /* This ... wildcard could cover more than one set of dirs (i.e.
8666          * a set of similar dir names is repeated).  If the template
8667          * contains more than 1 ..., upstream elements could resolve the
8668          * ambiguity, but it's not worth a full backtracking setup here.
8669          * As a quick heuristic, clip off the current default directory
8670          * if it's present to find the trimmed spec, else use the
8671          * shortest string that this ... could cover.
8672          */
8673         char def[NAM$C_MAXRSS+1], *st;
8674
8675         if (getcwd(def, sizeof def,0) == NULL) {
8676             Safefree(unixified);
8677             Safefree(unixwild);
8678             Safefree(lcres);
8679             Safefree(tpl);
8680             return 0;
8681         }
8682         if (!decc_efs_case_preserve) {
8683           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8684             if (_tolower(*cp1) != _tolower(*cp2)) break;
8685         }
8686         segdirs = dirs - totells;  /* Min # of dirs we must have left */
8687         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
8688         if (*cp1 == '\0' && *cp2 == '/') {
8689           memmove(fspec,cp2+1,end - cp2);
8690           PerlMem_free(tpl);
8691           PerlMem_free(unixified);
8692           PerlMem_free(unixwild);
8693           PerlMem_free(lcres);
8694           return 1;
8695         }
8696         /* Nope -- stick with lcfront from above and keep going. */
8697       }
8698     }
8699     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
8700     PerlMem_free(tpl);
8701     PerlMem_free(unixified);
8702     PerlMem_free(unixwild);
8703     PerlMem_free(lcres);
8704     return 1;
8705     ellipsis = nextell;
8706   }
8707
8708 }  /* end of trim_unixpath() */
8709 /*}}}*/
8710
8711
8712 /*
8713  *  VMS readdir() routines.
8714  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
8715  *
8716  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
8717  *  Minor modifications to original routines.
8718  */
8719
8720 /* readdir may have been redefined by reentr.h, so make sure we get
8721  * the local version for what we do here.
8722  */
8723 #ifdef readdir
8724 # undef readdir
8725 #endif
8726 #if !defined(PERL_IMPLICIT_CONTEXT)
8727 # define readdir Perl_readdir
8728 #else
8729 # define readdir(a) Perl_readdir(aTHX_ a)
8730 #endif
8731
8732     /* Number of elements in vms_versions array */
8733 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
8734
8735 /*
8736  *  Open a directory, return a handle for later use.
8737  */
8738 /*{{{ DIR *opendir(char*name) */
8739 DIR *
8740 Perl_opendir(pTHX_ const char *name)
8741 {
8742     DIR *dd;
8743     char *dir;
8744     Stat_t sb;
8745     int unix_flag;
8746
8747     unix_flag = 0;
8748     if (decc_efs_charset) {
8749         unix_flag = is_unix_filespec(name);
8750     }
8751
8752     Newx(dir, VMS_MAXRSS, char);
8753     if (do_tovmspath(name,dir,0,NULL) == NULL) {
8754       Safefree(dir);
8755       return NULL;
8756     }
8757     /* Check access before stat; otherwise stat does not
8758      * accurately report whether it's a directory.
8759      */
8760     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
8761       /* cando_by_name has already set errno */
8762       Safefree(dir);
8763       return NULL;
8764     }
8765     if (flex_stat(dir,&sb) == -1) return NULL;
8766     if (!S_ISDIR(sb.st_mode)) {
8767       Safefree(dir);
8768       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
8769       return NULL;
8770     }
8771     /* Get memory for the handle, and the pattern. */
8772     Newx(dd,1,DIR);
8773     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
8774
8775     /* Fill in the fields; mainly playing with the descriptor. */
8776     sprintf(dd->pattern, "%s*.*",dir);
8777     Safefree(dir);
8778     dd->context = 0;
8779     dd->count = 0;
8780     dd->flags = 0;
8781     if (unix_flag)
8782         dd->flags = PERL_VMSDIR_M_UNIXSPECS;
8783     dd->pat.dsc$a_pointer = dd->pattern;
8784     dd->pat.dsc$w_length = strlen(dd->pattern);
8785     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
8786     dd->pat.dsc$b_class = DSC$K_CLASS_S;
8787 #if defined(USE_ITHREADS)
8788     Newx(dd->mutex,1,perl_mutex);
8789     MUTEX_INIT( (perl_mutex *) dd->mutex );
8790 #else
8791     dd->mutex = NULL;
8792 #endif
8793
8794     return dd;
8795 }  /* end of opendir() */
8796 /*}}}*/
8797
8798 /*
8799  *  Set the flag to indicate we want versions or not.
8800  */
8801 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
8802 void
8803 vmsreaddirversions(DIR *dd, int flag)
8804 {
8805     if (flag)
8806         dd->flags |= PERL_VMSDIR_M_VERSIONS;
8807     else
8808         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8809 }
8810 /*}}}*/
8811
8812 /*
8813  *  Free up an opened directory.
8814  */
8815 /*{{{ void closedir(DIR *dd)*/
8816 void
8817 Perl_closedir(DIR *dd)
8818 {
8819     int sts;
8820
8821     sts = lib$find_file_end(&dd->context);
8822     Safefree(dd->pattern);
8823 #if defined(USE_ITHREADS)
8824     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
8825     Safefree(dd->mutex);
8826 #endif
8827     Safefree(dd);
8828 }
8829 /*}}}*/
8830
8831 /*
8832  *  Collect all the version numbers for the current file.
8833  */
8834 static void
8835 collectversions(pTHX_ DIR *dd)
8836 {
8837     struct dsc$descriptor_s     pat;
8838     struct dsc$descriptor_s     res;
8839     struct dirent *e;
8840     char *p, *text, *buff;
8841     int i;
8842     unsigned long context, tmpsts;
8843
8844     /* Convenient shorthand. */
8845     e = &dd->entry;
8846
8847     /* Add the version wildcard, ignoring the "*.*" put on before */
8848     i = strlen(dd->pattern);
8849     Newx(text,i + e->d_namlen + 3,char);
8850     strcpy(text, dd->pattern);
8851     sprintf(&text[i - 3], "%s;*", e->d_name);
8852
8853     /* Set up the pattern descriptor. */
8854     pat.dsc$a_pointer = text;
8855     pat.dsc$w_length = i + e->d_namlen - 1;
8856     pat.dsc$b_dtype = DSC$K_DTYPE_T;
8857     pat.dsc$b_class = DSC$K_CLASS_S;
8858
8859     /* Set up result descriptor. */
8860     Newx(buff, VMS_MAXRSS, char);
8861     res.dsc$a_pointer = buff;
8862     res.dsc$w_length = VMS_MAXRSS - 1;
8863     res.dsc$b_dtype = DSC$K_DTYPE_T;
8864     res.dsc$b_class = DSC$K_CLASS_S;
8865
8866     /* Read files, collecting versions. */
8867     for (context = 0, e->vms_verscount = 0;
8868          e->vms_verscount < VERSIZE(e);
8869          e->vms_verscount++) {
8870         unsigned long rsts;
8871         unsigned long flags = 0;
8872
8873 #ifdef VMS_LONGNAME_SUPPORT
8874         flags = LIB$M_FIL_LONG_NAMES;
8875 #endif
8876         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
8877         if (tmpsts == RMS$_NMF || context == 0) break;
8878         _ckvmssts(tmpsts);
8879         buff[VMS_MAXRSS - 1] = '\0';
8880         if ((p = strchr(buff, ';')))
8881             e->vms_versions[e->vms_verscount] = atoi(p + 1);
8882         else
8883             e->vms_versions[e->vms_verscount] = -1;
8884     }
8885
8886     _ckvmssts(lib$find_file_end(&context));
8887     Safefree(text);
8888     Safefree(buff);
8889
8890 }  /* end of collectversions() */
8891
8892 /*
8893  *  Read the next entry from the directory.
8894  */
8895 /*{{{ struct dirent *readdir(DIR *dd)*/
8896 struct dirent *
8897 Perl_readdir(pTHX_ DIR *dd)
8898 {
8899     struct dsc$descriptor_s     res;
8900     char *p, *buff;
8901     unsigned long int tmpsts;
8902     unsigned long rsts;
8903     unsigned long flags = 0;
8904     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8905     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8906
8907     /* Set up result descriptor, and get next file. */
8908     Newx(buff, VMS_MAXRSS, char);
8909     res.dsc$a_pointer = buff;
8910     res.dsc$w_length = VMS_MAXRSS - 1;
8911     res.dsc$b_dtype = DSC$K_DTYPE_T;
8912     res.dsc$b_class = DSC$K_CLASS_S;
8913
8914 #ifdef VMS_LONGNAME_SUPPORT
8915     flags = LIB$M_FIL_LONG_NAMES;
8916 #endif
8917
8918     tmpsts = lib$find_file
8919         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
8920     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
8921     if (!(tmpsts & 1)) {
8922       set_vaxc_errno(tmpsts);
8923       switch (tmpsts) {
8924         case RMS$_PRV:
8925           set_errno(EACCES); break;
8926         case RMS$_DEV:
8927           set_errno(ENODEV); break;
8928         case RMS$_DIR:
8929           set_errno(ENOTDIR); break;
8930         case RMS$_FNF: case RMS$_DNF:
8931           set_errno(ENOENT); break;
8932         default:
8933           set_errno(EVMSERR);
8934       }
8935       Safefree(buff);
8936       return NULL;
8937     }
8938     dd->count++;
8939     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
8940     if (!decc_efs_case_preserve) {
8941       buff[VMS_MAXRSS - 1] = '\0';
8942       for (p = buff; *p; p++) *p = _tolower(*p);
8943     }
8944     else {
8945       /* we don't want to force to lowercase, just null terminate */
8946       buff[res.dsc$w_length] = '\0';
8947     }
8948     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
8949     *p = '\0';
8950
8951     /* Skip any directory component and just copy the name. */
8952     sts = vms_split_path
8953        (buff,
8954         &v_spec,
8955         &v_len,
8956         &r_spec,
8957         &r_len,
8958         &d_spec,
8959         &d_len,
8960         &n_spec,
8961         &n_len,
8962         &e_spec,
8963         &e_len,
8964         &vs_spec,
8965         &vs_len);
8966
8967     /* Drop NULL extensions on UNIX file specification */
8968     if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
8969         (e_len == 1) && decc_readdir_dropdotnotype)) {
8970         e_len = 0;
8971         e_spec[0] = '\0';
8972     }
8973
8974     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
8975     dd->entry.d_name[n_len + e_len] = '\0';
8976     dd->entry.d_namlen = strlen(dd->entry.d_name);
8977
8978     /* Convert the filename to UNIX format if needed */
8979     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
8980
8981         /* Translate the encoded characters. */
8982         /* Fixme: unicode handling could result in embedded 0 characters */
8983         if (strchr(dd->entry.d_name, '^') != NULL) {
8984             char new_name[256];
8985             char * q;
8986             int cnt;
8987             p = dd->entry.d_name;
8988             q = new_name;
8989             while (*p != 0) {
8990                 int x, y;
8991                 x = copy_expand_vms_filename_escape(q, p, &y);
8992                 p += x;
8993                 q += y;
8994                 /* fix-me */
8995                 /* if y > 1, then this is a wide file specification */
8996                 /* Wide file specifications need to be passed in Perl */
8997                 /* counted strings apparently with a unicode flag */
8998             }
8999             *q = 0;
9000             strcpy(dd->entry.d_name, new_name);
9001         }
9002     }
9003
9004     dd->entry.vms_verscount = 0;
9005     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
9006     Safefree(buff);
9007     return &dd->entry;
9008
9009 }  /* end of readdir() */
9010 /*}}}*/
9011
9012 /*
9013  *  Read the next entry from the directory -- thread-safe version.
9014  */
9015 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
9016 int
9017 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
9018 {
9019     int retval;
9020
9021     MUTEX_LOCK( (perl_mutex *) dd->mutex );
9022
9023     entry = readdir(dd);
9024     *result = entry;
9025     retval = ( *result == NULL ? errno : 0 );
9026
9027     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
9028
9029     return retval;
9030
9031 }  /* end of readdir_r() */
9032 /*}}}*/
9033
9034 /*
9035  *  Return something that can be used in a seekdir later.
9036  */
9037 /*{{{ long telldir(DIR *dd)*/
9038 long
9039 Perl_telldir(DIR *dd)
9040 {
9041     return dd->count;
9042 }
9043 /*}}}*/
9044
9045 /*
9046  *  Return to a spot where we used to be.  Brute force.
9047  */
9048 /*{{{ void seekdir(DIR *dd,long count)*/
9049 void
9050 Perl_seekdir(pTHX_ DIR *dd, long count)
9051 {
9052     int old_flags;
9053
9054     /* If we haven't done anything yet... */
9055     if (dd->count == 0)
9056         return;
9057
9058     /* Remember some state, and clear it. */
9059     old_flags = dd->flags;
9060     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9061     _ckvmssts(lib$find_file_end(&dd->context));
9062     dd->context = 0;
9063
9064     /* The increment is in readdir(). */
9065     for (dd->count = 0; dd->count < count; )
9066         readdir(dd);
9067
9068     dd->flags = old_flags;
9069
9070 }  /* end of seekdir() */
9071 /*}}}*/
9072
9073 /* VMS subprocess management
9074  *
9075  * my_vfork() - just a vfork(), after setting a flag to record that
9076  * the current script is trying a Unix-style fork/exec.
9077  *
9078  * vms_do_aexec() and vms_do_exec() are called in response to the
9079  * perl 'exec' function.  If this follows a vfork call, then they
9080  * call out the regular perl routines in doio.c which do an
9081  * execvp (for those who really want to try this under VMS).
9082  * Otherwise, they do exactly what the perl docs say exec should
9083  * do - terminate the current script and invoke a new command
9084  * (See below for notes on command syntax.)
9085  *
9086  * do_aspawn() and do_spawn() implement the VMS side of the perl
9087  * 'system' function.
9088  *
9089  * Note on command arguments to perl 'exec' and 'system': When handled
9090  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
9091  * are concatenated to form a DCL command string.  If the first arg
9092  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
9093  * the command string is handed off to DCL directly.  Otherwise,
9094  * the first token of the command is taken as the filespec of an image
9095  * to run.  The filespec is expanded using a default type of '.EXE' and
9096  * the process defaults for device, directory, etc., and if found, the resultant
9097  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
9098  * the command string as parameters.  This is perhaps a bit complicated,
9099  * but I hope it will form a happy medium between what VMS folks expect
9100  * from lib$spawn and what Unix folks expect from exec.
9101  */
9102
9103 static int vfork_called;
9104
9105 /*{{{int my_vfork()*/
9106 int
9107 my_vfork()
9108 {
9109   vfork_called++;
9110   return vfork();
9111 }
9112 /*}}}*/
9113
9114
9115 static void
9116 vms_execfree(struct dsc$descriptor_s *vmscmd)
9117 {
9118   if (vmscmd) {
9119       if (vmscmd->dsc$a_pointer) {
9120           PerlMem_free(vmscmd->dsc$a_pointer);
9121       }
9122       PerlMem_free(vmscmd);
9123   }
9124 }
9125
9126 static char *
9127 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
9128 {
9129   char *junk, *tmps = Nullch;
9130   register size_t cmdlen = 0;
9131   size_t rlen;
9132   register SV **idx;
9133   STRLEN n_a;
9134
9135   idx = mark;
9136   if (really) {
9137     tmps = SvPV(really,rlen);
9138     if (*tmps) {
9139       cmdlen += rlen + 1;
9140       idx++;
9141     }
9142   }
9143
9144   for (idx++; idx <= sp; idx++) {
9145     if (*idx) {
9146       junk = SvPVx(*idx,rlen);
9147       cmdlen += rlen ? rlen + 1 : 0;
9148     }
9149   }
9150   Newx(PL_Cmd, cmdlen+1, char);
9151
9152   if (tmps && *tmps) {
9153     strcpy(PL_Cmd,tmps);
9154     mark++;
9155   }
9156   else *PL_Cmd = '\0';
9157   while (++mark <= sp) {
9158     if (*mark) {
9159       char *s = SvPVx(*mark,n_a);
9160       if (!*s) continue;
9161       if (*PL_Cmd) strcat(PL_Cmd," ");
9162       strcat(PL_Cmd,s);
9163     }
9164   }
9165   return PL_Cmd;
9166
9167 }  /* end of setup_argstr() */
9168
9169
9170 static unsigned long int
9171 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
9172                    struct dsc$descriptor_s **pvmscmd)
9173 {
9174   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
9175   char image_name[NAM$C_MAXRSS+1];
9176   char image_argv[NAM$C_MAXRSS+1];
9177   $DESCRIPTOR(defdsc,".EXE");
9178   $DESCRIPTOR(defdsc2,".");
9179   $DESCRIPTOR(resdsc,resspec);
9180   struct dsc$descriptor_s *vmscmd;
9181   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9182   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
9183   register char *s, *rest, *cp, *wordbreak;
9184   char * cmd;
9185   int cmdlen;
9186   register int isdcl;
9187
9188   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9189   if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
9190
9191   /* Make a copy for modification */
9192   cmdlen = strlen(incmd);
9193   cmd = PerlMem_malloc(cmdlen+1);
9194   if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
9195   strncpy(cmd, incmd, cmdlen);
9196   cmd[cmdlen] = 0;
9197   image_name[0] = 0;
9198   image_argv[0] = 0;
9199
9200   vmscmd->dsc$a_pointer = NULL;
9201   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
9202   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
9203   vmscmd->dsc$w_length = 0;
9204   if (pvmscmd) *pvmscmd = vmscmd;
9205
9206   if (suggest_quote) *suggest_quote = 0;
9207
9208   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
9209     PerlMem_free(cmd);
9210     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
9211   }
9212
9213   s = cmd;
9214
9215   while (*s && isspace(*s)) s++;
9216
9217   if (*s == '@' || *s == '$') {
9218     vmsspec[0] = *s;  rest = s + 1;
9219     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
9220   }
9221   else { cp = vmsspec; rest = s; }
9222   if (*rest == '.' || *rest == '/') {
9223     char *cp2;
9224     for (cp2 = resspec;
9225          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
9226          rest++, cp2++) *cp2 = *rest;
9227     *cp2 = '\0';
9228     if (do_tovmsspec(resspec,cp,0,NULL)) {
9229       s = vmsspec;
9230       if (*rest) {
9231         for (cp2 = vmsspec + strlen(vmsspec);
9232              *rest && cp2 - vmsspec < sizeof vmsspec;
9233              rest++, cp2++) *cp2 = *rest;
9234         *cp2 = '\0';
9235       }
9236     }
9237   }
9238   /* Intuit whether verb (first word of cmd) is a DCL command:
9239    *   - if first nonspace char is '@', it's a DCL indirection
9240    * otherwise
9241    *   - if verb contains a filespec separator, it's not a DCL command
9242    *   - if it doesn't, caller tells us whether to default to a DCL
9243    *     command, or to a local image unless told it's DCL (by leading '$')
9244    */
9245   if (*s == '@') {
9246       isdcl = 1;
9247       if (suggest_quote) *suggest_quote = 1;
9248   } else {
9249     register char *filespec = strpbrk(s,":<[.;");
9250     rest = wordbreak = strpbrk(s," \"\t/");
9251     if (!wordbreak) wordbreak = s + strlen(s);
9252     if (*s == '$') check_img = 0;
9253     if (filespec && (filespec < wordbreak)) isdcl = 0;
9254     else isdcl = !check_img;
9255   }
9256
9257   if (!isdcl) {
9258     int rsts;
9259     imgdsc.dsc$a_pointer = s;
9260     imgdsc.dsc$w_length = wordbreak - s;
9261     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9262     if (!(retsts&1)) {
9263         _ckvmssts(lib$find_file_end(&cxt));
9264         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9265       if (!(retsts & 1) && *s == '$') {
9266         _ckvmssts(lib$find_file_end(&cxt));
9267         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
9268         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9269         if (!(retsts&1)) {
9270           _ckvmssts(lib$find_file_end(&cxt));
9271           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9272         }
9273       }
9274     }
9275     _ckvmssts(lib$find_file_end(&cxt));
9276
9277     if (retsts & 1) {
9278       FILE *fp;
9279       s = resspec;
9280       while (*s && !isspace(*s)) s++;
9281       *s = '\0';
9282
9283       /* check that it's really not DCL with no file extension */
9284       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9285       if (fp) {
9286         char b[256] = {0,0,0,0};
9287         read(fileno(fp), b, 256);
9288         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9289         if (isdcl) {
9290           int shebang_len;
9291
9292           /* Check for script */
9293           shebang_len = 0;
9294           if ((b[0] == '#') && (b[1] == '!'))
9295              shebang_len = 2;
9296 #ifdef ALTERNATE_SHEBANG
9297           else {
9298             shebang_len = strlen(ALTERNATE_SHEBANG);
9299             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9300               char * perlstr;
9301                 perlstr = strstr("perl",b);
9302                 if (perlstr == NULL)
9303                   shebang_len = 0;
9304             }
9305             else
9306               shebang_len = 0;
9307           }
9308 #endif
9309
9310           if (shebang_len > 0) {
9311           int i;
9312           int j;
9313           char tmpspec[NAM$C_MAXRSS + 1];
9314
9315             i = shebang_len;
9316              /* Image is following after white space */
9317             /*--------------------------------------*/
9318             while (isprint(b[i]) && isspace(b[i]))
9319                 i++;
9320
9321             j = 0;
9322             while (isprint(b[i]) && !isspace(b[i])) {
9323                 tmpspec[j++] = b[i++];
9324                 if (j >= NAM$C_MAXRSS)
9325                    break;
9326             }
9327             tmpspec[j] = '\0';
9328
9329              /* There may be some default parameters to the image */
9330             /*---------------------------------------------------*/
9331             j = 0;
9332             while (isprint(b[i])) {
9333                 image_argv[j++] = b[i++];
9334                 if (j >= NAM$C_MAXRSS)
9335                    break;
9336             }
9337             while ((j > 0) && !isprint(image_argv[j-1]))
9338                 j--;
9339             image_argv[j] = 0;
9340
9341             /* It will need to be converted to VMS format and validated */
9342             if (tmpspec[0] != '\0') {
9343               char * iname;
9344
9345                /* Try to find the exact program requested to be run */
9346               /*---------------------------------------------------*/
9347               iname = do_rmsexpand
9348                  (tmpspec, image_name, 0, ".exe",
9349                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
9350               if (iname != NULL) {
9351                 if (cando_by_name_int
9352                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
9353                   /* MCR prefix needed */
9354                   isdcl = 0;
9355                 }
9356                 else {
9357                    /* Try again with a null type */
9358                   /*----------------------------*/
9359                   iname = do_rmsexpand
9360                     (tmpspec, image_name, 0, ".",
9361                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
9362                   if (iname != NULL) {
9363                     if (cando_by_name_int
9364                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
9365                       /* MCR prefix needed */
9366                       isdcl = 0;
9367                     }
9368                   }
9369                 }
9370
9371                  /* Did we find the image to run the script? */
9372                 /*------------------------------------------*/
9373                 if (isdcl) {
9374                   char *tchr;
9375
9376                    /* Assume DCL or foreign command exists */
9377                   /*--------------------------------------*/
9378                   tchr = strrchr(tmpspec, '/');
9379                   if (tchr != NULL) {
9380                     tchr++;
9381                   }
9382                   else {
9383                     tchr = tmpspec;
9384                   }
9385                   strcpy(image_name, tchr);
9386                 }
9387               }
9388             }
9389           }
9390         }
9391         fclose(fp);
9392       }
9393       if (check_img && isdcl) return RMS$_FNF;
9394
9395       if (cando_by_name(S_IXUSR,0,resspec)) {
9396         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
9397         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
9398         if (!isdcl) {
9399             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
9400             if (image_name[0] != 0) {
9401                 strcat(vmscmd->dsc$a_pointer, image_name);
9402                 strcat(vmscmd->dsc$a_pointer, " ");
9403             }
9404         } else if (image_name[0] != 0) {
9405             strcpy(vmscmd->dsc$a_pointer, image_name);
9406             strcat(vmscmd->dsc$a_pointer, " ");
9407         } else {
9408             strcpy(vmscmd->dsc$a_pointer,"@");
9409         }
9410         if (suggest_quote) *suggest_quote = 1;
9411
9412         /* If there is an image name, use original command */
9413         if (image_name[0] == 0)
9414             strcat(vmscmd->dsc$a_pointer,resspec);
9415         else {
9416             rest = cmd;
9417             while (*rest && isspace(*rest)) rest++;
9418         }
9419
9420         if (image_argv[0] != 0) {
9421           strcat(vmscmd->dsc$a_pointer,image_argv);
9422           strcat(vmscmd->dsc$a_pointer, " ");
9423         }
9424         if (rest) {
9425            int rest_len;
9426            int vmscmd_len;
9427
9428            rest_len = strlen(rest);
9429            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
9430            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
9431               strcat(vmscmd->dsc$a_pointer,rest);
9432            else
9433              retsts = CLI$_BUFOVF;
9434         }
9435         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
9436         PerlMem_free(cmd);
9437         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9438       }
9439       else
9440         retsts = RMS$_PRV;
9441     }
9442   }
9443   /* It's either a DCL command or we couldn't find a suitable image */
9444   vmscmd->dsc$w_length = strlen(cmd);
9445
9446   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
9447   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
9448   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
9449
9450   PerlMem_free(cmd);
9451
9452   /* check if it's a symbol (for quoting purposes) */
9453   if (suggest_quote && !*suggest_quote) {
9454     int iss;
9455     char equiv[LNM$C_NAMLENGTH];
9456     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9457     eqvdsc.dsc$a_pointer = equiv;
9458
9459     iss = lib$get_symbol(vmscmd,&eqvdsc);
9460     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
9461   }
9462   if (!(retsts & 1)) {
9463     /* just hand off status values likely to be due to user error */
9464     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
9465         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
9466        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
9467     else { _ckvmssts(retsts); }
9468   }
9469
9470   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9471
9472 }  /* end of setup_cmddsc() */
9473
9474
9475 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
9476 bool
9477 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
9478 {
9479 bool exec_sts;
9480 char * cmd;
9481
9482   if (sp > mark) {
9483     if (vfork_called) {           /* this follows a vfork - act Unixish */
9484       vfork_called--;
9485       if (vfork_called < 0) {
9486         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9487         vfork_called = 0;
9488       }
9489       else return do_aexec(really,mark,sp);
9490     }
9491                                            /* no vfork - act VMSish */
9492     cmd = setup_argstr(aTHX_ really,mark,sp);
9493     exec_sts = vms_do_exec(cmd);
9494     Safefree(cmd);  /* Clean up from setup_argstr() */
9495     return exec_sts;
9496   }
9497
9498   return FALSE;
9499 }  /* end of vms_do_aexec() */
9500 /*}}}*/
9501
9502 /* {{{bool vms_do_exec(char *cmd) */
9503 bool
9504 Perl_vms_do_exec(pTHX_ const char *cmd)
9505 {
9506   struct dsc$descriptor_s *vmscmd;
9507
9508   if (vfork_called) {             /* this follows a vfork - act Unixish */
9509     vfork_called--;
9510     if (vfork_called < 0) {
9511       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9512       vfork_called = 0;
9513     }
9514     else return do_exec(cmd);
9515   }
9516
9517   {                               /* no vfork - act VMSish */
9518     unsigned long int retsts;
9519
9520     TAINT_ENV();
9521     TAINT_PROPER("exec");
9522     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
9523       retsts = lib$do_command(vmscmd);
9524
9525     switch (retsts) {
9526       case RMS$_FNF: case RMS$_DNF:
9527         set_errno(ENOENT); break;
9528       case RMS$_DIR:
9529         set_errno(ENOTDIR); break;
9530       case RMS$_DEV:
9531         set_errno(ENODEV); break;
9532       case RMS$_PRV:
9533         set_errno(EACCES); break;
9534       case RMS$_SYN:
9535         set_errno(EINVAL); break;
9536       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9537         set_errno(E2BIG); break;
9538       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9539         _ckvmssts(retsts); /* fall through */
9540       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9541         set_errno(EVMSERR);
9542     }
9543     set_vaxc_errno(retsts);
9544     if (ckWARN(WARN_EXEC)) {
9545       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
9546              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
9547     }
9548     vms_execfree(vmscmd);
9549   }
9550
9551   return FALSE;
9552
9553 }  /* end of vms_do_exec() */
9554 /*}}}*/
9555
9556 unsigned long int Perl_do_spawn(pTHX_ const char *);
9557
9558 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
9559 unsigned long int
9560 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
9561 {
9562 unsigned long int sts;
9563 char * cmd;
9564
9565   if (sp > mark) {
9566     cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
9567     sts = do_spawn(cmd);
9568     /* pp_sys will clean up cmd */
9569     return sts;
9570   }
9571   return SS$_ABORT;
9572 }  /* end of do_aspawn() */
9573 /*}}}*/
9574
9575 /* {{{unsigned long int do_spawn(char *cmd) */
9576 unsigned long int
9577 Perl_do_spawn(pTHX_ const char *cmd)
9578 {
9579   unsigned long int sts, substs;
9580
9581   /* The caller of this routine expects to Safefree(PL_Cmd) */
9582   Newx(PL_Cmd,10,char);
9583
9584   TAINT_ENV();
9585   TAINT_PROPER("spawn");
9586   if (!cmd || !*cmd) {
9587     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
9588     if (!(sts & 1)) {
9589       switch (sts) {
9590         case RMS$_FNF:  case RMS$_DNF:
9591           set_errno(ENOENT); break;
9592         case RMS$_DIR:
9593           set_errno(ENOTDIR); break;
9594         case RMS$_DEV:
9595           set_errno(ENODEV); break;
9596         case RMS$_PRV:
9597           set_errno(EACCES); break;
9598         case RMS$_SYN:
9599           set_errno(EINVAL); break;
9600         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9601           set_errno(E2BIG); break;
9602         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9603           _ckvmssts(sts); /* fall through */
9604         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9605           set_errno(EVMSERR);
9606       }
9607       set_vaxc_errno(sts);
9608       if (ckWARN(WARN_EXEC)) {
9609         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
9610                     Strerror(errno));
9611       }
9612     }
9613     sts = substs;
9614   }
9615   else {
9616     PerlIO * fp;
9617     fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
9618     if (fp != NULL)
9619       my_pclose(fp);
9620   }
9621   return sts;
9622 }  /* end of do_spawn() */
9623 /*}}}*/
9624
9625
9626 static unsigned int *sockflags, sockflagsize;
9627
9628 /*
9629  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
9630  * routines found in some versions of the CRTL can't deal with sockets.
9631  * We don't shim the other file open routines since a socket isn't
9632  * likely to be opened by a name.
9633  */
9634 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
9635 FILE *my_fdopen(int fd, const char *mode)
9636 {
9637   FILE *fp = fdopen(fd, mode);
9638
9639   if (fp) {
9640     unsigned int fdoff = fd / sizeof(unsigned int);
9641     Stat_t sbuf; /* native stat; we don't need flex_stat */
9642     if (!sockflagsize || fdoff > sockflagsize) {
9643       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
9644       else           Newx  (sockflags,fdoff+2,unsigned int);
9645       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
9646       sockflagsize = fdoff + 2;
9647     }
9648     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
9649       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
9650   }
9651   return fp;
9652
9653 }
9654 /*}}}*/
9655
9656
9657 /*
9658  * Clear the corresponding bit when the (possibly) socket stream is closed.
9659  * There still a small hole: we miss an implicit close which might occur
9660  * via freopen().  >> Todo
9661  */
9662 /*{{{ int my_fclose(FILE *fp)*/
9663 int my_fclose(FILE *fp) {
9664   if (fp) {
9665     unsigned int fd = fileno(fp);
9666     unsigned int fdoff = fd / sizeof(unsigned int);
9667
9668     if (sockflagsize && fdoff <= sockflagsize)
9669       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
9670   }
9671   return fclose(fp);
9672 }
9673 /*}}}*/
9674
9675
9676 /*
9677  * A simple fwrite replacement which outputs itmsz*nitm chars without
9678  * introducing record boundaries every itmsz chars.
9679  * We are using fputs, which depends on a terminating null.  We may
9680  * well be writing binary data, so we need to accommodate not only
9681  * data with nulls sprinkled in the middle but also data with no null
9682  * byte at the end.
9683  */
9684 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
9685 int
9686 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
9687 {
9688   register char *cp, *end, *cpd, *data;
9689   register unsigned int fd = fileno(dest);
9690   register unsigned int fdoff = fd / sizeof(unsigned int);
9691   int retval;
9692   int bufsize = itmsz * nitm + 1;
9693
9694   if (fdoff < sockflagsize &&
9695       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
9696     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
9697     return nitm;
9698   }
9699
9700   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
9701   memcpy( data, src, itmsz*nitm );
9702   data[itmsz*nitm] = '\0';
9703
9704   end = data + itmsz * nitm;
9705   retval = (int) nitm; /* on success return # items written */
9706
9707   cpd = data;
9708   while (cpd <= end) {
9709     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
9710     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
9711     if (cp < end)
9712       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
9713     cpd = cp + 1;
9714   }
9715
9716   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
9717   return retval;
9718
9719 }  /* end of my_fwrite() */
9720 /*}}}*/
9721
9722 /*{{{ int my_flush(FILE *fp)*/
9723 int
9724 Perl_my_flush(pTHX_ FILE *fp)
9725 {
9726     int res;
9727     if ((res = fflush(fp)) == 0 && fp) {
9728 #ifdef VMS_DO_SOCKETS
9729         Stat_t s;
9730         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
9731 #endif
9732             res = fsync(fileno(fp));
9733     }
9734 /*
9735  * If the flush succeeded but set end-of-file, we need to clear
9736  * the error because our caller may check ferror().  BTW, this
9737  * probably means we just flushed an empty file.
9738  */
9739     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
9740
9741     return res;
9742 }
9743 /*}}}*/
9744
9745 /*
9746  * Here are replacements for the following Unix routines in the VMS environment:
9747  *      getpwuid    Get information for a particular UIC or UID
9748  *      getpwnam    Get information for a named user
9749  *      getpwent    Get information for each user in the rights database
9750  *      setpwent    Reset search to the start of the rights database
9751  *      endpwent    Finish searching for users in the rights database
9752  *
9753  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
9754  * (defined in pwd.h), which contains the following fields:-
9755  *      struct passwd {
9756  *              char        *pw_name;    Username (in lower case)
9757  *              char        *pw_passwd;  Hashed password
9758  *              unsigned int pw_uid;     UIC
9759  *              unsigned int pw_gid;     UIC group  number
9760  *              char        *pw_unixdir; Default device/directory (VMS-style)
9761  *              char        *pw_gecos;   Owner name
9762  *              char        *pw_dir;     Default device/directory (Unix-style)
9763  *              char        *pw_shell;   Default CLI name (eg. DCL)
9764  *      };
9765  * If the specified user does not exist, getpwuid and getpwnam return NULL.
9766  *
9767  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
9768  * not the UIC member number (eg. what's returned by getuid()),
9769  * getpwuid() can accept either as input (if uid is specified, the caller's
9770  * UIC group is used), though it won't recognise gid=0.
9771  *
9772  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
9773  * information about other users in your group or in other groups, respectively.
9774  * If the required privilege is not available, then these routines fill only
9775  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
9776  * string).
9777  *
9778  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
9779  */
9780
9781 /* sizes of various UAF record fields */
9782 #define UAI$S_USERNAME 12
9783 #define UAI$S_IDENT    31
9784 #define UAI$S_OWNER    31
9785 #define UAI$S_DEFDEV   31
9786 #define UAI$S_DEFDIR   63
9787 #define UAI$S_DEFCLI   31
9788 #define UAI$S_PWD       8
9789
9790 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
9791                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
9792                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
9793
9794 static char __empty[]= "";
9795 static struct passwd __passwd_empty=
9796     {(char *) __empty, (char *) __empty, 0, 0,
9797      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
9798 static int contxt= 0;
9799 static struct passwd __pwdcache;
9800 static char __pw_namecache[UAI$S_IDENT+1];
9801
9802 /*
9803  * This routine does most of the work extracting the user information.
9804  */
9805 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
9806 {
9807     static struct {
9808         unsigned char length;
9809         char pw_gecos[UAI$S_OWNER+1];
9810     } owner;
9811     static union uicdef uic;
9812     static struct {
9813         unsigned char length;
9814         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
9815     } defdev;
9816     static struct {
9817         unsigned char length;
9818         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
9819     } defdir;
9820     static struct {
9821         unsigned char length;
9822         char pw_shell[UAI$S_DEFCLI+1];
9823     } defcli;
9824     static char pw_passwd[UAI$S_PWD+1];
9825
9826     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
9827     struct dsc$descriptor_s name_desc;
9828     unsigned long int sts;
9829
9830     static struct itmlst_3 itmlst[]= {
9831         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
9832         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
9833         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
9834         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
9835         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
9836         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
9837         {0,                0,           NULL,    NULL}};
9838
9839     name_desc.dsc$w_length=  strlen(name);
9840     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
9841     name_desc.dsc$b_class=   DSC$K_CLASS_S;
9842     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
9843
9844 /*  Note that sys$getuai returns many fields as counted strings. */
9845     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
9846     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
9847       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
9848     }
9849     else { _ckvmssts(sts); }
9850     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
9851
9852     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
9853     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
9854     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
9855     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
9856     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
9857     owner.pw_gecos[lowner]=            '\0';
9858     defdev.pw_dir[ldefdev+ldefdir]= '\0';
9859     defcli.pw_shell[ldefcli]=          '\0';
9860     if (valid_uic(uic)) {
9861         pwd->pw_uid= uic.uic$l_uic;
9862         pwd->pw_gid= uic.uic$v_group;
9863     }
9864     else
9865       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
9866     pwd->pw_passwd=  pw_passwd;
9867     pwd->pw_gecos=   owner.pw_gecos;
9868     pwd->pw_dir=     defdev.pw_dir;
9869     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
9870     pwd->pw_shell=   defcli.pw_shell;
9871     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
9872         int ldir;
9873         ldir= strlen(pwd->pw_unixdir) - 1;
9874         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
9875     }
9876     else
9877         strcpy(pwd->pw_unixdir, pwd->pw_dir);
9878     if (!decc_efs_case_preserve)
9879         __mystrtolower(pwd->pw_unixdir);
9880     return 1;
9881 }
9882
9883 /*
9884  * Get information for a named user.
9885 */
9886 /*{{{struct passwd *getpwnam(char *name)*/
9887 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
9888 {
9889     struct dsc$descriptor_s name_desc;
9890     union uicdef uic;
9891     unsigned long int status, sts;
9892
9893     __pwdcache = __passwd_empty;
9894     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
9895       /* We still may be able to determine pw_uid and pw_gid */
9896       name_desc.dsc$w_length=  strlen(name);
9897       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
9898       name_desc.dsc$b_class=   DSC$K_CLASS_S;
9899       name_desc.dsc$a_pointer= (char *) name;
9900       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
9901         __pwdcache.pw_uid= uic.uic$l_uic;
9902         __pwdcache.pw_gid= uic.uic$v_group;
9903       }
9904       else {
9905         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
9906           set_vaxc_errno(sts);
9907           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
9908           return NULL;
9909         }
9910         else { _ckvmssts(sts); }
9911       }
9912     }
9913     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
9914     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
9915     __pwdcache.pw_name= __pw_namecache;
9916     return &__pwdcache;
9917 }  /* end of my_getpwnam() */
9918 /*}}}*/
9919
9920 /*
9921  * Get information for a particular UIC or UID.
9922  * Called by my_getpwent with uid=-1 to list all users.
9923 */
9924 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
9925 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
9926 {
9927     const $DESCRIPTOR(name_desc,__pw_namecache);
9928     unsigned short lname;
9929     union uicdef uic;
9930     unsigned long int status;
9931
9932     if (uid == (unsigned int) -1) {
9933       do {
9934         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
9935         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
9936           set_vaxc_errno(status);
9937           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9938           my_endpwent();
9939           return NULL;
9940         }
9941         else { _ckvmssts(status); }
9942       } while (!valid_uic (uic));
9943     }
9944     else {
9945       uic.uic$l_uic= uid;
9946       if (!uic.uic$v_group)
9947         uic.uic$v_group= PerlProc_getgid();
9948       if (valid_uic(uic))
9949         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
9950       else status = SS$_IVIDENT;
9951       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
9952           status == RMS$_PRV) {
9953         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9954         return NULL;
9955       }
9956       else { _ckvmssts(status); }
9957     }
9958     __pw_namecache[lname]= '\0';
9959     __mystrtolower(__pw_namecache);
9960
9961     __pwdcache = __passwd_empty;
9962     __pwdcache.pw_name = __pw_namecache;
9963
9964 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
9965     The identifier's value is usually the UIC, but it doesn't have to be,
9966     so if we can, we let fillpasswd update this. */
9967     __pwdcache.pw_uid =  uic.uic$l_uic;
9968     __pwdcache.pw_gid =  uic.uic$v_group;
9969
9970     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
9971     return &__pwdcache;
9972
9973 }  /* end of my_getpwuid() */
9974 /*}}}*/
9975
9976 /*
9977  * Get information for next user.
9978 */
9979 /*{{{struct passwd *my_getpwent()*/
9980 struct passwd *Perl_my_getpwent(pTHX)
9981 {
9982     return (my_getpwuid((unsigned int) -1));
9983 }
9984 /*}}}*/
9985
9986 /*
9987  * Finish searching rights database for users.
9988 */
9989 /*{{{void my_endpwent()*/
9990 void Perl_my_endpwent(pTHX)
9991 {
9992     if (contxt) {
9993       _ckvmssts(sys$finish_rdb(&contxt));
9994       contxt= 0;
9995     }
9996 }
9997 /*}}}*/
9998
9999 #ifdef HOMEGROWN_POSIX_SIGNALS
10000   /* Signal handling routines, pulled into the core from POSIX.xs.
10001    *
10002    * We need these for threads, so they've been rolled into the core,
10003    * rather than left in POSIX.xs.
10004    *
10005    * (DRS, Oct 23, 1997)
10006    */
10007
10008   /* sigset_t is atomic under VMS, so these routines are easy */
10009 /*{{{int my_sigemptyset(sigset_t *) */
10010 int my_sigemptyset(sigset_t *set) {
10011     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10012     *set = 0; return 0;
10013 }
10014 /*}}}*/
10015
10016
10017 /*{{{int my_sigfillset(sigset_t *)*/
10018 int my_sigfillset(sigset_t *set) {
10019     int i;
10020     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10021     for (i = 0; i < NSIG; i++) *set |= (1 << i);
10022     return 0;
10023 }
10024 /*}}}*/
10025
10026
10027 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
10028 int my_sigaddset(sigset_t *set, int sig) {
10029     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10030     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10031     *set |= (1 << (sig - 1));
10032     return 0;
10033 }
10034 /*}}}*/
10035
10036
10037 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
10038 int my_sigdelset(sigset_t *set, int sig) {
10039     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10040     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10041     *set &= ~(1 << (sig - 1));
10042     return 0;
10043 }
10044 /*}}}*/
10045
10046
10047 /*{{{int my_sigismember(sigset_t *set, int sig)*/
10048 int my_sigismember(sigset_t *set, int sig) {
10049     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10050     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10051     return *set & (1 << (sig - 1));
10052 }
10053 /*}}}*/
10054
10055
10056 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10057 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10058     sigset_t tempmask;
10059
10060     /* If set and oset are both null, then things are badly wrong. Bail out. */
10061     if ((oset == NULL) && (set == NULL)) {
10062       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
10063       return -1;
10064     }
10065
10066     /* If set's null, then we're just handling a fetch. */
10067     if (set == NULL) {
10068         tempmask = sigblock(0);
10069     }
10070     else {
10071       switch (how) {
10072       case SIG_SETMASK:
10073         tempmask = sigsetmask(*set);
10074         break;
10075       case SIG_BLOCK:
10076         tempmask = sigblock(*set);
10077         break;
10078       case SIG_UNBLOCK:
10079         tempmask = sigblock(0);
10080         sigsetmask(*oset & ~tempmask);
10081         break;
10082       default:
10083         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10084         return -1;
10085       }
10086     }
10087
10088     /* Did they pass us an oset? If so, stick our holding mask into it */
10089     if (oset)
10090       *oset = tempmask;
10091
10092     return 0;
10093 }
10094 /*}}}*/
10095 #endif  /* HOMEGROWN_POSIX_SIGNALS */
10096
10097
10098 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
10099  * my_utime(), and flex_stat(), all of which operate on UTC unless
10100  * VMSISH_TIMES is true.
10101  */
10102 /* method used to handle UTC conversions:
10103  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
10104  */
10105 static int gmtime_emulation_type;
10106 /* number of secs to add to UTC POSIX-style time to get local time */
10107 static long int utc_offset_secs;
10108
10109 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
10110  * in vmsish.h.  #undef them here so we can call the CRTL routines
10111  * directly.
10112  */
10113 #undef gmtime
10114 #undef localtime
10115 #undef time
10116
10117
10118 /*
10119  * DEC C previous to 6.0 corrupts the behavior of the /prefix
10120  * qualifier with the extern prefix pragma.  This provisional
10121  * hack circumvents this prefix pragma problem in previous
10122  * precompilers.
10123  */
10124 #if defined(__VMS_VER) && __VMS_VER >= 70000000
10125 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
10126 #    pragma __extern_prefix save
10127 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
10128 #    define gmtime decc$__utctz_gmtime
10129 #    define localtime decc$__utctz_localtime
10130 #    define time decc$__utc_time
10131 #    pragma __extern_prefix restore
10132
10133      struct tm *gmtime(), *localtime();
10134
10135 #  endif
10136 #endif
10137
10138
10139 static time_t toutc_dst(time_t loc) {
10140   struct tm *rsltmp;
10141
10142   if ((rsltmp = localtime(&loc)) == NULL) return -1;
10143   loc -= utc_offset_secs;
10144   if (rsltmp->tm_isdst) loc -= 3600;
10145   return loc;
10146 }
10147 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10148        ((gmtime_emulation_type || my_time(NULL)), \
10149        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
10150        ((secs) - utc_offset_secs))))
10151
10152 static time_t toloc_dst(time_t utc) {
10153   struct tm *rsltmp;
10154
10155   utc += utc_offset_secs;
10156   if ((rsltmp = localtime(&utc)) == NULL) return -1;
10157   if (rsltmp->tm_isdst) utc += 3600;
10158   return utc;
10159 }
10160 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10161        ((gmtime_emulation_type || my_time(NULL)), \
10162        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
10163        ((secs) + utc_offset_secs))))
10164
10165 #ifndef RTL_USES_UTC
10166 /*
10167
10168     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
10169         DST starts on 1st sun of april      at 02:00  std time
10170             ends on last sun of october     at 02:00  dst time
10171     see the UCX management command reference, SET CONFIG TIMEZONE
10172     for formatting info.
10173
10174     No, it's not as general as it should be, but then again, NOTHING
10175     will handle UK times in a sensible way.
10176 */
10177
10178
10179 /*
10180     parse the DST start/end info:
10181     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
10182 */
10183
10184 static char *
10185 tz_parse_startend(char *s, struct tm *w, int *past)
10186 {
10187     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
10188     int ly, dozjd, d, m, n, hour, min, sec, j, k;
10189     time_t g;
10190
10191     if (!s)    return 0;
10192     if (!w) return 0;
10193     if (!past) return 0;
10194
10195     ly = 0;
10196     if (w->tm_year % 4        == 0) ly = 1;
10197     if (w->tm_year % 100      == 0) ly = 0;
10198     if (w->tm_year+1900 % 400 == 0) ly = 1;
10199     if (ly) dinm[1]++;
10200
10201     dozjd = isdigit(*s);
10202     if (*s == 'J' || *s == 'j' || dozjd) {
10203         if (!dozjd && !isdigit(*++s)) return 0;
10204         d = *s++ - '0';
10205         if (isdigit(*s)) {
10206             d = d*10 + *s++ - '0';
10207             if (isdigit(*s)) {
10208                 d = d*10 + *s++ - '0';
10209             }
10210         }
10211         if (d == 0) return 0;
10212         if (d > 366) return 0;
10213         d--;
10214         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
10215         g = d * 86400;
10216         dozjd = 1;
10217     } else if (*s == 'M' || *s == 'm') {
10218         if (!isdigit(*++s)) return 0;
10219         m = *s++ - '0';
10220         if (isdigit(*s)) m = 10*m + *s++ - '0';
10221         if (*s != '.') return 0;
10222         if (!isdigit(*++s)) return 0;
10223         n = *s++ - '0';
10224         if (n < 1 || n > 5) return 0;
10225         if (*s != '.') return 0;
10226         if (!isdigit(*++s)) return 0;
10227         d = *s++ - '0';
10228         if (d > 6) return 0;
10229     }
10230
10231     if (*s == '/') {
10232         if (!isdigit(*++s)) return 0;
10233         hour = *s++ - '0';
10234         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
10235         if (*s == ':') {
10236             if (!isdigit(*++s)) return 0;
10237             min = *s++ - '0';
10238             if (isdigit(*s)) min = 10*min + *s++ - '0';
10239             if (*s == ':') {
10240                 if (!isdigit(*++s)) return 0;
10241                 sec = *s++ - '0';
10242                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
10243             }
10244         }
10245     } else {
10246         hour = 2;
10247         min = 0;
10248         sec = 0;
10249     }
10250
10251     if (dozjd) {
10252         if (w->tm_yday < d) goto before;
10253         if (w->tm_yday > d) goto after;
10254     } else {
10255         if (w->tm_mon+1 < m) goto before;
10256         if (w->tm_mon+1 > m) goto after;
10257
10258         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
10259         k = d - j; /* mday of first d */
10260         if (k <= 0) k += 7;
10261         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
10262         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
10263         if (w->tm_mday < k) goto before;
10264         if (w->tm_mday > k) goto after;
10265     }
10266
10267     if (w->tm_hour < hour) goto before;
10268     if (w->tm_hour > hour) goto after;
10269     if (w->tm_min  < min)  goto before;
10270     if (w->tm_min  > min)  goto after;
10271     if (w->tm_sec  < sec)  goto before;
10272     goto after;
10273
10274 before:
10275     *past = 0;
10276     return s;
10277 after:
10278     *past = 1;
10279     return s;
10280 }
10281
10282
10283
10284
10285 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
10286
10287 static char *
10288 tz_parse_offset(char *s, int *offset)
10289 {
10290     int hour = 0, min = 0, sec = 0;
10291     int neg = 0;
10292     if (!s) return 0;
10293     if (!offset) return 0;
10294
10295     if (*s == '-') {neg++; s++;}
10296     if (*s == '+') s++;
10297     if (!isdigit(*s)) return 0;
10298     hour = *s++ - '0';
10299     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10300     if (hour > 24) return 0;
10301     if (*s == ':') {
10302         if (!isdigit(*++s)) return 0;
10303         min = *s++ - '0';
10304         if (isdigit(*s)) min = min*10 + (*s++ - '0');
10305         if (min > 59) return 0;
10306         if (*s == ':') {
10307             if (!isdigit(*++s)) return 0;
10308             sec = *s++ - '0';
10309             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10310             if (sec > 59) return 0;
10311         }
10312     }
10313
10314     *offset = (hour*60+min)*60 + sec;
10315     if (neg) *offset = -*offset;
10316     return s;
10317 }
10318
10319 /*
10320     input time is w, whatever type of time the CRTL localtime() uses.
10321     sets dst, the zone, and the gmtoff (seconds)
10322
10323     caches the value of TZ and UCX$TZ env variables; note that
10324     my_setenv looks for these and sets a flag if they're changed
10325     for efficiency.
10326
10327     We have to watch out for the "australian" case (dst starts in
10328     october, ends in april)...flagged by "reverse" and checked by
10329     scanning through the months of the previous year.
10330
10331 */
10332
10333 static int
10334 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
10335 {
10336     time_t when;
10337     struct tm *w2;
10338     char *s,*s2;
10339     char *dstzone, *tz, *s_start, *s_end;
10340     int std_off, dst_off, isdst;
10341     int y, dststart, dstend;
10342     static char envtz[1025];  /* longer than any logical, symbol, ... */
10343     static char ucxtz[1025];
10344     static char reversed = 0;
10345
10346     if (!w) return 0;
10347
10348     if (tz_updated) {
10349         tz_updated = 0;
10350         reversed = -1;  /* flag need to check  */
10351         envtz[0] = ucxtz[0] = '\0';
10352         tz = my_getenv("TZ",0);
10353         if (tz) strcpy(envtz, tz);
10354         tz = my_getenv("UCX$TZ",0);
10355         if (tz) strcpy(ucxtz, tz);
10356         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
10357     }
10358     tz = envtz;
10359     if (!*tz) tz = ucxtz;
10360
10361     s = tz;
10362     while (isalpha(*s)) s++;
10363     s = tz_parse_offset(s, &std_off);
10364     if (!s) return 0;
10365     if (!*s) {                  /* no DST, hurray we're done! */
10366         isdst = 0;
10367         goto done;
10368     }
10369
10370     dstzone = s;
10371     while (isalpha(*s)) s++;
10372     s2 = tz_parse_offset(s, &dst_off);
10373     if (s2) {
10374         s = s2;
10375     } else {
10376         dst_off = std_off - 3600;
10377     }
10378
10379     if (!*s) {      /* default dst start/end?? */
10380         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
10381             s = strchr(ucxtz,',');
10382         }
10383         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
10384     }
10385     if (*s != ',') return 0;
10386
10387     when = *w;
10388     when = _toutc(when);      /* convert to utc */
10389     when = when - std_off;    /* convert to pseudolocal time*/
10390
10391     w2 = localtime(&when);
10392     y = w2->tm_year;
10393     s_start = s+1;
10394     s = tz_parse_startend(s_start,w2,&dststart);
10395     if (!s) return 0;
10396     if (*s != ',') return 0;
10397
10398     when = *w;
10399     when = _toutc(when);      /* convert to utc */
10400     when = when - dst_off;    /* convert to pseudolocal time*/
10401     w2 = localtime(&when);
10402     if (w2->tm_year != y) {   /* spans a year, just check one time */
10403         when += dst_off - std_off;
10404         w2 = localtime(&when);
10405     }
10406     s_end = s+1;
10407     s = tz_parse_startend(s_end,w2,&dstend);
10408     if (!s) return 0;
10409
10410     if (reversed == -1) {  /* need to check if start later than end */
10411         int j, ds, de;
10412
10413         when = *w;
10414         if (when < 2*365*86400) {
10415             when += 2*365*86400;
10416         } else {
10417             when -= 365*86400;
10418         }
10419         w2 =localtime(&when);
10420         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
10421
10422         for (j = 0; j < 12; j++) {
10423             w2 =localtime(&when);
10424             tz_parse_startend(s_start,w2,&ds);
10425             tz_parse_startend(s_end,w2,&de);
10426             if (ds != de) break;
10427             when += 30*86400;
10428         }
10429         reversed = 0;
10430         if (de && !ds) reversed = 1;
10431     }
10432
10433     isdst = dststart && !dstend;
10434     if (reversed) isdst = dststart  || !dstend;
10435
10436 done:
10437     if (dst)    *dst = isdst;
10438     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
10439     if (isdst)  tz = dstzone;
10440     if (zone) {
10441         while(isalpha(*tz))  *zone++ = *tz++;
10442         *zone = '\0';
10443     }
10444     return 1;
10445 }
10446
10447 #endif /* !RTL_USES_UTC */
10448
10449 /* my_time(), my_localtime(), my_gmtime()
10450  * By default traffic in UTC time values, using CRTL gmtime() or
10451  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
10452  * Note: We need to use these functions even when the CRTL has working
10453  * UTC support, since they also handle C<use vmsish qw(times);>
10454  *
10455  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
10456  * Modified by Charles Bailey <bailey@newman.upenn.edu>
10457  */
10458
10459 /*{{{time_t my_time(time_t *timep)*/
10460 time_t Perl_my_time(pTHX_ time_t *timep)
10461 {
10462   time_t when;
10463   struct tm *tm_p;
10464
10465   if (gmtime_emulation_type == 0) {
10466     int dstnow;
10467     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
10468                               /* results of calls to gmtime() and localtime() */
10469                               /* for same &base */
10470
10471     gmtime_emulation_type++;
10472     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
10473       char off[LNM$C_NAMLENGTH+1];;
10474
10475       gmtime_emulation_type++;
10476       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
10477         gmtime_emulation_type++;
10478         utc_offset_secs = 0;
10479         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
10480       }
10481       else { utc_offset_secs = atol(off); }
10482     }
10483     else { /* We've got a working gmtime() */
10484       struct tm gmt, local;
10485
10486       gmt = *tm_p;
10487       tm_p = localtime(&base);
10488       local = *tm_p;
10489       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
10490       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
10491       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
10492       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
10493     }
10494   }
10495
10496   when = time(NULL);
10497 # ifdef VMSISH_TIME
10498 # ifdef RTL_USES_UTC
10499   if (VMSISH_TIME) when = _toloc(when);
10500 # else
10501   if (!VMSISH_TIME) when = _toutc(when);
10502 # endif
10503 # endif
10504   if (timep != NULL) *timep = when;
10505   return when;
10506
10507 }  /* end of my_time() */
10508 /*}}}*/
10509
10510
10511 /*{{{struct tm *my_gmtime(const time_t *timep)*/
10512 struct tm *
10513 Perl_my_gmtime(pTHX_ const time_t *timep)
10514 {
10515   char *p;
10516   time_t when;
10517   struct tm *rsltmp;
10518
10519   if (timep == NULL) {
10520     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10521     return NULL;
10522   }
10523   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
10524
10525   when = *timep;
10526 # ifdef VMSISH_TIME
10527   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
10528 #  endif
10529 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
10530   return gmtime(&when);
10531 # else
10532   /* CRTL localtime() wants local time as input, so does no tz correction */
10533   rsltmp = localtime(&when);
10534   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
10535   return rsltmp;
10536 #endif
10537 }  /* end of my_gmtime() */
10538 /*}}}*/
10539
10540
10541 /*{{{struct tm *my_localtime(const time_t *timep)*/
10542 struct tm *
10543 Perl_my_localtime(pTHX_ const time_t *timep)
10544 {
10545   time_t when, whenutc;
10546   struct tm *rsltmp;
10547   int dst, offset;
10548
10549   if (timep == NULL) {
10550     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10551     return NULL;
10552   }
10553   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
10554   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
10555
10556   when = *timep;
10557 # ifdef RTL_USES_UTC
10558 # ifdef VMSISH_TIME
10559   if (VMSISH_TIME) when = _toutc(when);
10560 # endif
10561   /* CRTL localtime() wants UTC as input, does tz correction itself */
10562   return localtime(&when);
10563
10564 # else /* !RTL_USES_UTC */
10565   whenutc = when;
10566 # ifdef VMSISH_TIME
10567   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
10568   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
10569 # endif
10570   dst = -1;
10571 #ifndef RTL_USES_UTC
10572   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
10573       when = whenutc - offset;                   /* pseudolocal time*/
10574   }
10575 # endif
10576   /* CRTL localtime() wants local time as input, so does no tz correction */
10577   rsltmp = localtime(&when);
10578   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
10579   return rsltmp;
10580 # endif
10581
10582 } /*  end of my_localtime() */
10583 /*}}}*/
10584
10585 /* Reset definitions for later calls */
10586 #define gmtime(t)    my_gmtime(t)
10587 #define localtime(t) my_localtime(t)
10588 #define time(t)      my_time(t)
10589
10590
10591 /* my_utime - update modification/access time of a file
10592  *
10593  * VMS 7.3 and later implementation
10594  * Only the UTC translation is home-grown. The rest is handled by the
10595  * CRTL utime(), which will take into account the relevant feature
10596  * logicals and ODS-5 volume characteristics for true access times.
10597  *
10598  * pre VMS 7.3 implementation:
10599  * The calling sequence is identical to POSIX utime(), but under
10600  * VMS with ODS-2, only the modification time is changed; ODS-2 does
10601  * not maintain access times.  Restrictions differ from the POSIX
10602  * definition in that the time can be changed as long as the
10603  * caller has permission to execute the necessary IO$_MODIFY $QIO;
10604  * no separate checks are made to insure that the caller is the
10605  * owner of the file or has special privs enabled.
10606  * Code here is based on Joe Meadows' FILE utility.
10607  *
10608  */
10609
10610 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
10611  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
10612  * in 100 ns intervals.
10613  */
10614 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
10615
10616 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
10617 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
10618 {
10619 #if __CRTL_VER >= 70300000
10620   struct utimbuf utc_utimes, *utc_utimesp;
10621
10622   if (utimes != NULL) {
10623     utc_utimes.actime = utimes->actime;
10624     utc_utimes.modtime = utimes->modtime;
10625 # ifdef VMSISH_TIME
10626     /* If input was local; convert to UTC for sys svc */
10627     if (VMSISH_TIME) {
10628       utc_utimes.actime = _toutc(utimes->actime);
10629       utc_utimes.modtime = _toutc(utimes->modtime);
10630     }
10631 # endif
10632     utc_utimesp = &utc_utimes;
10633   }
10634   else {
10635     utc_utimesp = NULL;
10636   }
10637
10638   return utime(file, utc_utimesp);
10639
10640 #else /* __CRTL_VER < 70300000 */
10641
10642   register int i;
10643   int sts;
10644   long int bintime[2], len = 2, lowbit, unixtime,
10645            secscale = 10000000; /* seconds --> 100 ns intervals */
10646   unsigned long int chan, iosb[2], retsts;
10647   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
10648   struct FAB myfab = cc$rms_fab;
10649   struct NAM mynam = cc$rms_nam;
10650 #if defined (__DECC) && defined (__VAX)
10651   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
10652    * at least through VMS V6.1, which causes a type-conversion warning.
10653    */
10654 #  pragma message save
10655 #  pragma message disable cvtdiftypes
10656 #endif
10657   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
10658   struct fibdef myfib;
10659 #if defined (__DECC) && defined (__VAX)
10660   /* This should be right after the declaration of myatr, but due
10661    * to a bug in VAX DEC C, this takes effect a statement early.
10662    */
10663 #  pragma message restore
10664 #endif
10665   /* cast ok for read only parameter */
10666   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
10667                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
10668                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
10669
10670   if (file == NULL || *file == '\0') {
10671     SETERRNO(ENOENT, LIB$_INVARG);
10672     return -1;
10673   }
10674
10675   /* Convert to VMS format ensuring that it will fit in 255 characters */
10676   if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
10677       SETERRNO(ENOENT, LIB$_INVARG);
10678       return -1;
10679   }
10680   if (utimes != NULL) {
10681     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
10682      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
10683      * Since time_t is unsigned long int, and lib$emul takes a signed long int
10684      * as input, we force the sign bit to be clear by shifting unixtime right
10685      * one bit, then multiplying by an extra factor of 2 in lib$emul().
10686      */
10687     lowbit = (utimes->modtime & 1) ? secscale : 0;
10688     unixtime = (long int) utimes->modtime;
10689 #   ifdef VMSISH_TIME
10690     /* If input was UTC; convert to local for sys svc */
10691     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
10692 #   endif
10693     unixtime >>= 1;  secscale <<= 1;
10694     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
10695     if (!(retsts & 1)) {
10696       SETERRNO(EVMSERR, retsts);
10697       return -1;
10698     }
10699     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
10700     if (!(retsts & 1)) {
10701       SETERRNO(EVMSERR, retsts);
10702       return -1;
10703     }
10704   }
10705   else {
10706     /* Just get the current time in VMS format directly */
10707     retsts = sys$gettim(bintime);
10708     if (!(retsts & 1)) {
10709       SETERRNO(EVMSERR, retsts);
10710       return -1;
10711     }
10712   }
10713
10714   myfab.fab$l_fna = vmsspec;
10715   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
10716   myfab.fab$l_nam = &mynam;
10717   mynam.nam$l_esa = esa;
10718   mynam.nam$b_ess = (unsigned char) sizeof esa;
10719   mynam.nam$l_rsa = rsa;
10720   mynam.nam$b_rss = (unsigned char) sizeof rsa;
10721   if (decc_efs_case_preserve)
10722       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
10723
10724   /* Look for the file to be affected, letting RMS parse the file
10725    * specification for us as well.  I have set errno using only
10726    * values documented in the utime() man page for VMS POSIX.
10727    */
10728   retsts = sys$parse(&myfab,0,0);
10729   if (!(retsts & 1)) {
10730     set_vaxc_errno(retsts);
10731     if      (retsts == RMS$_PRV) set_errno(EACCES);
10732     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
10733     else                         set_errno(EVMSERR);
10734     return -1;
10735   }
10736   retsts = sys$search(&myfab,0,0);
10737   if (!(retsts & 1)) {
10738     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10739     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10740     set_vaxc_errno(retsts);
10741     if      (retsts == RMS$_PRV) set_errno(EACCES);
10742     else if (retsts == RMS$_FNF) set_errno(ENOENT);
10743     else                         set_errno(EVMSERR);
10744     return -1;
10745   }
10746
10747   devdsc.dsc$w_length = mynam.nam$b_dev;
10748   /* cast ok for read only parameter */
10749   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
10750
10751   retsts = sys$assign(&devdsc,&chan,0,0);
10752   if (!(retsts & 1)) {
10753     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10754     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10755     set_vaxc_errno(retsts);
10756     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
10757     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
10758     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
10759     else                               set_errno(EVMSERR);
10760     return -1;
10761   }
10762
10763   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
10764   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
10765
10766   memset((void *) &myfib, 0, sizeof myfib);
10767 #if defined(__DECC) || defined(__DECCXX)
10768   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
10769   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
10770   /* This prevents the revision time of the file being reset to the current
10771    * time as a result of our IO$_MODIFY $QIO. */
10772   myfib.fib$l_acctl = FIB$M_NORECORD;
10773 #else
10774   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
10775   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
10776   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
10777 #endif
10778   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
10779   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10780   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10781   _ckvmssts(sys$dassgn(chan));
10782   if (retsts & 1) retsts = iosb[0];
10783   if (!(retsts & 1)) {
10784     set_vaxc_errno(retsts);
10785     if (retsts == SS$_NOPRIV) set_errno(EACCES);
10786     else                      set_errno(EVMSERR);
10787     return -1;
10788   }
10789
10790   return 0;
10791
10792 #endif /* #if __CRTL_VER >= 70300000 */
10793
10794 }  /* end of my_utime() */
10795 /*}}}*/
10796
10797 /*
10798  * flex_stat, flex_lstat, flex_fstat
10799  * basic stat, but gets it right when asked to stat
10800  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
10801  */
10802
10803 #ifndef _USE_STD_STAT
10804 /* encode_dev packs a VMS device name string into an integer to allow
10805  * simple comparisons. This can be used, for example, to check whether two
10806  * files are located on the same device, by comparing their encoded device
10807  * names. Even a string comparison would not do, because stat() reuses the
10808  * device name buffer for each call; so without encode_dev, it would be
10809  * necessary to save the buffer and use strcmp (this would mean a number of
10810  * changes to the standard Perl code, to say nothing of what a Perl script
10811  * would have to do.
10812  *
10813  * The device lock id, if it exists, should be unique (unless perhaps compared
10814  * with lock ids transferred from other nodes). We have a lock id if the disk is
10815  * mounted cluster-wide, which is when we tend to get long (host-qualified)
10816  * device names. Thus we use the lock id in preference, and only if that isn't
10817  * available, do we try to pack the device name into an integer (flagged by
10818  * the sign bit (LOCKID_MASK) being set).
10819  *
10820  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
10821  * name and its encoded form, but it seems very unlikely that we will find
10822  * two files on different disks that share the same encoded device names,
10823  * and even more remote that they will share the same file id (if the test
10824  * is to check for the same file).
10825  *
10826  * A better method might be to use sys$device_scan on the first call, and to
10827  * search for the device, returning an index into the cached array.
10828  * The number returned would be more intelligible.
10829  * This is probably not worth it, and anyway would take quite a bit longer
10830  * on the first call.
10831  */
10832 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
10833 static mydev_t encode_dev (pTHX_ const char *dev)
10834 {
10835   int i;
10836   unsigned long int f;
10837   mydev_t enc;
10838   char c;
10839   const char *q;
10840
10841   if (!dev || !dev[0]) return 0;
10842
10843 #if LOCKID_MASK
10844   {
10845     struct dsc$descriptor_s dev_desc;
10846     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
10847
10848     /* For cluster-mounted disks, the disk lock identifier is unique, so we
10849        can try that first. */
10850     dev_desc.dsc$w_length =  strlen (dev);
10851     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
10852     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
10853     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
10854     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
10855     if (!$VMS_STATUS_SUCCESS(status)) {
10856       switch (status) {
10857         case SS$_NOSUCHDEV:
10858           SETERRNO(ENODEV, status);
10859           return 0;
10860         default:
10861           _ckvmssts(status);
10862       }
10863     }
10864     if (lockid) return (lockid & ~LOCKID_MASK);
10865   }
10866 #endif
10867
10868   /* Otherwise we try to encode the device name */
10869   enc = 0;
10870   f = 1;
10871   i = 0;
10872   for (q = dev + strlen(dev); q--; q >= dev) {
10873     if (*q == ':')
10874         break;
10875     if (isdigit (*q))
10876       c= (*q) - '0';
10877     else if (isalpha (toupper (*q)))
10878       c= toupper (*q) - 'A' + (char)10;
10879     else
10880       continue; /* Skip '$'s */
10881     i++;
10882     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
10883     if (i>1) f *= 36;
10884     enc += f * (unsigned long int) c;
10885   }
10886   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
10887
10888 }  /* end of encode_dev() */
10889 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10890         device_no = encode_dev(aTHX_ devname)
10891 #else
10892 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10893         device_no = new_dev_no
10894 #endif
10895
10896 static int
10897 is_null_device(name)
10898     const char *name;
10899 {
10900   if (decc_bug_devnull != 0) {
10901     if (strncmp("/dev/null", name, 9) == 0)
10902       return 1;
10903   }
10904     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
10905        The underscore prefix, controller letter, and unit number are
10906        independently optional; for our purposes, the colon punctuation
10907        is not.  The colon can be trailed by optional directory and/or
10908        filename, but two consecutive colons indicates a nodename rather
10909        than a device.  [pr]  */
10910   if (*name == '_') ++name;
10911   if (tolower(*name++) != 'n') return 0;
10912   if (tolower(*name++) != 'l') return 0;
10913   if (tolower(*name) == 'a') ++name;
10914   if (*name == '0') ++name;
10915   return (*name++ == ':') && (*name != ':');
10916 }
10917
10918
10919 static I32
10920 Perl_cando_by_name_int
10921    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
10922 {
10923   static char usrname[L_cuserid];
10924   static struct dsc$descriptor_s usrdsc =
10925          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
10926   char vmsname[NAM$C_MAXRSS+1];
10927   char *fileified;
10928   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
10929   unsigned short int retlen, trnlnm_iter_count;
10930   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10931   union prvdef curprv;
10932   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
10933          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
10934          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
10935   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
10936          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
10937          {0,0,0,0}};
10938   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
10939          {0,0,0,0}};
10940   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10941
10942   if (!fname || !*fname) return FALSE;
10943   /* Make sure we expand logical names, since sys$check_access doesn't */
10944
10945   fileified = NULL;
10946   if ((opts & PERL_RMSEXPAND_M_VMS_IN) != 0) {
10947     fileified = PerlMem_malloc(VMS_MAXRSS);
10948     if (!strpbrk(fname,"/]>:")) {
10949       strcpy(fileified,fname);
10950       trnlnm_iter_count = 0;
10951       while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
10952         trnlnm_iter_count++;
10953         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
10954       }
10955       fname = fileified;
10956     }
10957     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
10958       PerlMem_free(fileified);
10959       return FALSE;
10960     }
10961     retlen = namdsc.dsc$w_length = strlen(vmsname);
10962     namdsc.dsc$a_pointer = vmsname;
10963     if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
10964       vmsname[retlen-1] == ':') {
10965       if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) return FALSE;
10966       namdsc.dsc$w_length = strlen(fileified);
10967       namdsc.dsc$a_pointer = fileified;
10968     }
10969   }
10970   else {
10971     retlen = namdsc.dsc$w_length = strlen(fname);
10972     namdsc.dsc$a_pointer = (char *)fname; /* cast ok */
10973   }
10974
10975   switch (bit) {
10976     case S_IXUSR: case S_IXGRP: case S_IXOTH:
10977       access = ARM$M_EXECUTE;
10978       flags = CHP$M_READ;
10979       break;
10980     case S_IRUSR: case S_IRGRP: case S_IROTH:
10981       access = ARM$M_READ;
10982       flags = CHP$M_READ | CHP$M_USEREADALL;
10983       break;
10984     case S_IWUSR: case S_IWGRP: case S_IWOTH:
10985       access = ARM$M_WRITE;
10986       flags = CHP$M_READ | CHP$M_WRITE;
10987       break;
10988     case S_IDUSR: case S_IDGRP: case S_IDOTH:
10989       access = ARM$M_DELETE;
10990       flags = CHP$M_READ | CHP$M_WRITE;
10991       break;
10992     default:
10993       if (fileified != NULL)
10994         PerlMem_free(fileified);
10995       return FALSE;
10996   }
10997
10998   /* Before we call $check_access, create a user profile with the current
10999    * process privs since otherwise it just uses the default privs from the
11000    * UAF and might give false positives or negatives.  This only works on
11001    * VMS versions v6.0 and later since that's when sys$create_user_profile
11002    * became available.
11003    */
11004
11005   /* get current process privs and username */
11006   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11007   _ckvmssts(iosb[0]);
11008
11009 #if defined(__VMS_VER) && __VMS_VER >= 60000000
11010
11011   /* find out the space required for the profile */
11012   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11013                                     &usrprodsc.dsc$w_length,0));
11014
11015   /* allocate space for the profile and get it filled in */
11016   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11017   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
11018   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11019                                     &usrprodsc.dsc$w_length,0));
11020
11021   /* use the profile to check access to the file; free profile & analyze results */
11022   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
11023   PerlMem_free(usrprodsc.dsc$a_pointer);
11024   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11025
11026 #else
11027
11028   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11029
11030 #endif
11031
11032   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
11033       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11034       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11035     set_vaxc_errno(retsts);
11036     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11037     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11038     else set_errno(ENOENT);
11039     if (fileified != NULL)
11040       PerlMem_free(fileified);
11041     return FALSE;
11042   }
11043   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11044     if (fileified != NULL)
11045       PerlMem_free(fileified);
11046     return TRUE;
11047   }
11048   _ckvmssts(retsts);
11049
11050   if (fileified != NULL)
11051     PerlMem_free(fileified);
11052   return FALSE;  /* Should never get here */
11053
11054 }
11055
11056 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
11057 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11058  * subset of the applicable information.
11059  */
11060 bool
11061 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11062 {
11063   return cando_by_name_int
11064         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11065 }  /* end of cando() */
11066 /*}}}*/
11067
11068
11069 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11070 I32
11071 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11072 {
11073    return cando_by_name_int(bit, effective, fname, 0);
11074
11075 }  /* end of cando_by_name() */
11076 /*}}}*/
11077
11078
11079 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
11080 int
11081 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
11082 {
11083   if (!fstat(fd,(stat_t *) statbufp)) {
11084     char *cptr;
11085     char *vms_filename;
11086     vms_filename = PerlMem_malloc(VMS_MAXRSS);
11087     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
11088
11089     /* Save name for cando by name in VMS format */
11090     cptr = getname(fd, vms_filename, 1);
11091
11092     /* This should not happen, but just in case */
11093     if (cptr == NULL) {
11094         statbufp->st_devnam[0] = 0;
11095     }
11096     else {
11097         /* Make sure that the saved name fits in 255 characters */
11098         cptr = do_rmsexpand
11099                        (vms_filename,
11100                         statbufp->st_devnam,
11101                         0,
11102                         NULL,
11103                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
11104                         NULL,
11105                         NULL);
11106         if (cptr == NULL)
11107             statbufp->st_devnam[0] = 0;
11108     }
11109     PerlMem_free(vms_filename);
11110
11111     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11112     VMS_DEVICE_ENCODE
11113         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11114
11115 #   ifdef RTL_USES_UTC
11116 #   ifdef VMSISH_TIME
11117     if (VMSISH_TIME) {
11118       statbufp->st_mtime = _toloc(statbufp->st_mtime);
11119       statbufp->st_atime = _toloc(statbufp->st_atime);
11120       statbufp->st_ctime = _toloc(statbufp->st_ctime);
11121     }
11122 #   endif
11123 #   else
11124 #   ifdef VMSISH_TIME
11125     if (!VMSISH_TIME) { /* Return UTC instead of local time */
11126 #   else
11127     if (1) {
11128 #   endif
11129       statbufp->st_mtime = _toutc(statbufp->st_mtime);
11130       statbufp->st_atime = _toutc(statbufp->st_atime);
11131       statbufp->st_ctime = _toutc(statbufp->st_ctime);
11132     }
11133 #endif
11134     return 0;
11135   }
11136   return -1;
11137
11138 }  /* end of flex_fstat() */
11139 /*}}}*/
11140
11141 #if !defined(__VAX) && __CRTL_VER >= 80200000
11142 #ifdef lstat
11143 #undef lstat
11144 #endif
11145 #else
11146 #ifdef lstat
11147 #undef lstat
11148 #endif
11149 #define lstat(_x, _y) stat(_x, _y)
11150 #endif
11151
11152 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11153
11154 static int
11155 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
11156 {
11157     char fileified[VMS_MAXRSS];
11158     char temp_fspec[VMS_MAXRSS];
11159     char *save_spec;
11160     int retval = -1;
11161     int saved_errno, saved_vaxc_errno;
11162
11163     if (!fspec) return retval;
11164     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
11165     strcpy(temp_fspec, fspec);
11166
11167     if (decc_bug_devnull != 0) {
11168       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
11169         memset(statbufp,0,sizeof *statbufp);
11170         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
11171         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
11172         statbufp->st_uid = 0x00010001;
11173         statbufp->st_gid = 0x0001;
11174         time((time_t *)&statbufp->st_mtime);
11175         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
11176         return 0;
11177       }
11178     }
11179
11180     /* Try for a directory name first.  If fspec contains a filename without
11181      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
11182      * and sea:[wine.dark]water. exist, we prefer the directory here.
11183      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
11184      * not sea:[wine.dark]., if the latter exists.  If the intended target is
11185      * the file with null type, specify this by calling flex_stat() with
11186      * a '.' at the end of fspec.
11187      *
11188      * If we are in Posix filespec mode, accept the filename as is.
11189      */
11190 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11191   if (decc_posix_compliant_pathnames == 0) {
11192 #endif
11193     if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
11194       if (lstat_flag == 0)
11195         retval = stat(fileified,(stat_t *) statbufp);
11196       else
11197         retval = lstat(fileified,(stat_t *) statbufp);
11198       save_spec = fileified;
11199     }
11200     if (retval) {
11201       if (lstat_flag == 0)
11202         retval = stat(temp_fspec,(stat_t *) statbufp);
11203       else
11204         retval = lstat(temp_fspec,(stat_t *) statbufp);
11205       save_spec = temp_fspec;
11206     }
11207 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11208   } else {
11209     if (lstat_flag == 0)
11210       retval = stat(temp_fspec,(stat_t *) statbufp);
11211     else
11212       retval = lstat(temp_fspec,(stat_t *) statbufp);
11213       save_spec = temp_fspec;
11214   }
11215 #endif
11216     if (!retval) {
11217     char * cptr;
11218       cptr = do_rmsexpand
11219        (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
11220       if (cptr == NULL)
11221         statbufp->st_devnam[0] = 0;
11222
11223       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11224       VMS_DEVICE_ENCODE
11225         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11226 #     ifdef RTL_USES_UTC
11227 #     ifdef VMSISH_TIME
11228       if (VMSISH_TIME) {
11229         statbufp->st_mtime = _toloc(statbufp->st_mtime);
11230         statbufp->st_atime = _toloc(statbufp->st_atime);
11231         statbufp->st_ctime = _toloc(statbufp->st_ctime);
11232       }
11233 #     endif
11234 #     else
11235 #     ifdef VMSISH_TIME
11236       if (!VMSISH_TIME) { /* Return UTC instead of local time */
11237 #     else
11238       if (1) {
11239 #     endif
11240         statbufp->st_mtime = _toutc(statbufp->st_mtime);
11241         statbufp->st_atime = _toutc(statbufp->st_atime);
11242         statbufp->st_ctime = _toutc(statbufp->st_ctime);
11243       }
11244 #     endif
11245     }
11246     /* If we were successful, leave errno where we found it */
11247     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
11248     return retval;
11249
11250 }  /* end of flex_stat_int() */
11251
11252
11253 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
11254 int
11255 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
11256 {
11257    return flex_stat_int(fspec, statbufp, 0);
11258 }
11259 /*}}}*/
11260
11261 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
11262 int
11263 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
11264 {
11265    return flex_stat_int(fspec, statbufp, 1);
11266 }
11267 /*}}}*/
11268
11269
11270 /*{{{char *my_getlogin()*/
11271 /* VMS cuserid == Unix getlogin, except calling sequence */
11272 char *
11273 my_getlogin(void)
11274 {
11275     static char user[L_cuserid];
11276     return cuserid(user);
11277 }
11278 /*}}}*/
11279
11280
11281 /*  rmscopy - copy a file using VMS RMS routines
11282  *
11283  *  Copies contents and attributes of spec_in to spec_out, except owner
11284  *  and protection information.  Name and type of spec_in are used as
11285  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
11286  *  should try to propagate timestamps from the input file to the output file.
11287  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
11288  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
11289  *  propagated to the output file at creation iff the output file specification
11290  *  did not contain an explicit name or type, and the revision date is always
11291  *  updated at the end of the copy operation.  If it is greater than 0, then
11292  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
11293  *  other than the revision date should be propagated, and bit 1 indicates
11294  *  that the revision date should be propagated.
11295  *
11296  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
11297  *
11298  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
11299  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
11300  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
11301  * as part of the Perl standard distribution under the terms of the
11302  * GNU General Public License or the Perl Artistic License.  Copies
11303  * of each may be found in the Perl standard distribution.
11304  */ /* FIXME */
11305 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
11306 int
11307 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
11308 {
11309     char *vmsin, * vmsout, *esa, *esa_out,
11310          *rsa, *ubf;
11311     unsigned long int i, sts, sts2;
11312     int dna_len;
11313     struct FAB fab_in, fab_out;
11314     struct RAB rab_in, rab_out;
11315     rms_setup_nam(nam);
11316     rms_setup_nam(nam_out);
11317     struct XABDAT xabdat;
11318     struct XABFHC xabfhc;
11319     struct XABRDT xabrdt;
11320     struct XABSUM xabsum;
11321
11322     vmsin = PerlMem_malloc(VMS_MAXRSS);
11323     if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
11324     vmsout = PerlMem_malloc(VMS_MAXRSS);
11325     if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
11326     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
11327         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
11328       PerlMem_free(vmsin);
11329       PerlMem_free(vmsout);
11330       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11331       return 0;
11332     }
11333
11334     esa = PerlMem_malloc(VMS_MAXRSS);
11335     if (esa == NULL) _ckvmssts(SS$_INSFMEM);
11336     fab_in = cc$rms_fab;
11337     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
11338     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
11339     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
11340     fab_in.fab$l_fop = FAB$M_SQO;
11341     rms_bind_fab_nam(fab_in, nam);
11342     fab_in.fab$l_xab = (void *) &xabdat;
11343
11344     rsa = PerlMem_malloc(VMS_MAXRSS);
11345     if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
11346     rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
11347     rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
11348     rms_nam_esl(nam) = 0;
11349     rms_nam_rsl(nam) = 0;
11350     rms_nam_esll(nam) = 0;
11351     rms_nam_rsll(nam) = 0;
11352 #ifdef NAM$M_NO_SHORT_UPCASE
11353     if (decc_efs_case_preserve)
11354         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
11355 #endif
11356
11357     xabdat = cc$rms_xabdat;        /* To get creation date */
11358     xabdat.xab$l_nxt = (void *) &xabfhc;
11359
11360     xabfhc = cc$rms_xabfhc;        /* To get record length */
11361     xabfhc.xab$l_nxt = (void *) &xabsum;
11362
11363     xabsum = cc$rms_xabsum;        /* To get key and area information */
11364
11365     if (!((sts = sys$open(&fab_in)) & 1)) {
11366       PerlMem_free(vmsin);
11367       PerlMem_free(vmsout);
11368       PerlMem_free(esa);
11369       PerlMem_free(rsa);
11370       set_vaxc_errno(sts);
11371       switch (sts) {
11372         case RMS$_FNF: case RMS$_DNF:
11373           set_errno(ENOENT); break;
11374         case RMS$_DIR:
11375           set_errno(ENOTDIR); break;
11376         case RMS$_DEV:
11377           set_errno(ENODEV); break;
11378         case RMS$_SYN:
11379           set_errno(EINVAL); break;
11380         case RMS$_PRV:
11381           set_errno(EACCES); break;
11382         default:
11383           set_errno(EVMSERR);
11384       }
11385       return 0;
11386     }
11387
11388     nam_out = nam;
11389     fab_out = fab_in;
11390     fab_out.fab$w_ifi = 0;
11391     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
11392     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
11393     fab_out.fab$l_fop = FAB$M_SQO;
11394     rms_bind_fab_nam(fab_out, nam_out);
11395     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
11396     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
11397     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
11398     esa_out = PerlMem_malloc(VMS_MAXRSS);
11399     if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
11400     rms_set_rsa(nam_out, NULL, 0);
11401     rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
11402
11403     if (preserve_dates == 0) {  /* Act like DCL COPY */
11404       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
11405       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
11406       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
11407         PerlMem_free(vmsin);
11408         PerlMem_free(vmsout);
11409         PerlMem_free(esa);
11410         PerlMem_free(rsa);
11411         PerlMem_free(esa_out);
11412         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
11413         set_vaxc_errno(sts);
11414         return 0;
11415       }
11416       fab_out.fab$l_xab = (void *) &xabdat;
11417       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
11418         preserve_dates = 1;
11419     }
11420     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
11421       preserve_dates =0;      /* bitmask from this point forward   */
11422
11423     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
11424     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
11425       PerlMem_free(vmsin);
11426       PerlMem_free(vmsout);
11427       PerlMem_free(esa);
11428       PerlMem_free(rsa);
11429       PerlMem_free(esa_out);
11430       set_vaxc_errno(sts);
11431       switch (sts) {
11432         case RMS$_DNF:
11433           set_errno(ENOENT); break;
11434         case RMS$_DIR:
11435           set_errno(ENOTDIR); break;
11436         case RMS$_DEV:
11437           set_errno(ENODEV); break;
11438         case RMS$_SYN:
11439           set_errno(EINVAL); break;
11440         case RMS$_PRV:
11441           set_errno(EACCES); break;
11442         default:
11443           set_errno(EVMSERR);
11444       }
11445       return 0;
11446     }
11447     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
11448     if (preserve_dates & 2) {
11449       /* sys$close() will process xabrdt, not xabdat */
11450       xabrdt = cc$rms_xabrdt;
11451 #ifndef __GNUC__
11452       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
11453 #else
11454       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
11455        * is unsigned long[2], while DECC & VAXC use a struct */
11456       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
11457 #endif
11458       fab_out.fab$l_xab = (void *) &xabrdt;
11459     }
11460
11461     ubf = PerlMem_malloc(32256);
11462     if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
11463     rab_in = cc$rms_rab;
11464     rab_in.rab$l_fab = &fab_in;
11465     rab_in.rab$l_rop = RAB$M_BIO;
11466     rab_in.rab$l_ubf = ubf;
11467     rab_in.rab$w_usz = 32256;
11468     if (!((sts = sys$connect(&rab_in)) & 1)) {
11469       sys$close(&fab_in); sys$close(&fab_out);
11470       PerlMem_free(vmsin);
11471       PerlMem_free(vmsout);
11472       PerlMem_free(esa);
11473       PerlMem_free(ubf);
11474       PerlMem_free(rsa);
11475       PerlMem_free(esa_out);
11476       set_errno(EVMSERR); set_vaxc_errno(sts);
11477       return 0;
11478     }
11479
11480     rab_out = cc$rms_rab;
11481     rab_out.rab$l_fab = &fab_out;
11482     rab_out.rab$l_rbf = ubf;
11483     if (!((sts = sys$connect(&rab_out)) & 1)) {
11484       sys$close(&fab_in); sys$close(&fab_out);
11485       PerlMem_free(vmsin);
11486       PerlMem_free(vmsout);
11487       PerlMem_free(esa);
11488       PerlMem_free(ubf);
11489       PerlMem_free(rsa);
11490       PerlMem_free(esa_out);
11491       set_errno(EVMSERR); set_vaxc_errno(sts);
11492       return 0;
11493     }
11494
11495     while ((sts = sys$read(&rab_in))) {  /* always true  */
11496       if (sts == RMS$_EOF) break;
11497       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
11498       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
11499         sys$close(&fab_in); sys$close(&fab_out);
11500         PerlMem_free(vmsin);
11501         PerlMem_free(vmsout);
11502         PerlMem_free(esa);
11503         PerlMem_free(ubf);
11504         PerlMem_free(rsa);
11505         PerlMem_free(esa_out);
11506         set_errno(EVMSERR); set_vaxc_errno(sts);
11507         return 0;
11508       }
11509     }
11510
11511
11512     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
11513     sys$close(&fab_in);  sys$close(&fab_out);
11514     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
11515     if (!(sts & 1)) {
11516       PerlMem_free(vmsin);
11517       PerlMem_free(vmsout);
11518       PerlMem_free(esa);
11519       PerlMem_free(ubf);
11520       PerlMem_free(rsa);
11521       PerlMem_free(esa_out);
11522       set_errno(EVMSERR); set_vaxc_errno(sts);
11523       return 0;
11524     }
11525
11526     PerlMem_free(vmsin);
11527     PerlMem_free(vmsout);
11528     PerlMem_free(esa);
11529     PerlMem_free(ubf);
11530     PerlMem_free(rsa);
11531     PerlMem_free(esa_out);
11532     return 1;
11533
11534 }  /* end of rmscopy() */
11535 /*}}}*/
11536
11537
11538 /***  The following glue provides 'hooks' to make some of the routines
11539  * from this file available from Perl.  These routines are sufficiently
11540  * basic, and are required sufficiently early in the build process,
11541  * that's it's nice to have them available to miniperl as well as the
11542  * full Perl, so they're set up here instead of in an extension.  The
11543  * Perl code which handles importation of these names into a given
11544  * package lives in [.VMS]Filespec.pm in @INC.
11545  */
11546
11547 void
11548 rmsexpand_fromperl(pTHX_ CV *cv)
11549 {
11550   dXSARGS;
11551   char *fspec, *defspec = NULL, *rslt;
11552   STRLEN n_a;
11553   int fs_utf8, dfs_utf8;
11554
11555   fs_utf8 = 0;
11556   dfs_utf8 = 0;
11557   if (!items || items > 2)
11558     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
11559   fspec = SvPV(ST(0),n_a);
11560   fs_utf8 = SvUTF8(ST(0));
11561   if (!fspec || !*fspec) XSRETURN_UNDEF;
11562   if (items == 2) {
11563     defspec = SvPV(ST(1),n_a);
11564     dfs_utf8 = SvUTF8(ST(1));
11565   }
11566   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
11567   ST(0) = sv_newmortal();
11568   if (rslt != NULL) {
11569     sv_usepvn(ST(0),rslt,strlen(rslt));
11570     if (fs_utf8) {
11571         SvUTF8_on(ST(0));
11572     }
11573   }
11574   XSRETURN(1);
11575 }
11576
11577 void
11578 vmsify_fromperl(pTHX_ CV *cv)
11579 {
11580   dXSARGS;
11581   char *vmsified;
11582   STRLEN n_a;
11583   int utf8_fl;
11584
11585   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
11586   utf8_fl = SvUTF8(ST(0));
11587   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11588   ST(0) = sv_newmortal();
11589   if (vmsified != NULL) {
11590     sv_usepvn(ST(0),vmsified,strlen(vmsified));
11591     if (utf8_fl) {
11592         SvUTF8_on(ST(0));
11593     }
11594   }
11595   XSRETURN(1);
11596 }
11597
11598 void
11599 unixify_fromperl(pTHX_ CV *cv)
11600 {
11601   dXSARGS;
11602   char *unixified;
11603   STRLEN n_a;
11604   int utf8_fl;
11605
11606   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
11607   utf8_fl = SvUTF8(ST(0));
11608   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11609   ST(0) = sv_newmortal();
11610   if (unixified != NULL) {
11611     sv_usepvn(ST(0),unixified,strlen(unixified));
11612     if (utf8_fl) {
11613         SvUTF8_on(ST(0));
11614     }
11615   }
11616   XSRETURN(1);
11617 }
11618
11619 void
11620 fileify_fromperl(pTHX_ CV *cv)
11621 {
11622   dXSARGS;
11623   char *fileified;
11624   STRLEN n_a;
11625   int utf8_fl;
11626
11627   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
11628   utf8_fl = SvUTF8(ST(0));
11629   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11630   ST(0) = sv_newmortal();
11631   if (fileified != NULL) {
11632     sv_usepvn(ST(0),fileified,strlen(fileified));
11633     if (utf8_fl) {
11634         SvUTF8_on(ST(0));
11635     }
11636   }
11637   XSRETURN(1);
11638 }
11639
11640 void
11641 pathify_fromperl(pTHX_ CV *cv)
11642 {
11643   dXSARGS;
11644   char *pathified;
11645   STRLEN n_a;
11646   int utf8_fl;
11647
11648   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
11649   utf8_fl = SvUTF8(ST(0));
11650   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11651   ST(0) = sv_newmortal();
11652   if (pathified != NULL) {
11653     sv_usepvn(ST(0),pathified,strlen(pathified));
11654     if (utf8_fl) {
11655         SvUTF8_on(ST(0));
11656     }
11657   }
11658   XSRETURN(1);
11659 }
11660
11661 void
11662 vmspath_fromperl(pTHX_ CV *cv)
11663 {
11664   dXSARGS;
11665   char *vmspath;
11666   STRLEN n_a;
11667   int utf8_fl;
11668
11669   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
11670   utf8_fl = SvUTF8(ST(0));
11671   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11672   ST(0) = sv_newmortal();
11673   if (vmspath != NULL) {
11674     sv_usepvn(ST(0),vmspath,strlen(vmspath));
11675     if (utf8_fl) {
11676         SvUTF8_on(ST(0));
11677     }
11678   }
11679   XSRETURN(1);
11680 }
11681
11682 void
11683 unixpath_fromperl(pTHX_ CV *cv)
11684 {
11685   dXSARGS;
11686   char *unixpath;
11687   STRLEN n_a;
11688   int utf8_fl;
11689
11690   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
11691   utf8_fl = SvUTF8(ST(0));
11692   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11693   ST(0) = sv_newmortal();
11694   if (unixpath != NULL) {
11695     sv_usepvn(ST(0),unixpath,strlen(unixpath));
11696     if (utf8_fl) {
11697         SvUTF8_on(ST(0));
11698     }
11699   }
11700   XSRETURN(1);
11701 }
11702
11703 void
11704 candelete_fromperl(pTHX_ CV *cv)
11705 {
11706   dXSARGS;
11707   char *fspec, *fsp;
11708   SV *mysv;
11709   IO *io;
11710   STRLEN n_a;
11711
11712   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
11713
11714   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11715   Newx(fspec, VMS_MAXRSS, char);
11716   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
11717   if (SvTYPE(mysv) == SVt_PVGV) {
11718     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
11719       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11720       ST(0) = &PL_sv_no;
11721       Safefree(fspec);
11722       XSRETURN(1);
11723     }
11724     fsp = fspec;
11725   }
11726   else {
11727     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
11728       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11729       ST(0) = &PL_sv_no;
11730       Safefree(fspec);
11731       XSRETURN(1);
11732     }
11733   }
11734
11735   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
11736   Safefree(fspec);
11737   XSRETURN(1);
11738 }
11739
11740 void
11741 rmscopy_fromperl(pTHX_ CV *cv)
11742 {
11743   dXSARGS;
11744   char *inspec, *outspec, *inp, *outp;
11745   int date_flag;
11746   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
11747                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11748   unsigned long int sts;
11749   SV *mysv;
11750   IO *io;
11751   STRLEN n_a;
11752
11753   if (items < 2 || items > 3)
11754     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
11755
11756   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11757   Newx(inspec, VMS_MAXRSS, char);
11758   if (SvTYPE(mysv) == SVt_PVGV) {
11759     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
11760       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11761       ST(0) = &PL_sv_no;
11762       Safefree(inspec);
11763       XSRETURN(1);
11764     }
11765     inp = inspec;
11766   }
11767   else {
11768     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
11769       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11770       ST(0) = &PL_sv_no;
11771       Safefree(inspec);
11772       XSRETURN(1);
11773     }
11774   }
11775   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
11776   Newx(outspec, VMS_MAXRSS, char);
11777   if (SvTYPE(mysv) == SVt_PVGV) {
11778     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
11779       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11780       ST(0) = &PL_sv_no;
11781       Safefree(inspec);
11782       Safefree(outspec);
11783       XSRETURN(1);
11784     }
11785     outp = outspec;
11786   }
11787   else {
11788     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
11789       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11790       ST(0) = &PL_sv_no;
11791       Safefree(inspec);
11792       Safefree(outspec);
11793       XSRETURN(1);
11794     }
11795   }
11796   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
11797
11798   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
11799   Safefree(inspec);
11800   Safefree(outspec);
11801   XSRETURN(1);
11802 }
11803
11804 /* The mod2fname is limited to shorter filenames by design, so it should
11805  * not be modified to support longer EFS pathnames
11806  */
11807 void
11808 mod2fname(pTHX_ CV *cv)
11809 {
11810   dXSARGS;
11811   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
11812        workbuff[NAM$C_MAXRSS*1 + 1];
11813   int total_namelen = 3, counter, num_entries;
11814   /* ODS-5 ups this, but we want to be consistent, so... */
11815   int max_name_len = 39;
11816   AV *in_array = (AV *)SvRV(ST(0));
11817
11818   num_entries = av_len(in_array);
11819
11820   /* All the names start with PL_. */
11821   strcpy(ultimate_name, "PL_");
11822
11823   /* Clean up our working buffer */
11824   Zero(work_name, sizeof(work_name), char);
11825
11826   /* Run through the entries and build up a working name */
11827   for(counter = 0; counter <= num_entries; counter++) {
11828     /* If it's not the first name then tack on a __ */
11829     if (counter) {
11830       strcat(work_name, "__");
11831     }
11832     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
11833                            PL_na));
11834   }
11835
11836   /* Check to see if we actually have to bother...*/
11837   if (strlen(work_name) + 3 <= max_name_len) {
11838     strcat(ultimate_name, work_name);
11839   } else {
11840     /* It's too darned big, so we need to go strip. We use the same */
11841     /* algorithm as xsubpp does. First, strip out doubled __ */
11842     char *source, *dest, last;
11843     dest = workbuff;
11844     last = 0;
11845     for (source = work_name; *source; source++) {
11846       if (last == *source && last == '_') {
11847         continue;
11848       }
11849       *dest++ = *source;
11850       last = *source;
11851     }
11852     /* Go put it back */
11853     strcpy(work_name, workbuff);
11854     /* Is it still too big? */
11855     if (strlen(work_name) + 3 > max_name_len) {
11856       /* Strip duplicate letters */
11857       last = 0;
11858       dest = workbuff;
11859       for (source = work_name; *source; source++) {
11860         if (last == toupper(*source)) {
11861         continue;
11862         }
11863         *dest++ = *source;
11864         last = toupper(*source);
11865       }
11866       strcpy(work_name, workbuff);
11867     }
11868
11869     /* Is it *still* too big? */
11870     if (strlen(work_name) + 3 > max_name_len) {
11871       /* Too bad, we truncate */
11872       work_name[max_name_len - 2] = 0;
11873     }
11874     strcat(ultimate_name, work_name);
11875   }
11876
11877   /* Okay, return it */
11878   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
11879   XSRETURN(1);
11880 }
11881
11882 void
11883 hushexit_fromperl(pTHX_ CV *cv)
11884 {
11885     dXSARGS;
11886
11887     if (items > 0) {
11888         VMSISH_HUSHED = SvTRUE(ST(0));
11889     }
11890     ST(0) = boolSV(VMSISH_HUSHED);
11891     XSRETURN(1);
11892 }
11893
11894
11895 PerlIO *
11896 Perl_vms_start_glob
11897    (pTHX_ SV *tmpglob,
11898     IO *io)
11899 {
11900     PerlIO *fp;
11901     struct vs_str_st *rslt;
11902     char *vmsspec;
11903     char *rstr;
11904     char *begin, *cp;
11905     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
11906     PerlIO *tmpfp;
11907     STRLEN i;
11908     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11909     struct dsc$descriptor_vs rsdsc;
11910     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
11911     unsigned long hasver = 0, isunix = 0;
11912     unsigned long int lff_flags = 0;
11913     int rms_sts;
11914
11915 #ifdef VMS_LONGNAME_SUPPORT
11916     lff_flags = LIB$M_FIL_LONG_NAMES;
11917 #endif
11918     /* The Newx macro will not allow me to assign a smaller array
11919      * to the rslt pointer, so we will assign it to the begin char pointer
11920      * and then copy the value into the rslt pointer.
11921      */
11922     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
11923     rslt = (struct vs_str_st *)begin;
11924     rslt->length = 0;
11925     rstr = &rslt->str[0];
11926     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
11927     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
11928     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
11929     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
11930
11931     Newx(vmsspec, VMS_MAXRSS, char);
11932
11933         /* We could find out if there's an explicit dev/dir or version
11934            by peeking into lib$find_file's internal context at
11935            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
11936            but that's unsupported, so I don't want to do it now and
11937            have it bite someone in the future. */
11938         /* Fix-me: vms_split_path() is the only way to do this, the
11939            existing method will fail with many legal EFS or UNIX specifications
11940          */
11941
11942     cp = SvPV(tmpglob,i);
11943
11944     for (; i; i--) {
11945         if (cp[i] == ';') hasver = 1;
11946         if (cp[i] == '.') {
11947             if (sts) hasver = 1;
11948             else sts = 1;
11949         }
11950         if (cp[i] == '/') {
11951             hasdir = isunix = 1;
11952             break;
11953         }
11954         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
11955             hasdir = 1;
11956             break;
11957         }
11958     }
11959     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
11960         Stat_t st;
11961         int stat_sts;
11962         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
11963         if (!stat_sts && S_ISDIR(st.st_mode)) {
11964             wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
11965             ok = (wilddsc.dsc$a_pointer != NULL);
11966         }
11967         else {
11968             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
11969             ok = (wilddsc.dsc$a_pointer != NULL);
11970         }
11971         if (ok)
11972             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
11973
11974         /* If not extended character set, replace ? with % */
11975         /* With extended character set, ? is a wildcard single character */
11976         if (!decc_efs_case_preserve) {
11977             for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
11978                 if (*cp == '?') *cp = '%';
11979         }
11980         sts = SS$_NORMAL;
11981         while (ok && $VMS_STATUS_SUCCESS(sts)) {
11982          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
11983          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
11984
11985             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
11986                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
11987             if (!$VMS_STATUS_SUCCESS(sts))
11988                 break;
11989
11990             /* with varying string, 1st word of buffer contains result length */
11991             rstr[rslt->length] = '\0';
11992
11993              /* Find where all the components are */
11994              v_sts = vms_split_path
11995                        (rstr,
11996                         &v_spec,
11997                         &v_len,
11998                         &r_spec,
11999                         &r_len,
12000                         &d_spec,
12001                         &d_len,
12002                         &n_spec,
12003                         &n_len,
12004                         &e_spec,
12005                         &e_len,
12006                         &vs_spec,
12007                         &vs_len);
12008
12009             /* If no version on input, truncate the version on output */
12010             if (!hasver && (vs_len > 0)) {
12011                 *vs_spec = '\0';
12012                 vs_len = 0;
12013
12014                 /* No version & a null extension on UNIX handling */
12015                 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
12016                     e_len = 0;
12017                     *e_spec = '\0';
12018                 }
12019             }
12020
12021             if (!decc_efs_case_preserve) {
12022                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
12023             }
12024
12025             if (hasdir) {
12026                 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
12027                 begin = rstr;
12028             }
12029             else {
12030                 /* Start with the name */
12031                 begin = n_spec;
12032             }
12033             strcat(begin,"\n");
12034             ok = (PerlIO_puts(tmpfp,begin) != EOF);
12035         }
12036         if (cxt) (void)lib$find_file_end(&cxt);
12037         if (ok && sts != RMS$_NMF &&
12038             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
12039         if (!ok) {
12040             if (!(sts & 1)) {
12041                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
12042             }
12043             PerlIO_close(tmpfp);
12044             fp = NULL;
12045         }
12046         else {
12047             PerlIO_rewind(tmpfp);
12048             IoTYPE(io) = IoTYPE_RDONLY;
12049             IoIFP(io) = fp = tmpfp;
12050             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
12051         }
12052     }
12053     Safefree(vmsspec);
12054     Safefree(rslt);
12055     return fp;
12056 }
12057
12058
12059 #ifdef HAS_SYMLINK
12060 static char *
12061 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec, const int *utf8_fl);
12062
12063 void
12064 vms_realpath_fromperl(pTHX_ CV *cv)
12065 {
12066   dXSARGS;
12067   char *fspec, *rslt_spec, *rslt;
12068   STRLEN n_a;
12069
12070   if (!items || items != 1)
12071     Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
12072
12073   fspec = SvPV(ST(0),n_a);
12074   if (!fspec || !*fspec) XSRETURN_UNDEF;
12075
12076   Newx(rslt_spec, VMS_MAXRSS + 1, char);
12077   rslt = do_vms_realpath(fspec, rslt_spec, NULL);
12078   ST(0) = sv_newmortal();
12079   if (rslt != NULL)
12080     sv_usepvn(ST(0),rslt,strlen(rslt));
12081   else
12082     Safefree(rslt_spec);
12083   XSRETURN(1);
12084 }
12085 #endif
12086
12087 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12088 int do_vms_case_tolerant(void);
12089
12090 void
12091 vms_case_tolerant_fromperl(pTHX_ CV *cv)
12092 {
12093   dXSARGS;
12094   ST(0) = boolSV(do_vms_case_tolerant());
12095   XSRETURN(1);
12096 }
12097 #endif
12098
12099 void
12100 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
12101                           struct interp_intern *dst)
12102 {
12103     memcpy(dst,src,sizeof(struct interp_intern));
12104 }
12105
12106 void
12107 Perl_sys_intern_clear(pTHX)
12108 {
12109 }
12110
12111 void
12112 Perl_sys_intern_init(pTHX)
12113 {
12114     unsigned int ix = RAND_MAX;
12115     double x;
12116
12117     VMSISH_HUSHED = 0;
12118
12119     /* fix me later to track running under GNV */
12120     /* this allows some limited testing */
12121     MY_POSIX_EXIT = decc_filename_unix_report;
12122
12123     x = (float)ix;
12124     MY_INV_RAND_MAX = 1./x;
12125 }
12126
12127 void
12128 init_os_extras(void)
12129 {
12130   dTHX;
12131   char* file = __FILE__;
12132   if (decc_disable_to_vms_logname_translation) {
12133     no_translate_barewords = TRUE;
12134   } else {
12135     no_translate_barewords = FALSE;
12136   }
12137
12138   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
12139   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
12140   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
12141   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
12142   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
12143   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
12144   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
12145   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
12146   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
12147   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
12148   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
12149 #ifdef HAS_SYMLINK
12150   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
12151 #endif
12152 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12153   newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
12154 #endif
12155
12156   store_pipelocs(aTHX);         /* will redo any earlier attempts */
12157
12158   return;
12159 }
12160
12161 #ifdef HAS_SYMLINK
12162
12163 #if __CRTL_VER == 80200000
12164 /* This missed getting in to the DECC SDK for 8.2 */
12165 char *realpath(const char *file_name, char * resolved_name, ...);
12166 #endif
12167
12168 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
12169 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
12170  * The perl fallback routine to provide realpath() is not as efficient
12171  * on OpenVMS.
12172  */
12173 static char *
12174 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12175 {
12176     return realpath(filespec, outbuf);
12177 }
12178
12179 /*}}}*/
12180 /* External entry points */
12181 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12182 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
12183 #else
12184 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12185 { return NULL; }
12186 #endif
12187
12188
12189 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12190 /* case_tolerant */
12191
12192 /*{{{int do_vms_case_tolerant(void)*/
12193 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
12194  * controlled by a process setting.
12195  */
12196 int do_vms_case_tolerant(void)
12197 {
12198     return vms_process_case_tolerant;
12199 }
12200 /*}}}*/
12201 /* External entry points */
12202 int Perl_vms_case_tolerant(void)
12203 { return do_vms_case_tolerant(); }
12204 #else
12205 int Perl_vms_case_tolerant(void)
12206 { return vms_process_case_tolerant; }
12207 #endif
12208
12209
12210  /* Start of DECC RTL Feature handling */
12211
12212 static int sys_trnlnm
12213    (const char * logname,
12214     char * value,
12215     int value_len)
12216 {
12217     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
12218     const unsigned long attr = LNM$M_CASE_BLIND;
12219     struct dsc$descriptor_s name_dsc;
12220     int status;
12221     unsigned short result;
12222     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
12223                                 {0, 0, 0, 0}};
12224
12225     name_dsc.dsc$w_length = strlen(logname);
12226     name_dsc.dsc$a_pointer = (char *)logname;
12227     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12228     name_dsc.dsc$b_class = DSC$K_CLASS_S;
12229
12230     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
12231
12232     if ($VMS_STATUS_SUCCESS(status)) {
12233
12234          /* Null terminate and return the string */
12235         /*--------------------------------------*/
12236         value[result] = 0;
12237     }
12238
12239     return status;
12240 }
12241
12242 static int sys_crelnm
12243    (const char * logname,
12244     const char * value)
12245 {
12246     int ret_val;
12247     const char * proc_table = "LNM$PROCESS_TABLE";
12248     struct dsc$descriptor_s proc_table_dsc;
12249     struct dsc$descriptor_s logname_dsc;
12250     struct itmlst_3 item_list[2];
12251
12252     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
12253     proc_table_dsc.dsc$w_length = strlen(proc_table);
12254     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12255     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
12256
12257     logname_dsc.dsc$a_pointer = (char *) logname;
12258     logname_dsc.dsc$w_length = strlen(logname);
12259     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12260     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
12261
12262     item_list[0].buflen = strlen(value);
12263     item_list[0].itmcode = LNM$_STRING;
12264     item_list[0].bufadr = (char *)value;
12265     item_list[0].retlen = NULL;
12266
12267     item_list[1].buflen = 0;
12268     item_list[1].itmcode = 0;
12269
12270     ret_val = sys$crelnm
12271                        (NULL,
12272                         (const struct dsc$descriptor_s *)&proc_table_dsc,
12273                         (const struct dsc$descriptor_s *)&logname_dsc,
12274                         NULL,
12275                         (const struct item_list_3 *) item_list);
12276
12277     return ret_val;
12278 }
12279
12280 /* C RTL Feature settings */
12281
12282 static int set_features
12283    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
12284     int (* cli_routine)(void),  /* Not documented */
12285     void *image_info)           /* Not documented */
12286 {
12287     int status;
12288     int s;
12289     int dflt;
12290     char* str;
12291     char val_str[10];
12292 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12293     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
12294     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
12295     unsigned long case_perm;
12296     unsigned long case_image;
12297 #endif
12298
12299     /* Allow an exception to bring Perl into the VMS debugger */
12300     vms_debug_on_exception = 0;
12301     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
12302     if ($VMS_STATUS_SUCCESS(status)) {
12303        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12304          vms_debug_on_exception = 1;
12305        else
12306          vms_debug_on_exception = 0;
12307     }
12308
12309     /* Create VTF-7 filenames from UNICODE instead of UTF-8 */
12310     vms_vtf7_filenames = 0;
12311     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
12312     if ($VMS_STATUS_SUCCESS(status)) {
12313        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12314          vms_vtf7_filenames = 1;
12315        else
12316          vms_vtf7_filenames = 0;
12317     }
12318
12319     /* Dectect running under GNV Bash or other UNIX like shell */
12320 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12321     gnv_unix_shell = 0;
12322     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
12323     if ($VMS_STATUS_SUCCESS(status)) {
12324        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12325          gnv_unix_shell = 1;
12326          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
12327          set_feature_default("DECC$EFS_CHARSET", 1);
12328          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
12329          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
12330          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
12331          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
12332        }
12333        else
12334          gnv_unix_shell = 0;
12335     }
12336 #endif
12337
12338     /* hacks to see if known bugs are still present for testing */
12339
12340     /* Readdir is returning filenames in VMS syntax always */
12341     decc_bug_readdir_efs1 = 1;
12342     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
12343     if ($VMS_STATUS_SUCCESS(status)) {
12344        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12345          decc_bug_readdir_efs1 = 1;
12346        else
12347          decc_bug_readdir_efs1 = 0;
12348     }
12349
12350     /* PCP mode requires creating /dev/null special device file */
12351     decc_bug_devnull = 0;
12352     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
12353     if ($VMS_STATUS_SUCCESS(status)) {
12354        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12355           decc_bug_devnull = 1;
12356        else
12357           decc_bug_devnull = 0;
12358     }
12359
12360     /* fgetname returning a VMS name in UNIX mode */
12361     decc_bug_fgetname = 1;
12362     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
12363     if ($VMS_STATUS_SUCCESS(status)) {
12364       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12365         decc_bug_fgetname = 1;
12366       else
12367         decc_bug_fgetname = 0;
12368     }
12369
12370     /* UNIX directory names with no paths are broken in a lot of places */
12371     decc_dir_barename = 1;
12372     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
12373     if ($VMS_STATUS_SUCCESS(status)) {
12374       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12375         decc_dir_barename = 1;
12376       else
12377         decc_dir_barename = 0;
12378     }
12379
12380 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12381     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
12382     if (s >= 0) {
12383         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
12384         if (decc_disable_to_vms_logname_translation < 0)
12385             decc_disable_to_vms_logname_translation = 0;
12386     }
12387
12388     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
12389     if (s >= 0) {
12390         decc_efs_case_preserve = decc$feature_get_value(s, 1);
12391         if (decc_efs_case_preserve < 0)
12392             decc_efs_case_preserve = 0;
12393     }
12394
12395     s = decc$feature_get_index("DECC$EFS_CHARSET");
12396     if (s >= 0) {
12397         decc_efs_charset = decc$feature_get_value(s, 1);
12398         if (decc_efs_charset < 0)
12399             decc_efs_charset = 0;
12400     }
12401
12402     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
12403     if (s >= 0) {
12404         decc_filename_unix_report = decc$feature_get_value(s, 1);
12405         if (decc_filename_unix_report > 0)
12406             decc_filename_unix_report = 1;
12407         else
12408             decc_filename_unix_report = 0;
12409     }
12410
12411     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
12412     if (s >= 0) {
12413         decc_filename_unix_only = decc$feature_get_value(s, 1);
12414         if (decc_filename_unix_only > 0) {
12415             decc_filename_unix_only = 1;
12416         }
12417         else {
12418             decc_filename_unix_only = 0;
12419         }
12420     }
12421
12422     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
12423     if (s >= 0) {
12424         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
12425         if (decc_filename_unix_no_version < 0)
12426             decc_filename_unix_no_version = 0;
12427     }
12428
12429     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
12430     if (s >= 0) {
12431         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
12432         if (decc_readdir_dropdotnotype < 0)
12433             decc_readdir_dropdotnotype = 0;
12434     }
12435
12436     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
12437     if ($VMS_STATUS_SUCCESS(status)) {
12438         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
12439         if (s >= 0) {
12440             dflt = decc$feature_get_value(s, 4);
12441             if (dflt > 0) {
12442                 decc_disable_posix_root = decc$feature_get_value(s, 1);
12443                 if (decc_disable_posix_root <= 0) {
12444                     decc$feature_set_value(s, 1, 1);
12445                     decc_disable_posix_root = 1;
12446                 }
12447             }
12448             else {
12449                 /* Traditionally Perl assumes this is off */
12450                 decc_disable_posix_root = 1;
12451                 decc$feature_set_value(s, 1, 1);
12452             }
12453         }
12454     }
12455
12456 #if __CRTL_VER >= 80200000
12457     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
12458     if (s >= 0) {
12459         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
12460         if (decc_posix_compliant_pathnames < 0)
12461             decc_posix_compliant_pathnames = 0;
12462         if (decc_posix_compliant_pathnames > 4)
12463             decc_posix_compliant_pathnames = 0;
12464     }
12465
12466 #endif
12467 #else
12468     status = sys_trnlnm
12469         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
12470     if ($VMS_STATUS_SUCCESS(status)) {
12471         val_str[0] = _toupper(val_str[0]);
12472         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12473            decc_disable_to_vms_logname_translation = 1;
12474         }
12475     }
12476
12477 #ifndef __VAX
12478     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
12479     if ($VMS_STATUS_SUCCESS(status)) {
12480         val_str[0] = _toupper(val_str[0]);
12481         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12482            decc_efs_case_preserve = 1;
12483         }
12484     }
12485 #endif
12486
12487     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
12488     if ($VMS_STATUS_SUCCESS(status)) {
12489         val_str[0] = _toupper(val_str[0]);
12490         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12491            decc_filename_unix_report = 1;
12492         }
12493     }
12494     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
12495     if ($VMS_STATUS_SUCCESS(status)) {
12496         val_str[0] = _toupper(val_str[0]);
12497         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12498            decc_filename_unix_only = 1;
12499            decc_filename_unix_report = 1;
12500         }
12501     }
12502     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", 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_no_version = 1;
12507         }
12508     }
12509     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", 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_readdir_dropdotnotype = 1;
12514         }
12515     }
12516 #endif
12517
12518 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12519
12520      /* Report true case tolerance */
12521     /*----------------------------*/
12522     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
12523     if (!$VMS_STATUS_SUCCESS(status))
12524         case_perm = PPROP$K_CASE_BLIND;
12525     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
12526     if (!$VMS_STATUS_SUCCESS(status))
12527         case_image = PPROP$K_CASE_BLIND;
12528     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
12529         (case_image == PPROP$K_CASE_SENSITIVE))
12530         vms_process_case_tolerant = 0;
12531
12532 #endif
12533
12534
12535     /* CRTL can be initialized past this point, but not before. */
12536 /*    DECC$CRTL_INIT(); */
12537
12538     return SS$_NORMAL;
12539 }
12540
12541 #ifdef __DECC
12542 #pragma nostandard
12543 #pragma extern_model save
12544 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
12545         const __align (LONGWORD) int spare[8] = {0};
12546
12547 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
12548 #if __DECC_VER >= 60560002
12549 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
12550 #else
12551 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
12552 #endif
12553 #endif /* __DECC */
12554
12555 const long vms_cc_features = (const long)set_features;
12556
12557 /*
12558 ** Force a reference to LIB$INITIALIZE to ensure it
12559 ** exists in the image.
12560 */
12561 int lib$initialize(void);
12562 #ifdef __DECC
12563 #pragma extern_model strict_refdef
12564 #endif
12565     int lib_init_ref = (int) lib$initialize;
12566
12567 #ifdef __DECC
12568 #pragma extern_model restore
12569 #pragma standard
12570 #endif
12571
12572 /*  End of vms.c */