vms/vms.c

   1 /*    vms.c
   2  *
   3  *    VMS-specific routines for perl5
   4  *
   5  *    Copyright (C) 1993-2015 by Charles Bailey and others.
   6  *
   7  *    You may distribute under the terms of either the GNU General Public
   8  *    License or the Artistic License, as specified in the README file.
   9  */
  10
  11 /*
  12  *   Yet small as was their hunted band
  13  *   still fell and fearless was each hand,
  14  *   and strong deeds they wrought yet oft,
  15  *   and loved the woods, whose ways more soft
  16  *   them seemed than thralls of that black throne
  17  *   to live and languish in halls of stone.
  18  *        "The Lay of Leithian", Canto II, lines 135-40
  19  *
  20  *     [p.162 of _The Lays of Beleriand_]
  21  */
  22
  23 #include <acedef.h>
  24 #include <acldef.h>
  25 #include <armdef.h>
  26 #include <chpdef.h>
  27 #include <clidef.h>
  28 #include <climsgdef.h>
  29 #include <dcdef.h>
  30 #include <descrip.h>
  31 #include <devdef.h>
  32 #include <dvidef.h>
  33 #include <float.h>
  34 #include <fscndef.h>
  35 #include <iodef.h>
  36 #include <jpidef.h>
  37 #include <kgbdef.h>
  38 #include <libclidef.h>
  39 #include <libdef.h>
  40 #include <lib$routines.h>
  41 #include <lnmdef.h>
  42 #include <ossdef.h>
  43 #include <ppropdef.h>
  44 #include <prvdef.h>
  45 #include <pscandef.h>
  46 #include <psldef.h>
  47 #include <rms.h>
  48 #include <shrdef.h>
  49 #include <ssdef.h>
  50 #include <starlet.h>
  51 #include <strdef.h>
  52 #include <str$routines.h>
  53 #include <syidef.h>
  54 #include <uaidef.h>
  55 #include <uicdef.h>
  56 #include <stsdef.h>
  57 #include <efndef.h>
  58 #define NO_EFN EFN$C_ENF
  59
  60 #include <unixlib.h>
  61
  62 #pragma member_alignment save
  63 #pragma nomember_alignment longword
  64 struct item_list_3 {
  65         unsigned short len;
  66         unsigned short code;
  67         void * bufadr;
  68         unsigned short * retadr;
  69 };
  70 #pragma member_alignment restore
  71
  72 /* Older versions of ssdef.h don't have these */
  73 #ifndef SS$_INVFILFOROP
  74 #  define SS$_INVFILFOROP 3930
  75 #endif
  76 #ifndef SS$_NOSUCHOBJECT
  77 #  define SS$_NOSUCHOBJECT 2696
  78 #endif
  79
  80 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
  81 #define PERLIO_NOT_STDIO 0
  82
  83 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
  84  * code below needs to get to the underlying CRTL routines. */
  85 #define DONT_MASK_RTL_CALLS
  86 #include "EXTERN.h"
  87 #include "perl.h"
  88 #include "XSUB.h"
  89 /* Anticipating future expansion in lexical warnings . . . */
  90 #ifndef WARN_INTERNAL
  91 #  define WARN_INTERNAL WARN_MISC
  92 #endif
  93
  94 #ifdef VMS_LONGNAME_SUPPORT
  95 #include <libfildef.h>
  96 #endif
  97
  98 #if __CRTL_VER >= 80200000
  99 #ifdef lstat
 100 #undef lstat
 101 #endif
 102 #else
 103 #ifdef lstat
 104 #undef lstat
 105 #endif
 106 #define lstat(_x, _y) stat(_x, _y)
 107 #endif
 108
 109 /* Routine to create a decterm for use with the Perl debugger */
 110 /* No headers, this information was found in the Programming Concepts Manual */
 111
 112 static int (*decw_term_port)
 113    (const struct dsc$descriptor_s * display,
 114     const struct dsc$descriptor_s * setup_file,
 115     const struct dsc$descriptor_s * customization,
 116     struct dsc$descriptor_s * result_device_name,
 117     unsigned short * result_device_name_length,
 118     void * controller,
 119     void * char_buffer,
 120     void * char_change_buffer) = 0;
 121
 122 #if defined(NEED_AN_H_ERRNO)
 123 dEXT int h_errno;
 124 #endif
 125
 126 #if defined(__DECC) || defined(__DECCXX)
 127 #pragma member_alignment save
 128 #pragma nomember_alignment longword
 129 #pragma message save
 130 #pragma message disable misalgndmem
 131 #endif
 132 struct itmlst_3 {
 133   unsigned short int buflen;
 134   unsigned short int itmcode;
 135   void *bufadr;
 136   unsigned short int *retlen;
 137 };
 138
 139 struct filescan_itmlst_2 {
 140     unsigned short length;
 141     unsigned short itmcode;
 142     char * component;
 143 };
 144
 145 struct vs_str_st {
 146     unsigned short length;
 147     char str[VMS_MAXRSS];
 148     unsigned short pad; /* for longword struct alignment */
 149 };
 150
 151 #if defined(__DECC) || defined(__DECCXX)
 152 #pragma message restore
 153 #pragma member_alignment restore
 154 #endif
 155
 156 #define do_fileify_dirspec(a,b,c,d)     mp_do_fileify_dirspec(aTHX_ a,b,c,d)
 157 #define do_pathify_dirspec(a,b,c,d)     mp_do_pathify_dirspec(aTHX_ a,b,c,d)
 158 #define do_tovmsspec(a,b,c,d)           mp_do_tovmsspec(aTHX_ a,b,c,0,d)
 159 #define do_tovmspath(a,b,c,d)           mp_do_tovmspath(aTHX_ a,b,c,d)
 160 #define do_rmsexpand(a,b,c,d,e,f,g)     mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
 161 #define do_vms_realpath(a,b,c)          mp_do_vms_realpath(aTHX_ a,b,c)
 162 #define do_vms_realname(a,b,c)          mp_do_vms_realname(aTHX_ a,b,c)
 163 #define do_tounixspec(a,b,c,d)          mp_do_tounixspec(aTHX_ a,b,c,d)
 164 #define do_tounixpath(a,b,c,d)          mp_do_tounixpath(aTHX_ a,b,c,d)
 165 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 166 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 167 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 168
 169 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
 170 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
 171 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
 172 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
 173
 174 static char *  int_rmsexpand_vms(
 175     const char * filespec, char * outbuf, unsigned opts);
 176 static char * int_rmsexpand_tovms(
 177     const char * filespec, char * outbuf, unsigned opts);
 178 static char *int_tovmsspec
 179    (const char *path, char *buf, int dir_flag, int * utf8_flag);
 180 static char * int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl);
 181 static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl);
 182 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl);
 183
 184 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 185 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 186
 187 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 188  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 189  * the Perl facility.
 190  */
 191 #define PERL_LNM_MAX_ITER 10
 192
 193   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 194 #define MAX_DCL_SYMBOL          (8192)
 195 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 196
 197 static char *__mystrtolower(char *str)
 198 {
 199   if (str) for (; *str; ++str) *str= tolower(*str);
 200   return str;
 201 }
 202
 203 static struct dsc$descriptor_s fildevdsc =
 204   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 205 static struct dsc$descriptor_s crtlenvdsc =
 206   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 207 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 208 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 209 static struct dsc$descriptor_s **env_tables = defenv;
 210 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 211
 212 /* True if we shouldn't treat barewords as logicals during directory */
 213 /* munching */
 214 static int no_translate_barewords;
 215
 216 /* DECC Features that may need to affect how Perl interprets
 217  * displays filename information
 218  */
 219 static int decc_disable_to_vms_logname_translation = 1;
 220 static int decc_disable_posix_root = 1;
 221 int decc_efs_case_preserve = 0;
 222 static int decc_efs_charset = 0;
 223 static int decc_efs_charset_index = -1;
 224 static int decc_filename_unix_no_version = 0;
 225 static int decc_filename_unix_only = 0;
 226 int decc_filename_unix_report = 0;
 227 int decc_posix_compliant_pathnames = 0;
 228 int decc_readdir_dropdotnotype = 0;
 229 static int vms_process_case_tolerant = 1;
 230 int vms_vtf7_filenames = 0;
 231 int gnv_unix_shell = 0;
 232 static int vms_unlink_all_versions = 0;
 233 static int vms_posix_exit = 0;
 234
 235 /* bug workarounds if needed */
 236 int decc_bug_devnull = 1;
 237 int vms_bug_stat_filename = 0;
 238
 239 static int vms_debug_on_exception = 0;
 240 static int vms_debug_fileify = 0;
 241
 242 /* Simple logical name translation */
 243 static int
 244 simple_trnlnm(const char * logname, char * value, int value_len)
 245 {
 246     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
 247     const unsigned long attr = LNM$M_CASE_BLIND;
 248     struct dsc$descriptor_s name_dsc;
 249     int status;
 250     unsigned short result;
 251     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
 252                                 {0, 0, 0, 0}};
 253
 254     name_dsc.dsc$w_length = strlen(logname);
 255     name_dsc.dsc$a_pointer = (char *)logname;
 256     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
 257     name_dsc.dsc$b_class = DSC$K_CLASS_S;
 258
 259     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
 260
 261     if ($VMS_STATUS_SUCCESS(status)) {
 262
 263          /* Null terminate and return the string */
 264         /*--------------------------------------*/
 265         value[result] = 0;
 266         return result;
 267     }
 268
 269     return 0;
 270 }
 271
 272
 273 /* Is this a UNIX file specification?
 274  *   No longer a simple check with EFS file specs
 275  *   For now, not a full check, but need to
 276  *   handle POSIX ^UP^ specifications
 277  *   Fixing to handle ^/ cases would require
 278  *   changes to many other conversion routines.
 279  */
 280
 281 static int
 282 is_unix_filespec(const char *path)
 283 {
 284     int ret_val;
 285     const char * pch1;
 286
 287     ret_val = 0;
 288     if (strncmp(path,"\"^UP^",5) != 0) {
 289         pch1 = strchr(path, '/');
 290         if (pch1 != NULL)
 291             ret_val = 1;
 292         else {
 293
 294             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 295             if (decc_filename_unix_report || decc_filename_unix_only) {
 296             if (strcmp(path,".") == 0)
 297                 ret_val = 1;
 298             }
 299         }
 300     }
 301     return ret_val;
 302 }
 303
 304 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 305  */
 306
 307 static void
 308 ucs2_to_vtf7(char *outspec, unsigned long ucs2_char, int * output_cnt)
 309 {
 310     unsigned char * ucs_ptr;
 311     int hex;
 312
 313     ucs_ptr = (unsigned char *)&ucs2_char;
 314
 315     outspec[0] = '^';
 316     outspec[1] = 'U';
 317     hex = (ucs_ptr[1] >> 4) & 0xf;
 318     if (hex < 0xA)
 319         outspec[2] = hex + '0';
 320     else
 321         outspec[2] = (hex - 9) + 'A';
 322     hex = ucs_ptr[1] & 0xF;
 323     if (hex < 0xA)
 324         outspec[3] = hex + '0';
 325     else {
 326         outspec[3] = (hex - 9) + 'A';
 327     }
 328     hex = (ucs_ptr[0] >> 4) & 0xf;
 329     if (hex < 0xA)
 330         outspec[4] = hex + '0';
 331     else
 332         outspec[4] = (hex - 9) + 'A';
 333     hex = ucs_ptr[1] & 0xF;
 334     if (hex < 0xA)
 335         outspec[5] = hex + '0';
 336     else {
 337         outspec[5] = (hex - 9) + 'A';
 338     }
 339     *output_cnt = 6;
 340 }
 341
 342
 343 /* This handles the conversion of a UNIX extended character set to a ^
 344  * escaped VMS character.
 345  * in a UNIX file specification.
 346  *
 347  * The output count variable contains the number of characters added
 348  * to the output string.
 349  *
 350  * The return value is the number of characters read from the input string
 351  */
 352 static int
 353 copy_expand_unix_filename_escape(char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 354 {
 355     int count;
 356     int utf8_flag;
 357
 358     utf8_flag = 0;
 359     if (utf8_fl)
 360       utf8_flag = *utf8_fl;
 361
 362     count = 0;
 363     *output_cnt = 0;
 364     if (*inspec >= 0x80) {
 365         if (utf8_fl && vms_vtf7_filenames) {
 366         unsigned long ucs_char;
 367
 368             ucs_char = 0;
 369
 370             if ((*inspec & 0xE0) == 0xC0) {
 371                 /* 2 byte Unicode */
 372                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 373                 if (ucs_char >= 0x80) {
 374                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 375                     return 2;
 376                 }
 377             } else if ((*inspec & 0xF0) == 0xE0) {
 378                 /* 3 byte Unicode */
 379                 ucs_char = ((inspec[0] & 0xF) << 12) +
 380                    ((inspec[1] & 0x3f) << 6) +
 381                    (inspec[2] & 0x3f);
 382                 if (ucs_char >= 0x800) {
 383                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 384                     return 3;
 385                 }
 386
 387 #if 0 /* I do not see longer sequences supported by OpenVMS */
 388       /* Maybe some one can fix this later */
 389             } else if ((*inspec & 0xF8) == 0xF0) {
 390                 /* 4 byte Unicode */
 391                 /* UCS-4 to UCS-2 */
 392             } else if ((*inspec & 0xFC) == 0xF8) {
 393                 /* 5 byte Unicode */
 394                 /* UCS-4 to UCS-2 */
 395             } else if ((*inspec & 0xFE) == 0xFC) {
 396                 /* 6 byte Unicode */
 397                 /* UCS-4 to UCS-2 */
 398 #endif
 399             }
 400         }
 401
 402         /* High bit set, but not a Unicode character! */
 403
 404         /* Non printing DECMCS or ISO Latin-1 character? */
 405         if ((unsigned char)*inspec <= 0x9F) {
 406             int hex;
 407             outspec[0] = '^';
 408             outspec++;
 409             hex = (*inspec >> 4) & 0xF;
 410             if (hex < 0xA)
 411                 outspec[1] = hex + '0';
 412             else {
 413                 outspec[1] = (hex - 9) + 'A';
 414             }
 415             hex = *inspec & 0xF;
 416             if (hex < 0xA)
 417                 outspec[2] = hex + '0';
 418             else {
 419                 outspec[2] = (hex - 9) + 'A';
 420             }
 421             *output_cnt = 3;
 422             return 1;
 423         } else if ((unsigned char)*inspec == 0xA0) {
 424             outspec[0] = '^';
 425             outspec[1] = 'A';
 426             outspec[2] = '0';
 427             *output_cnt = 3;
 428             return 1;
 429         } else if ((unsigned char)*inspec == 0xFF) {
 430             outspec[0] = '^';
 431             outspec[1] = 'F';
 432             outspec[2] = 'F';
 433             *output_cnt = 3;
 434             return 1;
 435         }
 436         *outspec = *inspec;
 437         *output_cnt = 1;
 438         return 1;
 439     }
 440
 441     /* Is this a macro that needs to be passed through?
 442      * Macros start with $( and an alpha character, followed
 443      * by a string of alpha numeric characters ending with a )
 444      * If this does not match, then encode it as ODS-5.
 445      */
 446     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 447     int tcnt;
 448
 449         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 450             tcnt = 3;
 451             outspec[0] = inspec[0];
 452             outspec[1] = inspec[1];
 453             outspec[2] = inspec[2];
 454
 455             while(isalnum(inspec[tcnt]) ||
 456                   (inspec[2] == '.') || (inspec[2] == '_')) {
 457                 outspec[tcnt] = inspec[tcnt];
 458                 tcnt++;
 459             }
 460             if (inspec[tcnt] == ')') {
 461                 outspec[tcnt] = inspec[tcnt];
 462                 tcnt++;
 463                 *output_cnt = tcnt;
 464                 return tcnt;
 465             }
 466         }
 467     }
 468
 469     switch (*inspec) {
 470     case 0x7f:
 471         outspec[0] = '^';
 472         outspec[1] = '7';
 473         outspec[2] = 'F';
 474         *output_cnt = 3;
 475         return 1;
 476         break;
 477     case '?':
 478         if (decc_efs_charset == 0)
 479           outspec[0] = '%';
 480         else
 481           outspec[0] = '?';
 482         *output_cnt = 1;
 483         return 1;
 484         break;
 485     case '.':
 486     case '~':
 487     case '!':
 488     case '#':
 489     case '&':
 490     case '\'':
 491     case '`':
 492     case '(':
 493     case ')':
 494     case '+':
 495     case '@':
 496     case '{':
 497     case '}':
 498     case ',':
 499     case ';':
 500     case '[':
 501     case ']':
 502     case '%':
 503     case '^':
 504     case '\\':
 505         /* Don't escape again if following character is
 506          * already something we escape.
 507          */
 508         if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
 509             *outspec = *inspec;
 510             *output_cnt = 1;
 511             return 1;
 512             break;
 513         }
 514         /* But otherwise fall through and escape it. */
 515     case '=':
 516         /* Assume that this is to be escaped */
 517         outspec[0] = '^';
 518         outspec[1] = *inspec;
 519         *output_cnt = 2;
 520         return 1;
 521         break;
 522     case ' ': /* space */
 523         /* Assume that this is to be escaped */
 524         outspec[0] = '^';
 525         outspec[1] = '_';
 526         *output_cnt = 2;
 527         return 1;
 528         break;
 529     default:
 530         *outspec = *inspec;
 531         *output_cnt = 1;
 532         return 1;
 533         break;
 534     }
 535     return 0;
 536 }
 537
 538
 539 /* This handles the expansion of a '^' prefix to the proper character
 540  * in a UNIX file specification.
 541  *
 542  * The output count variable contains the number of characters added
 543  * to the output string.
 544  *
 545  * The return value is the number of characters read from the input
 546  * string
 547  */
 548 static int
 549 copy_expand_vms_filename_escape(char *outspec, const char *inspec, int *output_cnt)
 550 {
 551     int count;
 552     int scnt;
 553
 554     count = 0;
 555     *output_cnt = 0;
 556     if (*inspec == '^') {
 557         inspec++;
 558         switch (*inspec) {
 559         /* Spaces and non-trailing dots should just be passed through,
 560          * but eat the escape character.
 561          */
 562         case '.':
 563             *outspec = *inspec;
 564             count += 2;
 565             (*output_cnt)++;
 566             break;
 567         case '_': /* space */
 568             *outspec = ' ';
 569             count += 2;
 570             (*output_cnt)++;
 571             break;
 572         case '^':
 573             /* Hmm.  Better leave the escape escaped. */
 574             outspec[0] = '^';
 575             outspec[1] = '^';
 576             count += 2;
 577             (*output_cnt) += 2;
 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 /* vms_split_path - Verify that the input file specification is a
 631  * VMS format file specification, and provide pointers to the components of
 632  * it.  With EFS format filenames, this is virtually the only way to
 633  * parse a VMS path specification into components.
 634  *
 635  * If the sum of the components do not add up to the length of the
 636  * string, then the passed file specification is probably a UNIX style
 637  * path.
 638  */
 639 static int
 640 vms_split_path(const char * path, char * * volume, int * vol_len, char * * root, int * root_len,
 641                char * * dir, int * dir_len, char * * name, int * name_len,
 642                char * * ext, int * ext_len, char * * version, int * ver_len)
 643 {
 644     struct dsc$descriptor path_desc;
 645     int status;
 646     unsigned long flags;
 647     int ret_stat;
 648     struct filescan_itmlst_2 item_list[9];
 649     const int filespec = 0;
 650     const int nodespec = 1;
 651     const int devspec = 2;
 652     const int rootspec = 3;
 653     const int dirspec = 4;
 654     const int namespec = 5;
 655     const int typespec = 6;
 656     const int verspec = 7;
 657
 658     /* Assume the worst for an easy exit */
 659     ret_stat = -1;
 660     *volume = NULL;
 661     *vol_len = 0;
 662     *root = NULL;
 663     *root_len = 0;
 664     *dir = NULL;
 665     *name = NULL;
 666     *name_len = 0;
 667     *ext = NULL;
 668     *ext_len = 0;
 669     *version = NULL;
 670     *ver_len = 0;
 671
 672     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 673     path_desc.dsc$w_length = strlen(path);
 674     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 675     path_desc.dsc$b_class = DSC$K_CLASS_S;
 676
 677     /* Get the total length, if it is shorter than the string passed
 678      * then this was probably not a VMS formatted file specification
 679      */
 680     item_list[filespec].itmcode = FSCN$_FILESPEC;
 681     item_list[filespec].length = 0;
 682     item_list[filespec].component = NULL;
 683
 684     /* If the node is present, then it gets considered as part of the
 685      * volume name to hopefully make things simple.
 686      */
 687     item_list[nodespec].itmcode = FSCN$_NODE;
 688     item_list[nodespec].length = 0;
 689     item_list[nodespec].component = NULL;
 690
 691     item_list[devspec].itmcode = FSCN$_DEVICE;
 692     item_list[devspec].length = 0;
 693     item_list[devspec].component = NULL;
 694
 695     /* root is a special case,  adding it to either the directory or
 696      * the device components will probably complicate things for the
 697      * callers of this routine, so leave it separate.
 698      */
 699     item_list[rootspec].itmcode = FSCN$_ROOT;
 700     item_list[rootspec].length = 0;
 701     item_list[rootspec].component = NULL;
 702
 703     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 704     item_list[dirspec].length = 0;
 705     item_list[dirspec].component = NULL;
 706
 707     item_list[namespec].itmcode = FSCN$_NAME;
 708     item_list[namespec].length = 0;
 709     item_list[namespec].component = NULL;
 710
 711     item_list[typespec].itmcode = FSCN$_TYPE;
 712     item_list[typespec].length = 0;
 713     item_list[typespec].component = NULL;
 714
 715     item_list[verspec].itmcode = FSCN$_VERSION;
 716     item_list[verspec].length = 0;
 717     item_list[verspec].component = NULL;
 718
 719     item_list[8].itmcode = 0;
 720     item_list[8].length = 0;
 721     item_list[8].component = NULL;
 722
 723     status = sys$filescan
 724        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 725         &flags, NULL, NULL);
 726     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 727
 728     /* If we parsed it successfully these two lengths should be the same */
 729     if (path_desc.dsc$w_length != item_list[filespec].length)
 730         return ret_stat;
 731
 732     /* If we got here, then it is a VMS file specification */
 733     ret_stat = 0;
 734
 735     /* set the volume name */
 736     if (item_list[nodespec].length > 0) {
 737         *volume = item_list[nodespec].component;
 738         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 739     }
 740     else {
 741         *volume = item_list[devspec].component;
 742         *vol_len = item_list[devspec].length;
 743     }
 744
 745     *root = item_list[rootspec].component;
 746     *root_len = item_list[rootspec].length;
 747
 748     *dir = item_list[dirspec].component;
 749     *dir_len = item_list[dirspec].length;
 750
 751     /* Now fun with versions and EFS file specifications
 752      * The parser can not tell the difference when a "." is a version
 753      * delimiter or a part of the file specification.
 754      */
 755     if ((decc_efs_charset) &&
 756         (item_list[verspec].length > 0) &&
 757         (item_list[verspec].component[0] == '.')) {
 758         *name = item_list[namespec].component;
 759         *name_len = item_list[namespec].length + item_list[typespec].length;
 760         *ext = item_list[verspec].component;
 761         *ext_len = item_list[verspec].length;
 762         *version = NULL;
 763         *ver_len = 0;
 764     }
 765     else {
 766         *name = item_list[namespec].component;
 767         *name_len = item_list[namespec].length;
 768         *ext = item_list[typespec].component;
 769         *ext_len = item_list[typespec].length;
 770         *version = item_list[verspec].component;
 771         *ver_len = item_list[verspec].length;
 772     }
 773     return ret_stat;
 774 }
 775
 776 /* Routine to determine if the file specification ends with .dir */
 777 static int
 778 is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len)
 779 {
 780
 781     /* e_len must be 4, and version must be <= 2 characters */
 782     if (e_len != 4 || vs_len > 2)
 783         return 0;
 784
 785     /* If a version number is present, it needs to be one */
 786     if ((vs_len == 2) && (vs_spec[1] != '1'))
 787         return 0;
 788
 789     /* Look for the DIR on the extension */
 790     if (vms_process_case_tolerant) {
 791         if ((toupper(e_spec[1]) == 'D') &&
 792             (toupper(e_spec[2]) == 'I') &&
 793             (toupper(e_spec[3]) == 'R')) {
 794             return 1;
 795         }
 796     } else {
 797         /* Directory extensions are supposed to be in upper case only */
 798         /* I would not be surprised if this rule can not be enforced */
 799         /* if and when someone fully debugs the case sensitive mode */
 800         if ((e_spec[1] == 'D') &&
 801             (e_spec[2] == 'I') &&
 802             (e_spec[3] == 'R')) {
 803             return 1;
 804         }
 805     }
 806     return 0;
 807 }
 808
 809
 810 /* my_maxidx
 811  * Routine to retrieve the maximum equivalence index for an input
 812  * logical name.  Some calls to this routine have no knowledge if
 813  * the variable is a logical or not.  So on error we return a max
 814  * index of zero.
 815  */
 816 /*{{{int my_maxidx(const char *lnm) */
 817 static int
 818 my_maxidx(const char *lnm)
 819 {
 820     int status;
 821     int midx;
 822     int attr = LNM$M_CASE_BLIND;
 823     struct dsc$descriptor lnmdsc;
 824     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 825                                 {0, 0, 0, 0}};
 826
 827     lnmdsc.dsc$w_length = strlen(lnm);
 828     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 829     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 830     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 831
 832     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 833     if ((status & 1) == 0)
 834        midx = 0;
 835
 836     return (midx);
 837 }
 838 /*}}}*/
 839
 840 /* Routine to remove the 2-byte prefix from the translation of a
 841  * process-permanent file (PPF).
 842  */
 843 static inline unsigned short int
 844 S_remove_ppf_prefix(const char *lnm, char *eqv, unsigned short int eqvlen)
 845 {
 846     if (*((int *)lnm) == *((int *)"SYS$")                    &&
 847         eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00      &&
 848         ( (lnm[4] == 'O' && !strcmp(lnm,"SYS$OUTPUT"))  ||
 849           (lnm[4] == 'I' && !strcmp(lnm,"SYS$INPUT"))   ||
 850           (lnm[4] == 'E' && !strcmp(lnm,"SYS$ERROR"))   ||
 851           (lnm[4] == 'C' && !strcmp(lnm,"SYS$COMMAND")) )  ) {
 852
 853         memmove(eqv, eqv+4, eqvlen-4);
 854         eqvlen -= 4;
 855     }
 856     return eqvlen;
 857 }
 858
 859 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 860 int
 861 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 862   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 863 {
 864     const char *cp1;
 865     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 866     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 867     bool found_in_crtlenv = 0, found_in_clisym = 0;
 868     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 869     int midx;
 870     unsigned char acmode;
 871     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 872                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 873     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 874                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 875                                  {0, 0, 0, 0}};
 876     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 877 #if defined(PERL_IMPLICIT_CONTEXT)
 878     pTHX = NULL;
 879     if (PL_curinterp) {
 880       aTHX = PERL_GET_INTERP;
 881     } else {
 882       aTHX = NULL;
 883     }
 884 #endif
 885
 886     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 887       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 888     }
 889     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 890       *cp2 = _toupper(*cp1);
 891       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 892         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 893         return 0;
 894       }
 895     }
 896     lnmdsc.dsc$w_length = cp1 - lnm;
 897     lnmdsc.dsc$a_pointer = uplnm;
 898     uplnm[lnmdsc.dsc$w_length] = '\0';
 899     secure = flags & PERL__TRNENV_SECURE;
 900     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 901     if (!tabvec || !*tabvec) tabvec = env_tables;
 902
 903     for (curtab = 0; tabvec[curtab]; curtab++) {
 904       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 905         if (!ivenv && !secure) {
 906           char *eq;
 907           int i;
 908           if (!environ) {
 909             ivenv = 1;
 910 #if defined(PERL_IMPLICIT_CONTEXT)
 911             if (aTHX == NULL) {
 912                 fprintf(stderr,
 913                     "Can't read CRTL environ\n");
 914             } else
 915 #endif
 916                 Perl_warn(aTHX_ "Can't read CRTL environ\n");
 917             continue;
 918           }
 919           retsts = SS$_NOLOGNAM;
 920           for (i = 0; environ[i]; i++) {
 921             if ((eq = strchr(environ[i],'=')) &&
 922                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 923                 !strncmp(environ[i],lnm,eq - environ[i])) {
 924               eq++;
 925               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 926               if (!eqvlen) continue;
 927               retsts = SS$_NORMAL;
 928               break;
 929             }
 930           }
 931           if (retsts != SS$_NOLOGNAM) {
 932               found_in_crtlenv = 1;
 933               break;
 934           }
 935         }
 936       }
 937       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 938                !str$case_blind_compare(&tmpdsc,&clisym)) {
 939         if (!ivsym && !secure) {
 940           unsigned short int deflen = LNM$C_NAMLENGTH;
 941           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 942           /* dynamic dsc to accommodate possible long value */
 943           _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
 944           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 945           if (retsts & 1) {
 946             if (eqvlen > MAX_DCL_SYMBOL) {
 947               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 948               eqvlen = MAX_DCL_SYMBOL;
 949               /* Special hack--we might be called before the interpreter's */
 950               /* fully initialized, in which case either thr or PL_curcop */
 951               /* might be bogus. We have to check, since ckWARN needs them */
 952               /* both to be valid if running threaded */
 953 #if defined(PERL_IMPLICIT_CONTEXT)
 954               if (aTHX == NULL) {
 955                   fprintf(stderr,
 956                      "Value of CLI symbol \"%s\" too long",lnm);
 957               } else
 958 #endif
 959                 if (ckWARN(WARN_MISC)) {
 960                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 961                 }
 962             }
 963             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 964           }
 965           _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
 966           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 967           if (retsts == LIB$_NOSUCHSYM) continue;
 968           found_in_clisym = 1;
 969           break;
 970         }
 971       }
 972       else if (!ivlnm) {
 973         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
 974           midx = my_maxidx(lnm);
 975           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
 976             lnmlst[1].bufadr = cp2;
 977             eqvlen = 0;
 978             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 979             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
 980             if (retsts == SS$_NOLOGNAM) break;
 981             eqvlen = S_remove_ppf_prefix(uplnm, eqv, eqvlen);
 982             cp2 += eqvlen;
 983             *cp2 = '\0';
 984           }
 985           if ((retsts == SS$_IVLOGNAM) ||
 986               (retsts == SS$_NOLOGNAM)) { continue; }
 987           eqvlen = strlen(eqv);
 988         }
 989         else {
 990           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 991           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 992           if (retsts == SS$_NOLOGNAM) continue;
 993           eqvlen = S_remove_ppf_prefix(uplnm, eqv, eqvlen);
 994           eqv[eqvlen] = '\0';
 995         }
 996         break;
 997       }
 998     }
 999     /* An index only makes sense for logical names, so make sure we aren't
1000      * iterating over an index for an environ var or DCL symbol and getting
1001      * the same answer ad infinitum.
1002      */
1003     if (idx > 0 && (found_in_crtlenv || found_in_clisym)) {
1004         return 0;
1005     }
1006     else if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1007     else if (retsts == LIB$_NOSUCHSYM ||
1008              retsts == SS$_NOLOGNAM) {
1009      /* Unsuccessful lookup is normal -- no need to set errno */
1010      return 0;
1011     }
1012     else if (retsts == LIB$_INVSYMNAM ||
1013              retsts == SS$_IVLOGNAM   ||
1014              retsts == SS$_IVLOGTAB) {
1015       set_errno(EINVAL);  set_vaxc_errno(retsts);
1016     }
1017     else _ckvmssts_noperl(retsts);
1018     return 0;
1019 }  /* end of vmstrnenv */
1020 /*}}}*/
1021
1022 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1023 /* Define as a function so we can access statics. */
1024 int
1025 Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1026 {
1027     int flags = 0;
1028
1029 #if defined(PERL_IMPLICIT_CONTEXT)
1030     if (aTHX != NULL)
1031 #endif
1032 #ifdef SECURE_INTERNAL_GETENV
1033         flags = (PL_curinterp ? TAINTING_get : will_taint) ?
1034                  PERL__TRNENV_SECURE : 0;
1035 #endif
1036
1037     return vmstrnenv(lnm, eqv, idx, fildev, flags);
1038 }
1039 /*}}}*/
1040
1041 /* my_getenv
1042  * Note: Uses Perl temp to store result so char * can be returned to
1043  * caller; this pointer will be invalidated at next Perl statement
1044  * transition.
1045  * We define this as a function rather than a macro in terms of my_getenv_len()
1046  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1047  * allocate SVs).
1048  */
1049 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1050 char *
1051 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1052 {
1053     const char *cp1;
1054     static char *__my_getenv_eqv = NULL;
1055     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1056     unsigned long int idx = 0;
1057     int success, secure;
1058     int midx, flags;
1059     SV *tmpsv;
1060
1061     midx = my_maxidx(lnm) + 1;
1062
1063     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1064       /* Set up a temporary buffer for the return value; Perl will
1065        * clean it up at the next statement transition */
1066       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1067       if (!tmpsv) return NULL;
1068       eqv = SvPVX(tmpsv);
1069     }
1070     else {
1071       /* Assume no interpreter ==> single thread */
1072       if (__my_getenv_eqv != NULL) {
1073         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1074       }
1075       else {
1076         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1077       }
1078       eqv = __my_getenv_eqv;
1079     }
1080
1081     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1082     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1083       int len;
1084       getcwd(eqv,LNM$C_NAMLENGTH);
1085
1086       len = strlen(eqv);
1087
1088       /* Get rid of "000000/ in rooted filespecs */
1089       if (len > 7) {
1090         char * zeros;
1091         zeros = strstr(eqv, "/000000/");
1092         if (zeros != NULL) {
1093           int mlen;
1094           mlen = len - (zeros - eqv) - 7;
1095           memmove(zeros, &zeros[7], mlen);
1096           len = len - 7;
1097           eqv[len] = '\0';
1098         }
1099       }
1100       return eqv;
1101     }
1102     else {
1103       /* Impose security constraints only if tainting */
1104       if (sys) {
1105         /* Impose security constraints only if tainting */
1106         secure = PL_curinterp ? TAINTING_get : will_taint;
1107       }
1108       else {
1109         secure = 0;
1110       }
1111
1112       flags =
1113 #ifdef SECURE_INTERNAL_GETENV
1114               secure ? PERL__TRNENV_SECURE : 0
1115 #else
1116               0
1117 #endif
1118       ;
1119
1120       /* For the getenv interface we combine all the equivalence names
1121        * of a search list logical into one value to acquire a maximum
1122        * value length of 255*128 (assuming %ENV is using logicals).
1123        */
1124       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1125
1126       /* If the name contains a semicolon-delimited index, parse it
1127        * off and make sure we only retrieve the equivalence name for
1128        * that index.  */
1129       if ((cp2 = strchr(lnm,';')) != NULL) {
1130         my_strlcpy(uplnm, lnm, cp2 - lnm + 1);
1131         idx = strtoul(cp2+1,NULL,0);
1132         lnm = uplnm;
1133         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1134       }
1135
1136       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1137
1138       return success ? eqv : NULL;
1139     }
1140
1141 }  /* end of my_getenv() */
1142 /*}}}*/
1143
1144
1145 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1146 char *
1147 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1148 {
1149     const char *cp1;
1150     char *buf, *cp2;
1151     unsigned long idx = 0;
1152     int midx, flags;
1153     static char *__my_getenv_len_eqv = NULL;
1154     int secure;
1155     SV *tmpsv;
1156
1157     midx = my_maxidx(lnm) + 1;
1158
1159     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1160       /* Set up a temporary buffer for the return value; Perl will
1161        * clean it up at the next statement transition */
1162       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1163       if (!tmpsv) return NULL;
1164       buf = SvPVX(tmpsv);
1165     }
1166     else {
1167       /* Assume no interpreter ==> single thread */
1168       if (__my_getenv_len_eqv != NULL) {
1169         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1170       }
1171       else {
1172         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1173       }
1174       buf = __my_getenv_len_eqv;
1175     }
1176
1177     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1178     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1179     char * zeros;
1180
1181       getcwd(buf,LNM$C_NAMLENGTH);
1182       *len = strlen(buf);
1183
1184       /* Get rid of "000000/ in rooted filespecs */
1185       if (*len > 7) {
1186       zeros = strstr(buf, "/000000/");
1187       if (zeros != NULL) {
1188         int mlen;
1189         mlen = *len - (zeros - buf) - 7;
1190         memmove(zeros, &zeros[7], mlen);
1191         *len = *len - 7;
1192         buf[*len] = '\0';
1193         }
1194       }
1195       return buf;
1196     }
1197     else {
1198       if (sys) {
1199         /* Impose security constraints only if tainting */
1200         secure = PL_curinterp ? TAINTING_get : will_taint;
1201       }
1202       else {
1203         secure = 0;
1204       }
1205
1206       flags =
1207 #ifdef SECURE_INTERNAL_GETENV
1208               secure ? PERL__TRNENV_SECURE : 0
1209 #else
1210               0
1211 #endif
1212       ;
1213
1214       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1215
1216       if ((cp2 = strchr(lnm,';')) != NULL) {
1217         my_strlcpy(buf, lnm, cp2 - lnm + 1);
1218         idx = strtoul(cp2+1,NULL,0);
1219         lnm = buf;
1220         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1221       }
1222
1223       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1224
1225       /* Get rid of "000000/ in rooted filespecs */
1226       if (*len > 7) {
1227         char * zeros;
1228         zeros = strstr(buf, "/000000/");
1229         if (zeros != NULL) {
1230           int mlen;
1231           mlen = *len - (zeros - buf) - 7;
1232           memmove(zeros, &zeros[7], mlen);
1233           *len = *len - 7;
1234           buf[*len] = '\0';
1235         }
1236       }
1237
1238       return *len ? buf : NULL;
1239     }
1240
1241 }  /* end of my_getenv_len() */
1242 /*}}}*/
1243
1244 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
1245
1246 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1247
1248 /*{{{ void prime_env_iter() */
1249 void
1250 prime_env_iter(void)
1251 /* Fill the %ENV associative array with all logical names we can
1252  * find, in preparation for iterating over it.
1253  */
1254 {
1255   static int primed = 0;
1256   HV *seenhv = NULL, *envhv;
1257   SV *sv = NULL;
1258   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1259   unsigned short int chan;
1260 #ifndef CLI$M_TRUSTED
1261 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1262 #endif
1263   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1264   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0;
1265   long int i;
1266   bool have_sym = FALSE, have_lnm = FALSE;
1267   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1268   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1269   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1270   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1271   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1272 #if defined(PERL_IMPLICIT_CONTEXT)
1273   pTHX;
1274 #endif
1275 #if defined(USE_ITHREADS)
1276   static perl_mutex primenv_mutex;
1277   MUTEX_INIT(&primenv_mutex);
1278 #endif
1279
1280 #if defined(PERL_IMPLICIT_CONTEXT)
1281     /* We jump through these hoops because we can be called at */
1282     /* platform-specific initialization time, which is before anything is */
1283     /* set up--we can't even do a plain dTHX since that relies on the */
1284     /* interpreter structure to be initialized */
1285     if (PL_curinterp) {
1286       aTHX = PERL_GET_INTERP;
1287     } else {
1288       /* we never get here because the NULL pointer will cause the */
1289       /* several of the routines called by this routine to access violate */
1290
1291       /* This routine is only called by hv.c/hv_iterinit which has a */
1292       /* context, so the real fix may be to pass it through instead of */
1293       /* the hoops above */
1294       aTHX = NULL;
1295     }
1296 #endif
1297
1298   if (primed || !PL_envgv) return;
1299   MUTEX_LOCK(&primenv_mutex);
1300   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1301   envhv = GvHVn(PL_envgv);
1302   /* Perform a dummy fetch as an lval to insure that the hash table is
1303    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1304   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1305
1306   for (i = 0; env_tables[i]; i++) {
1307      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1308          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1309      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1310   }
1311   if (have_sym || have_lnm) {
1312     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1313     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1314     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1315     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1316   }
1317
1318   for (i--; i >= 0; i--) {
1319     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1320       char *start;
1321       int j;
1322       for (j = 0; environ[j]; j++) {
1323         if (!(start = strchr(environ[j],'='))) {
1324           if (ckWARN(WARN_INTERNAL))
1325             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1326         }
1327         else {
1328           start++;
1329           sv = newSVpv(start,0);
1330           SvTAINTED_on(sv);
1331           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1332         }
1333       }
1334       continue;
1335     }
1336     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1337              !str$case_blind_compare(&tmpdsc,&clisym)) {
1338       my_strlcpy(cmd, "Show Symbol/Global *", sizeof(cmd));
1339       cmddsc.dsc$w_length = 20;
1340       if (env_tables[i]->dsc$w_length == 12 &&
1341           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1342           !str$case_blind_compare(&tmpdsc,&local)) my_strlcpy(cmd+12, "Local  *", sizeof(cmd)-12);
1343       flags = defflags | CLI$M_NOLOGNAM;
1344     }
1345     else {
1346       my_strlcpy(cmd, "Show Logical *", sizeof(cmd));
1347       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1348         my_strlcat(cmd," /Table=", sizeof(cmd));
1349         cmddsc.dsc$w_length = my_strlcat(cmd, env_tables[i]->dsc$a_pointer, sizeof(cmd));
1350       }
1351       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1352       flags = defflags | CLI$M_NOCLISYM;
1353     }
1354
1355     /* Create a new subprocess to execute each command, to exclude the
1356      * remote possibility that someone could subvert a mbx or file used
1357      * to write multiple commands to a single subprocess.
1358      */
1359     do {
1360       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1361                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1362       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1363       defflags &= ~CLI$M_TRUSTED;
1364     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1365     _ckvmssts(retsts);
1366     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1367     if (seenhv) SvREFCNT_dec(seenhv);
1368     seenhv = newHV();
1369     while (1) {
1370       char *cp1, *cp2, *key;
1371       unsigned long int sts, iosb[2], retlen, keylen;
1372       U32 hash;
1373
1374       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1375       if (sts & 1) sts = iosb[0] & 0xffff;
1376       if (sts == SS$_ENDOFFILE) {
1377         int wakect = 0;
1378         while (substs == 0) { sys$hiber(); wakect++;}
1379         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1380         _ckvmssts(substs);
1381         break;
1382       }
1383       _ckvmssts(sts);
1384       retlen = iosb[0] >> 16;
1385       if (!retlen) continue;  /* blank line */
1386       buf[retlen] = '\0';
1387       if (iosb[1] != subpid) {
1388         if (iosb[1]) {
1389           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1390         }
1391         continue;
1392       }
1393       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1394         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1395
1396       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1397       if (*cp1 == '(' || /* Logical name table name */
1398           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1399       if (*cp1 == '"') cp1++;
1400       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1401       key = cp1;  keylen = cp2 - cp1;
1402       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1403       while (*cp2 && *cp2 != '=') cp2++;
1404       while (*cp2 && *cp2 == '=') cp2++;
1405       while (*cp2 && *cp2 == ' ') cp2++;
1406       if (*cp2 == '"') {  /* String translation; may embed "" */
1407         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1408         cp2++;  cp1--; /* Skip "" surrounding translation */
1409       }
1410       else {  /* Numeric translation */
1411         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1412         cp1--;  /* stop on last non-space char */
1413       }
1414       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1415         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1416         continue;
1417       }
1418       PERL_HASH(hash,key,keylen);
1419
1420       if (cp1 == cp2 && *cp2 == '.') {
1421         /* A single dot usually means an unprintable character, such as a null
1422          * to indicate a zero-length value.  Get the actual value to make sure.
1423          */
1424         char lnm[LNM$C_NAMLENGTH+1];
1425         char eqv[MAX_DCL_SYMBOL+1];
1426         int trnlen;
1427         strncpy(lnm, key, keylen);
1428         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1429         sv = newSVpvn(eqv, strlen(eqv));
1430       }
1431       else {
1432         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1433       }
1434
1435       SvTAINTED_on(sv);
1436       hv_store(envhv,key,keylen,sv,hash);
1437       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1438     }
1439     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1440       /* get the PPFs for this process, not the subprocess */
1441       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1442       char eqv[LNM$C_NAMLENGTH+1];
1443       int trnlen, i;
1444       for (i = 0; ppfs[i]; i++) {
1445         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1446         sv = newSVpv(eqv,trnlen);
1447         SvTAINTED_on(sv);
1448         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1449       }
1450     }
1451   }
1452   primed = 1;
1453   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1454   if (buf) Safefree(buf);
1455   if (seenhv) SvREFCNT_dec(seenhv);
1456   MUTEX_UNLOCK(&primenv_mutex);
1457   return;
1458
1459 }  /* end of prime_env_iter */
1460 /*}}}*/
1461
1462
1463 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1464 /* Define or delete an element in the same "environment" as
1465  * vmstrnenv().  If an element is to be deleted, it's removed from
1466  * the first place it's found.  If it's to be set, it's set in the
1467  * place designated by the first element of the table vector.
1468  * Like setenv() returns 0 for success, non-zero on error.
1469  */
1470 int
1471 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1472 {
1473     const char *cp1;
1474     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1475     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1476     int nseg = 0, j;
1477     unsigned long int retsts, usermode = PSL$C_USER;
1478     struct itmlst_3 *ile, *ilist;
1479     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1480                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1481                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1482     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1483     $DESCRIPTOR(local,"_LOCAL");
1484
1485     if (!lnm) {
1486         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1487         return SS$_IVLOGNAM;
1488     }
1489
1490     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1491       *cp2 = _toupper(*cp1);
1492       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1493         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1494         return SS$_IVLOGNAM;
1495       }
1496     }
1497     lnmdsc.dsc$w_length = cp1 - lnm;
1498     if (!tabvec || !*tabvec) tabvec = env_tables;
1499
1500     if (!eqv) {  /* we're deleting n element */
1501       for (curtab = 0; tabvec[curtab]; curtab++) {
1502         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1503         int i;
1504           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1505             if ((cp1 = strchr(environ[i],'=')) &&
1506                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1507                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1508               unsetenv(lnm);
1509               return 0;
1510             }
1511           }
1512           ivenv = 1; retsts = SS$_NOLOGNAM;
1513         }
1514         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1515                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1516           unsigned int symtype;
1517           if (tabvec[curtab]->dsc$w_length == 12 &&
1518               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1519               !str$case_blind_compare(&tmpdsc,&local))
1520             symtype = LIB$K_CLI_LOCAL_SYM;
1521           else symtype = LIB$K_CLI_GLOBAL_SYM;
1522           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1523           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1524           if (retsts == LIB$_NOSUCHSYM) continue;
1525           break;
1526         }
1527         else if (!ivlnm) {
1528           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1529           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1530           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1531           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1532           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1533         }
1534       }
1535     }
1536     else {  /* we're defining a value */
1537       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1538         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1539       }
1540       else {
1541         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1542         eqvdsc.dsc$w_length  = strlen(eqv);
1543         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1544             !str$case_blind_compare(&tmpdsc,&clisym)) {
1545           unsigned int symtype;
1546           if (tabvec[0]->dsc$w_length == 12 &&
1547               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1548                !str$case_blind_compare(&tmpdsc,&local))
1549             symtype = LIB$K_CLI_LOCAL_SYM;
1550           else symtype = LIB$K_CLI_GLOBAL_SYM;
1551           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1552         }
1553         else {
1554           if (!*eqv) eqvdsc.dsc$w_length = 1;
1555           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1556
1557             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1558             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1559               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1560                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1561               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1562               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1563             }
1564
1565             Newx(ilist,nseg+1,struct itmlst_3);
1566             ile = ilist;
1567             if (!ile) {
1568               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1569               return SS$_INSFMEM;
1570             }
1571             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1572
1573             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1574               ile->itmcode = LNM$_STRING;
1575               ile->bufadr = c;
1576               if ((j+1) == nseg) {
1577                 ile->buflen = strlen(c);
1578                 /* in case we are truncating one that's too long */
1579                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1580               }
1581               else {
1582                 ile->buflen = LNM$C_NAMLENGTH;
1583               }
1584             }
1585
1586             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1587             Safefree (ilist);
1588           }
1589           else {
1590             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1591           }
1592         }
1593       }
1594     }
1595     if (!(retsts & 1)) {
1596       switch (retsts) {
1597         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1598         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1599           set_errno(EVMSERR); break;
1600         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1601         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1602           set_errno(EINVAL); break;
1603         case SS$_NOPRIV:
1604           set_errno(EACCES); break;
1605         default:
1606           _ckvmssts(retsts);
1607           set_errno(EVMSERR);
1608        }
1609        set_vaxc_errno(retsts);
1610        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1611     }
1612     else {
1613       /* We reset error values on success because Perl does an hv_fetch()
1614        * before each hv_store(), and if the thing we're setting didn't
1615        * previously exist, we've got a leftover error message.  (Of course,
1616        * this fails in the face of
1617        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1618        * in that the error reported in $! isn't spurious,
1619        * but it's right more often than not.)
1620        */
1621       set_errno(0); set_vaxc_errno(retsts);
1622       return 0;
1623     }
1624
1625 }  /* end of vmssetenv() */
1626 /*}}}*/
1627
1628 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1629 /* This has to be a function since there's a prototype for it in proto.h */
1630 void
1631 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1632 {
1633     if (lnm && *lnm) {
1634       int len = strlen(lnm);
1635       if  (len == 7) {
1636         char uplnm[8];
1637         int i;
1638         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1639         if (!strcmp(uplnm,"DEFAULT")) {
1640           if (eqv && *eqv) my_chdir(eqv);
1641           return;
1642         }
1643     }
1644   }
1645   (void) vmssetenv(lnm,eqv,NULL);
1646 }
1647 /*}}}*/
1648
1649 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1650 /*  vmssetuserlnm
1651  *  sets a user-mode logical in the process logical name table
1652  *  used for redirection of sys$error
1653  */
1654 void
1655 Perl_vmssetuserlnm(const char *name, const char *eqv)
1656 {
1657     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1658     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1659     unsigned long int iss, attr = LNM$M_CONFINE;
1660     unsigned char acmode = PSL$C_USER;
1661     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1662                                  {0, 0, 0, 0}};
1663     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1664     d_name.dsc$w_length = strlen(name);
1665
1666     lnmlst[0].buflen = strlen(eqv);
1667     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1668
1669     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1670     if (!(iss&1)) lib$signal(iss);
1671 }
1672 /*}}}*/
1673
1674
1675 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1676 /* my_crypt - VMS password hashing
1677  * my_crypt() provides an interface compatible with the Unix crypt()
1678  * C library function, and uses sys$hash_password() to perform VMS
1679  * password hashing.  The quadword hashed password value is returned
1680  * as a NUL-terminated 8 character string.  my_crypt() does not change
1681  * the case of its string arguments; in order to match the behavior
1682  * of LOGINOUT et al., alphabetic characters in both arguments must
1683  *  be upcased by the caller.
1684  *
1685  * - fix me to call ACM services when available
1686  */
1687 char *
1688 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1689 {
1690 #   ifndef UAI$C_PREFERRED_ALGORITHM
1691 #     define UAI$C_PREFERRED_ALGORITHM 127
1692 #   endif
1693     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1694     unsigned short int salt = 0;
1695     unsigned long int sts;
1696     struct const_dsc {
1697         unsigned short int dsc$w_length;
1698         unsigned char      dsc$b_type;
1699         unsigned char      dsc$b_class;
1700         const char *       dsc$a_pointer;
1701     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1702        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1703     struct itmlst_3 uailst[3] = {
1704         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1705         { sizeof salt, UAI$_SALT,    &salt, 0},
1706         { 0,           0,            NULL,  NULL}};
1707     static char hash[9];
1708
1709     usrdsc.dsc$w_length = strlen(usrname);
1710     usrdsc.dsc$a_pointer = usrname;
1711     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1712       switch (sts) {
1713         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1714           set_errno(EACCES);
1715           break;
1716         case RMS$_RNF:
1717           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1718           break;
1719         default:
1720           set_errno(EVMSERR);
1721       }
1722       set_vaxc_errno(sts);
1723       if (sts != RMS$_RNF) return NULL;
1724     }
1725
1726     txtdsc.dsc$w_length = strlen(textpasswd);
1727     txtdsc.dsc$a_pointer = textpasswd;
1728     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1729       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1730     }
1731
1732     return (char *) hash;
1733
1734 }  /* end of my_crypt() */
1735 /*}}}*/
1736
1737
1738 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1739 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1740 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1741
1742 /* 8.3, remove() is now broken on symbolic links */
1743 static int rms_erase(const char * vmsname);
1744
1745
1746 /* mp_do_kill_file
1747  * A little hack to get around a bug in some implementation of remove()
1748  * that do not know how to delete a directory
1749  *
1750  * Delete any file to which user has control access, regardless of whether
1751  * delete access is explicitly allowed.
1752  * Limitations: User must have write access to parent directory.
1753  *              Does not block signals or ASTs; if interrupted in midstream
1754  *              may leave file with an altered ACL.
1755  * HANDLE WITH CARE!
1756  */
1757 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1758 static int
1759 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1760 {
1761     char *vmsname;
1762     char *rslt;
1763     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1764     unsigned long int cxt = 0, aclsts, fndsts;
1765     int rmsts = -1;
1766     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1767     struct myacedef {
1768       unsigned char myace$b_length;
1769       unsigned char myace$b_type;
1770       unsigned short int myace$w_flags;
1771       unsigned long int myace$l_access;
1772       unsigned long int myace$l_ident;
1773     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1774                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1775       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1776      struct itmlst_3
1777        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1778                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1779        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1780        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1781        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1782        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1783
1784     /* Expand the input spec using RMS, since the CRTL remove() and
1785      * system services won't do this by themselves, so we may miss
1786      * a file "hiding" behind a logical name or search list. */
1787     vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
1788     if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1789
1790     rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
1791     if (rslt == NULL) {
1792         PerlMem_free(vmsname);
1793         return -1;
1794       }
1795
1796     /* Erase the file */
1797     rmsts = rms_erase(vmsname);
1798
1799     /* Did it succeed */
1800     if ($VMS_STATUS_SUCCESS(rmsts)) {
1801         PerlMem_free(vmsname);
1802         return 0;
1803       }
1804
1805     /* If not, can changing protections help? */
1806     if (rmsts != RMS$_PRV) {
1807       set_vaxc_errno(rmsts);
1808       PerlMem_free(vmsname);
1809       return -1;
1810     }
1811
1812     /* No, so we get our own UIC to use as a rights identifier,
1813      * and the insert an ACE at the head of the ACL which allows us
1814      * to delete the file.
1815      */
1816     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1817     fildsc.dsc$w_length = strlen(vmsname);
1818     fildsc.dsc$a_pointer = vmsname;
1819     cxt = 0;
1820     newace.myace$l_ident = oldace.myace$l_ident;
1821     rmsts = -1;
1822     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1823       switch (aclsts) {
1824         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1825           set_errno(ENOENT); break;
1826         case RMS$_DIR:
1827           set_errno(ENOTDIR); break;
1828         case RMS$_DEV:
1829           set_errno(ENODEV); break;
1830         case RMS$_SYN: case SS$_INVFILFOROP:
1831           set_errno(EINVAL); break;
1832         case RMS$_PRV:
1833           set_errno(EACCES); break;
1834         default:
1835           _ckvmssts_noperl(aclsts);
1836       }
1837       set_vaxc_errno(aclsts);
1838       PerlMem_free(vmsname);
1839       return -1;
1840     }
1841     /* Grab any existing ACEs with this identifier in case we fail */
1842     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1843     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1844                     || fndsts == SS$_NOMOREACE ) {
1845       /* Add the new ACE . . . */
1846       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1847         goto yourroom;
1848
1849       rmsts = rms_erase(vmsname);
1850       if ($VMS_STATUS_SUCCESS(rmsts)) {
1851         rmsts = 0;
1852         }
1853         else {
1854         rmsts = -1;
1855         /* We blew it - dir with files in it, no write priv for
1856          * parent directory, etc.  Put things back the way they were. */
1857         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1858           goto yourroom;
1859         if (fndsts & 1) {
1860           addlst[0].bufadr = &oldace;
1861           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1862             goto yourroom;
1863         }
1864       }
1865     }
1866
1867     yourroom:
1868     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1869     /* We just deleted it, so of course it's not there.  Some versions of
1870      * VMS seem to return success on the unlock operation anyhow (after all
1871      * the unlock is successful), but others don't.
1872      */
1873     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1874     if (aclsts & 1) aclsts = fndsts;
1875     if (!(aclsts & 1)) {
1876       set_errno(EVMSERR);
1877       set_vaxc_errno(aclsts);
1878     }
1879
1880     PerlMem_free(vmsname);
1881     return rmsts;
1882
1883 }  /* end of kill_file() */
1884 /*}}}*/
1885
1886
1887 /*{{{int do_rmdir(char *name)*/
1888 int
1889 Perl_do_rmdir(pTHX_ const char *name)
1890 {
1891     char * dirfile;
1892     int retval;
1893     Stat_t st;
1894
1895     /* lstat returns a VMS fileified specification of the name */
1896     /* that is looked up, and also lets verifies that this is a directory */
1897
1898     retval = flex_lstat(name, &st);
1899     if (retval != 0) {
1900         char * ret_spec;
1901
1902         /* Due to a historical feature, flex_stat/lstat can not see some */
1903         /* Unix format file names that the rest of the CRTL can see */
1904         /* Fixing that feature will cause some perl tests to fail */
1905         /* So try this one more time. */
1906
1907         retval = lstat(name, &st.crtl_stat);
1908         if (retval != 0)
1909             return -1;
1910
1911         /* force it to a file spec for the kill file to work. */
1912         ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
1913         if (ret_spec == NULL) {
1914             errno = EIO;
1915             return -1;
1916         }
1917     }
1918
1919     if (!S_ISDIR(st.st_mode)) {
1920         errno = ENOTDIR;
1921         retval = -1;
1922     }
1923     else {
1924         dirfile = st.st_devnam;
1925
1926         /* It may be possible for flex_stat to find a file and vmsify() to */
1927         /* fail with ODS-2 specifications.  mp_do_kill_file can not deal */
1928         /* with that case, so fail it */
1929         if (dirfile[0] == 0) {
1930             errno = EIO;
1931             return -1;
1932         }
1933
1934         retval = mp_do_kill_file(aTHX_ dirfile, 1);
1935     }
1936
1937     return retval;
1938
1939 }  /* end of do_rmdir */
1940 /*}}}*/
1941
1942 /* kill_file
1943  * Delete any file to which user has control access, regardless of whether
1944  * delete access is explicitly allowed.
1945  * Limitations: User must have write access to parent directory.
1946  *              Does not block signals or ASTs; if interrupted in midstream
1947  *              may leave file with an altered ACL.
1948  * HANDLE WITH CARE!
1949  */
1950 /*{{{int kill_file(char *name)*/
1951 int
1952 Perl_kill_file(pTHX_ const char *name)
1953 {
1954     char * vmsfile;
1955     Stat_t st;
1956     int rmsts;
1957
1958     /* Convert the filename to VMS format and see if it is a directory */
1959     /* flex_lstat returns a vmsified file specification */
1960     rmsts = flex_lstat(name, &st);
1961     if (rmsts != 0) {
1962
1963         /* Due to a historical feature, flex_stat/lstat can not see some */
1964         /* Unix format file names that the rest of the CRTL can see when */
1965         /* ODS-2 file specifications are in use. */
1966         /* Fixing that feature will cause some perl tests to fail */
1967         /* [.lib.ExtUtils.t]Manifest.t is one of them */
1968         st.st_mode = 0;
1969         vmsfile = (char *) name; /* cast ok */
1970
1971     } else {
1972         vmsfile = st.st_devnam;
1973         if (vmsfile[0] == 0) {
1974             /* It may be possible for flex_stat to find a file and vmsify() */
1975             /* to fail with ODS-2 specifications.  mp_do_kill_file can not */
1976             /* deal with that case, so fail it */
1977             errno = EIO;
1978             return -1;
1979         }
1980     }
1981
1982     /* Remove() is allowed to delete directories, according to the X/Open
1983      * specifications.
1984      * This may need special handling to work with the ACL hacks.
1985      */
1986     if (S_ISDIR(st.st_mode)) {
1987         rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
1988         return rmsts;
1989     }
1990
1991     rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
1992
1993     /* Need to delete all versions ? */
1994     if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
1995         int i = 0;
1996
1997         /* Just use lstat() here as do not need st_dev */
1998         /* and we know that the file is in VMS format or that */
1999         /* because of a historical bug, flex_stat can not see the file */
2000         while (lstat(vmsfile, (stat_t *)&st) == 0) {
2001             rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2002             if (rmsts != 0)
2003                 break;
2004             i++;
2005
2006             /* Make sure that we do not loop forever */
2007             if (i > 32767) {
2008                 errno = EIO;
2009                 rmsts = -1;
2010                 break;
2011             }
2012         }
2013     }
2014
2015     return rmsts;
2016
2017 }  /* end of kill_file() */
2018 /*}}}*/
2019
2020
2021 /*{{{int my_mkdir(char *,Mode_t)*/
2022 int
2023 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2024 {
2025   STRLEN dirlen = strlen(dir);
2026
2027   /* zero length string sometimes gives ACCVIO */
2028   if (dirlen == 0) return -1;
2029
2030   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2031    * null file name/type.  However, it's commonplace under Unix,
2032    * so we'll allow it for a gain in portability.
2033    */
2034   if (dir[dirlen-1] == '/') {
2035     char *newdir = savepvn(dir,dirlen-1);
2036     int ret = mkdir(newdir,mode);
2037     Safefree(newdir);
2038     return ret;
2039   }
2040   else return mkdir(dir,mode);
2041 }  /* end of my_mkdir */
2042 /*}}}*/
2043
2044 /*{{{int my_chdir(char *)*/
2045 int
2046 Perl_my_chdir(pTHX_ const char *dir)
2047 {
2048   STRLEN dirlen = strlen(dir);
2049   const char *dir1 = dir;
2050
2051   /* POSIX says we should set ENOENT for zero length string. */
2052   if (dirlen == 0) {
2053     SETERRNO(ENOENT, RMS$_DNF);
2054     return -1;
2055   }
2056
2057   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2058    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2059    * so that existing scripts do not need to be changed.
2060    */
2061   while ((dirlen > 0) && (*dir1 == ' ')) {
2062     dir1++;
2063     dirlen--;
2064   }
2065
2066   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2067    * that implies
2068    * null file name/type.  However, it's commonplace under Unix,
2069    * so we'll allow it for a gain in portability.
2070    *
2071    *  '/' is valid when SYS$POSIX_ROOT or POSIX compliant pathnames are active.
2072    */
2073   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2074       char *newdir;
2075       int ret;
2076       newdir = (char *)PerlMem_malloc(dirlen);
2077       if (newdir ==NULL)
2078           _ckvmssts_noperl(SS$_INSFMEM);
2079       memcpy(newdir, dir1, dirlen-1);
2080       newdir[dirlen-1] = '\0';
2081       ret = chdir(newdir);
2082       PerlMem_free(newdir);
2083       return ret;
2084   }
2085   else return chdir(dir1);
2086 }  /* end of my_chdir */
2087 /*}}}*/
2088
2089
2090 /*{{{int my_chmod(char *, mode_t)*/
2091 int
2092 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2093 {
2094   Stat_t st;
2095   int ret = -1;
2096   char * changefile;
2097   STRLEN speclen = strlen(file_spec);
2098
2099   /* zero length string sometimes gives ACCVIO */
2100   if (speclen == 0) return -1;
2101
2102   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2103    * that implies null file name/type.  However, it's commonplace under Unix,
2104    * so we'll allow it for a gain in portability.
2105    *
2106    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2107    * in VMS file.dir notation.
2108    */
2109   changefile = (char *) file_spec; /* cast ok */
2110   ret = flex_lstat(file_spec, &st);
2111   if (ret != 0) {
2112
2113         /* Due to a historical feature, flex_stat/lstat can not see some */
2114         /* Unix format file names that the rest of the CRTL can see when */
2115         /* ODS-2 file specifications are in use. */
2116         /* Fixing that feature will cause some perl tests to fail */
2117         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2118         st.st_mode = 0;
2119
2120   } else {
2121       /* It may be possible to get here with nothing in st_devname */
2122       /* chmod still may work though */
2123       if (st.st_devnam[0] != 0) {
2124           changefile = st.st_devnam;
2125       }
2126   }
2127   ret = chmod(changefile, mode);
2128   return ret;
2129 }  /* end of my_chmod */
2130 /*}}}*/
2131
2132
2133 /*{{{FILE *my_tmpfile()*/
2134 FILE *
2135 my_tmpfile(void)
2136 {
2137   FILE *fp;
2138   char *cp;
2139
2140   if ((fp = tmpfile())) return fp;
2141
2142   cp = (char *)PerlMem_malloc(L_tmpnam+24);
2143   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2144
2145   if (decc_filename_unix_only == 0)
2146     strcpy(cp,"Sys$Scratch:");
2147   else
2148     strcpy(cp,"/tmp/");
2149   tmpnam(cp+strlen(cp));
2150   strcat(cp,".Perltmp");
2151   fp = fopen(cp,"w+","fop=dlt");
2152   PerlMem_free(cp);
2153   return fp;
2154 }
2155 /*}}}*/
2156
2157
2158 /*
2159  * The C RTL's sigaction fails to check for invalid signal numbers so we
2160  * help it out a bit.  The docs are correct, but the actual routine doesn't
2161  * do what the docs say it will.
2162  */
2163 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2164 int
2165 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2166                    struct sigaction* oact)
2167 {
2168   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2169         SETERRNO(EINVAL, SS$_INVARG);
2170         return -1;
2171   }
2172   return sigaction(sig, act, oact);
2173 }
2174 /*}}}*/
2175
2176 #include <errnodef.h>
2177
2178 /* We implement our own kill() using the undocumented system service
2179    sys$sigprc for one of two reasons:
2180
2181    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2182    target process to do a sys$exit, which usually can't be handled
2183    gracefully...certainly not by Perl and the %SIG{} mechanism.
2184
2185    2.) If the kill() in the CRTL can't be called from a signal
2186    handler without disappearing into the ether, i.e., the signal
2187    it purportedly sends is never trapped. Still true as of VMS 7.3.
2188
2189    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2190    in the target process rather than calling sys$exit.
2191
2192    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2193    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2194    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2195    with condition codes C$_SIG0+nsig*8, catching the exception on the
2196    target process and resignaling with appropriate arguments.
2197
2198    But we don't have that VMS 7.0+ exception handler, so if you
2199    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2200
2201    Also note that SIGTERM is listed in the docs as being "unimplemented",
2202    yet always seems to be signaled with a VMS condition code of 4 (and
2203    correctly handled for that code).  So we hardwire it in.
2204
2205    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2206    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2207    than signalling with an unrecognized (and unhandled by CRTL) code.
2208 */
2209
2210 #define _MY_SIG_MAX 28
2211
2212 static unsigned int
2213 Perl_sig_to_vmscondition_int(int sig)
2214 {
2215     static unsigned int sig_code[_MY_SIG_MAX+1] =
2216     {
2217         0,                  /*  0 ZERO     */
2218         SS$_HANGUP,         /*  1 SIGHUP   */
2219         SS$_CONTROLC,       /*  2 SIGINT   */
2220         SS$_CONTROLY,       /*  3 SIGQUIT  */
2221         SS$_RADRMOD,        /*  4 SIGILL   */
2222         SS$_BREAK,          /*  5 SIGTRAP  */
2223         SS$_OPCCUS,         /*  6 SIGABRT  */
2224         SS$_COMPAT,         /*  7 SIGEMT   */
2225         SS$_HPARITH,        /*  8 SIGFPE AXP */
2226         SS$_ABORT,          /*  9 SIGKILL  */
2227         SS$_ACCVIO,         /* 10 SIGBUS   */
2228         SS$_ACCVIO,         /* 11 SIGSEGV  */
2229         SS$_BADPARAM,       /* 12 SIGSYS   */
2230         SS$_NOMBX,          /* 13 SIGPIPE  */
2231         SS$_ASTFLT,         /* 14 SIGALRM  */
2232         4,                  /* 15 SIGTERM  */
2233         0,                  /* 16 SIGUSR1  */
2234         0,                  /* 17 SIGUSR2  */
2235         0,                  /* 18 */
2236         0,                  /* 19 */
2237         0,                  /* 20 SIGCHLD  */
2238         0,                  /* 21 SIGCONT  */
2239         0,                  /* 22 SIGSTOP  */
2240         0,                  /* 23 SIGTSTP  */
2241         0,                  /* 24 SIGTTIN  */
2242         0,                  /* 25 SIGTTOU  */
2243         0,                  /* 26 */
2244         0,                  /* 27 */
2245         0                   /* 28 SIGWINCH  */
2246     };
2247
2248     static int initted = 0;
2249     if (!initted) {
2250         initted = 1;
2251         sig_code[16] = C$_SIGUSR1;
2252         sig_code[17] = C$_SIGUSR2;
2253         sig_code[20] = C$_SIGCHLD;
2254         sig_code[28] = C$_SIGWINCH;
2255     }
2256
2257     if (sig < _SIG_MIN) return 0;
2258     if (sig > _MY_SIG_MAX) return 0;
2259     return sig_code[sig];
2260 }
2261
2262 unsigned int
2263 Perl_sig_to_vmscondition(int sig)
2264 {
2265 #ifdef SS$_DEBUG
2266     if (vms_debug_on_exception != 0)
2267         lib$signal(SS$_DEBUG);
2268 #endif
2269     return Perl_sig_to_vmscondition_int(sig);
2270 }
2271
2272
2273 #ifdef KILL_BY_SIGPRC
2274 #define sys$sigprc SYS$SIGPRC
2275 #ifdef __cplusplus
2276 extern "C" {
2277 #endif
2278 int sys$sigprc(unsigned int *pidadr,
2279                struct dsc$descriptor_s *prcname,
2280                unsigned int code);
2281 #ifdef __cplusplus
2282 }
2283 #endif
2284
2285 int
2286 Perl_my_kill(int pid, int sig)
2287 {
2288     int iss;
2289     unsigned int code;
2290
2291      /* sig 0 means validate the PID */
2292     /*------------------------------*/
2293     if (sig == 0) {
2294         const unsigned long int jpicode = JPI$_PID;
2295         pid_t ret_pid;
2296         int status;
2297         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2298         if ($VMS_STATUS_SUCCESS(status))
2299            return 0;
2300         switch (status) {
2301         case SS$_NOSUCHNODE:
2302         case SS$_UNREACHABLE:
2303         case SS$_NONEXPR:
2304            errno = ESRCH;
2305            break;
2306         case SS$_NOPRIV:
2307            errno = EPERM;
2308            break;
2309         default:
2310            errno = EVMSERR;
2311         }
2312         vaxc$errno=status;
2313         return -1;
2314     }
2315
2316     code = Perl_sig_to_vmscondition_int(sig);
2317
2318     if (!code) {
2319         SETERRNO(EINVAL, SS$_BADPARAM);
2320         return -1;
2321     }
2322
2323     /* Per official UNIX specification: If pid = 0, or negative then
2324      * signals are to be sent to multiple processes.
2325      *  pid = 0 - all processes in group except ones that the system exempts
2326      *  pid = -1 - all processes except ones that the system exempts
2327      *  pid = -n - all processes in group (abs(n)) except ...
2328      *
2329      * Handle these via killpg, which is redundant for the -n case, since OP_KILL
2330      * in doio.c already does that. killpg currently does not support the -1 case.
2331      */
2332
2333     if (pid <= 0) {
2334         return killpg(-pid, sig);
2335     }
2336
2337     iss = sys$sigprc((unsigned int *)&pid,0,code);
2338     if (iss&1) return 0;
2339
2340     switch (iss) {
2341       case SS$_NOPRIV:
2342         set_errno(EPERM);  break;
2343       case SS$_NONEXPR:
2344       case SS$_NOSUCHNODE:
2345       case SS$_UNREACHABLE:
2346         set_errno(ESRCH);  break;
2347       case SS$_INSFMEM:
2348         set_errno(ENOMEM); break;
2349       default:
2350         _ckvmssts_noperl(iss);
2351         set_errno(EVMSERR);
2352     }
2353     set_vaxc_errno(iss);
2354
2355     return -1;
2356 }
2357 #endif
2358
2359 int
2360 Perl_my_killpg(pid_t master_pid, int signum)
2361 {
2362     int pid, status, i;
2363     unsigned long int jpi_context;
2364     unsigned short int iosb[4];
2365     struct itmlst_3  il3[3];
2366
2367     /* All processes on the system?  Seems dangerous, but it looks
2368      * like we could implement this pretty easily with a wildcard
2369      * input to sys$process_scan.
2370      */
2371     if (master_pid == -1) {
2372         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2373         return -1;
2374     }
2375
2376     /* All processes in the current process group; find the master
2377      * pid for the current process.
2378      */
2379     if (master_pid == 0) {
2380         i = 0;
2381         il3[i].buflen   = sizeof( int );
2382         il3[i].itmcode   = JPI$_MASTER_PID;
2383         il3[i].bufadr   = &master_pid;
2384         il3[i++].retlen = NULL;
2385
2386         il3[i].buflen   = 0;
2387         il3[i].itmcode   = 0;
2388         il3[i].bufadr   = NULL;
2389         il3[i++].retlen = NULL;
2390
2391         status = sys$getjpiw(EFN$C_ENF, NULL, NULL, il3, iosb, NULL, 0);
2392         if ($VMS_STATUS_SUCCESS(status))
2393             status = iosb[0];
2394
2395         switch (status) {
2396             case SS$_NORMAL:
2397                 break;
2398             case SS$_NOPRIV:
2399             case SS$_SUSPENDED:
2400                 SETERRNO(EPERM, status);
2401                 break;
2402             case SS$_NOMOREPROC:
2403             case SS$_NONEXPR:
2404             case SS$_NOSUCHNODE:
2405             case SS$_UNREACHABLE:
2406                 SETERRNO(ESRCH, status);
2407                 break;
2408             case SS$_ACCVIO:
2409             case SS$_BADPARAM:
2410                 SETERRNO(EINVAL, status);
2411                 break;
2412             default:
2413                 SETERRNO(EVMSERR, status);
2414         }
2415         if (!$VMS_STATUS_SUCCESS(status))
2416             return -1;
2417     }
2418
2419     /* Set up a process context for those processes we will scan
2420      * with sys$getjpiw.  Ask for all processes belonging to the
2421      * master pid.
2422      */
2423
2424     i = 0;
2425     il3[i].buflen   = 0;
2426     il3[i].itmcode   = PSCAN$_MASTER_PID;
2427     il3[i].bufadr   = (void *)master_pid;
2428     il3[i++].retlen = NULL;
2429
2430     il3[i].buflen   = 0;
2431     il3[i].itmcode   = 0;
2432     il3[i].bufadr   = NULL;
2433     il3[i++].retlen = NULL;
2434
2435     status = sys$process_scan(&jpi_context, il3);
2436     switch (status) {
2437         case SS$_NORMAL:
2438             break;
2439         case SS$_ACCVIO:
2440         case SS$_BADPARAM:
2441         case SS$_IVBUFLEN:
2442         case SS$_IVSSRQ:
2443             SETERRNO(EINVAL, status);
2444             break;
2445         default:
2446             SETERRNO(EVMSERR, status);
2447     }
2448     if (!$VMS_STATUS_SUCCESS(status))
2449         return -1;
2450
2451     i = 0;
2452     il3[i].buflen   = sizeof(int);
2453     il3[i].itmcode  = JPI$_PID;
2454     il3[i].bufadr   = &pid;
2455     il3[i++].retlen = NULL;
2456
2457     il3[i].buflen   = 0;
2458     il3[i].itmcode  = 0;
2459     il3[i].bufadr   = NULL;
2460     il3[i++].retlen = NULL;
2461
2462     /* Loop through the processes matching our specified criteria
2463      */
2464
2465     while (1) {
2466         /* Find the next process...
2467          */
2468         status = sys$getjpiw( EFN$C_ENF, &jpi_context, NULL, il3, iosb, NULL, 0);
2469         if ($VMS_STATUS_SUCCESS(status)) status = iosb[0];
2470
2471         switch (status) {
2472             case SS$_NORMAL:
2473                 if (kill(pid, signum) == -1)
2474                     break;
2475
2476                 continue;     /* next process */
2477             case SS$_NOPRIV:
2478             case SS$_SUSPENDED:
2479                 SETERRNO(EPERM, status);
2480                 break;
2481             case SS$_NOMOREPROC:
2482                 break;
2483             case SS$_NONEXPR:
2484             case SS$_NOSUCHNODE:
2485             case SS$_UNREACHABLE:
2486                 SETERRNO(ESRCH, status);
2487                 break;
2488             case SS$_ACCVIO:
2489             case SS$_BADPARAM:
2490                 SETERRNO(EINVAL, status);
2491                 break;
2492             default:
2493                SETERRNO(EVMSERR, status);
2494         }
2495
2496         if (!$VMS_STATUS_SUCCESS(status))
2497             break;
2498     }
2499
2500     /* Release context-related resources.
2501      */
2502     (void) sys$process_scan(&jpi_context);
2503
2504     if (status != SS$_NOMOREPROC)
2505         return -1;
2506
2507     return 0;
2508 }
2509
2510 /* Routine to convert a VMS status code to a UNIX status code.
2511 ** More tricky than it appears because of conflicting conventions with
2512 ** existing code.
2513 **
2514 ** VMS status codes are a bit mask, with the least significant bit set for
2515 ** success.
2516 **
2517 ** Special UNIX status of EVMSERR indicates that no translation is currently
2518 ** available, and programs should check the VMS status code.
2519 **
2520 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2521 ** decoding.
2522 */
2523
2524 #ifndef C_FACILITY_NO
2525 #define C_FACILITY_NO 0x350000
2526 #endif
2527 #ifndef DCL_IVVERB
2528 #define DCL_IVVERB 0x38090
2529 #endif
2530
2531 int
2532 Perl_vms_status_to_unix(int vms_status, int child_flag)
2533 {
2534   int facility;
2535   int fac_sp;
2536   int msg_no;
2537   int msg_status;
2538   int unix_status;
2539
2540   /* Assume the best or the worst */
2541   if (vms_status & STS$M_SUCCESS)
2542     unix_status = 0;
2543   else
2544     unix_status = EVMSERR;
2545
2546   msg_status = vms_status & ~STS$M_CONTROL;
2547
2548   facility = vms_status & STS$M_FAC_NO;
2549   fac_sp = vms_status & STS$M_FAC_SP;
2550   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2551
2552   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2553     switch(msg_no) {
2554     case SS$_NORMAL:
2555         unix_status = 0;
2556         break;
2557     case SS$_ACCVIO:
2558         unix_status = EFAULT;
2559         break;
2560     case SS$_DEVOFFLINE:
2561         unix_status = EBUSY;
2562         break;
2563     case SS$_CLEARED:
2564         unix_status = ENOTCONN;
2565         break;
2566     case SS$_IVCHAN:
2567     case SS$_IVLOGNAM:
2568     case SS$_BADPARAM:
2569     case SS$_IVLOGTAB:
2570     case SS$_NOLOGNAM:
2571     case SS$_NOLOGTAB:
2572     case SS$_INVFILFOROP:
2573     case SS$_INVARG:
2574     case SS$_NOSUCHID:
2575     case SS$_IVIDENT:
2576         unix_status = EINVAL;
2577         break;
2578     case SS$_UNSUPPORTED:
2579         unix_status = ENOTSUP;
2580         break;
2581     case SS$_FILACCERR:
2582     case SS$_NOGRPPRV:
2583     case SS$_NOSYSPRV:
2584         unix_status = EACCES;
2585         break;
2586     case SS$_DEVICEFULL:
2587         unix_status = ENOSPC;
2588         break;
2589     case SS$_NOSUCHDEV:
2590         unix_status = ENODEV;
2591         break;
2592     case SS$_NOSUCHFILE:
2593     case SS$_NOSUCHOBJECT:
2594         unix_status = ENOENT;
2595         break;
2596     case SS$_ABORT:                                 /* Fatal case */
2597     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2598     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2599         unix_status = EINTR;
2600         break;
2601     case SS$_BUFFEROVF:
2602         unix_status = E2BIG;
2603         break;
2604     case SS$_INSFMEM:
2605         unix_status = ENOMEM;
2606         break;
2607     case SS$_NOPRIV:
2608         unix_status = EPERM;
2609         break;
2610     case SS$_NOSUCHNODE:
2611     case SS$_UNREACHABLE:
2612         unix_status = ESRCH;
2613         break;
2614     case SS$_NONEXPR:
2615         unix_status = ECHILD;
2616         break;
2617     default:
2618         if ((facility == 0) && (msg_no < 8)) {
2619           /* These are not real VMS status codes so assume that they are
2620           ** already UNIX status codes
2621           */
2622           unix_status = msg_no;
2623           break;
2624         }
2625     }
2626   }
2627   else {
2628     /* Translate a POSIX exit code to a UNIX exit code */
2629     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2630         unix_status = (msg_no & 0x07F8) >> 3;
2631     }
2632     else {
2633
2634          /* Documented traditional behavior for handling VMS child exits */
2635         /*--------------------------------------------------------------*/
2636         if (child_flag != 0) {
2637
2638              /* Success / Informational return 0 */
2639             /*----------------------------------*/
2640             if (msg_no & STS$K_SUCCESS)
2641                 return 0;
2642
2643              /* Warning returns 1 */
2644             /*-------------------*/
2645             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2646                 return 1;
2647
2648              /* Everything else pass through the severity bits */
2649             /*------------------------------------------------*/
2650             return (msg_no & STS$M_SEVERITY);
2651         }
2652
2653          /* Normal VMS status to ERRNO mapping attempt */
2654         /*--------------------------------------------*/
2655         switch(msg_status) {
2656         /* case RMS$_EOF: */ /* End of File */
2657         case RMS$_FNF:  /* File Not Found */
2658         case RMS$_DNF:  /* Dir Not Found */
2659                 unix_status = ENOENT;
2660                 break;
2661         case RMS$_RNF:  /* Record Not Found */
2662                 unix_status = ESRCH;
2663                 break;
2664         case RMS$_DIR:
2665                 unix_status = ENOTDIR;
2666                 break;
2667         case RMS$_DEV:
2668                 unix_status = ENODEV;
2669                 break;
2670         case RMS$_IFI:
2671         case RMS$_FAC:
2672         case RMS$_ISI:
2673                 unix_status = EBADF;
2674                 break;
2675         case RMS$_FEX:
2676                 unix_status = EEXIST;
2677                 break;
2678         case RMS$_SYN:
2679         case RMS$_FNM:
2680         case LIB$_INVSTRDES:
2681         case LIB$_INVARG:
2682         case LIB$_NOSUCHSYM:
2683         case LIB$_INVSYMNAM:
2684         case DCL_IVVERB:
2685                 unix_status = EINVAL;
2686                 break;
2687         case CLI$_BUFOVF:
2688         case RMS$_RTB:
2689         case CLI$_TKNOVF:
2690         case CLI$_RSLOVF:
2691                 unix_status = E2BIG;
2692                 break;
2693         case RMS$_PRV:  /* No privilege */
2694         case RMS$_ACC:  /* ACP file access failed */
2695         case RMS$_WLK:  /* Device write locked */
2696                 unix_status = EACCES;
2697                 break;
2698         case RMS$_MKD:  /* Failed to mark for delete */
2699                 unix_status = EPERM;
2700                 break;
2701         /* case RMS$_NMF: */  /* No more files */
2702         }
2703     }
2704   }
2705
2706   return unix_status;
2707 }
2708
2709 /* Try to guess at what VMS error status should go with a UNIX errno
2710  * value.  This is hard to do as there could be many possible VMS
2711  * error statuses that caused the errno value to be set.
2712  */
2713
2714 int
2715 Perl_unix_status_to_vms(int unix_status)
2716 {
2717     int test_unix_status;
2718
2719      /* Trivial cases first */
2720     /*---------------------*/
2721     if (unix_status == EVMSERR)
2722         return vaxc$errno;
2723
2724      /* Is vaxc$errno sane? */
2725     /*---------------------*/
2726     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2727     if (test_unix_status == unix_status)
2728         return vaxc$errno;
2729
2730      /* If way out of range, must be VMS code already */
2731     /*-----------------------------------------------*/
2732     if (unix_status > EVMSERR)
2733         return unix_status;
2734
2735      /* If out of range, punt */
2736     /*-----------------------*/
2737     if (unix_status > __ERRNO_MAX)
2738         return SS$_ABORT;
2739
2740
2741      /* Ok, now we have to do it the hard way. */
2742     /*----------------------------------------*/
2743     switch(unix_status) {
2744     case 0:     return SS$_NORMAL;
2745     case EPERM: return SS$_NOPRIV;
2746     case ENOENT: return SS$_NOSUCHOBJECT;
2747     case ESRCH: return SS$_UNREACHABLE;
2748     case EINTR: return SS$_ABORT;
2749     /* case EIO: */
2750     /* case ENXIO:  */
2751     case E2BIG: return SS$_BUFFEROVF;
2752     /* case ENOEXEC */
2753     case EBADF: return RMS$_IFI;
2754     case ECHILD: return SS$_NONEXPR;
2755     /* case EAGAIN */
2756     case ENOMEM: return SS$_INSFMEM;
2757     case EACCES: return SS$_FILACCERR;
2758     case EFAULT: return SS$_ACCVIO;
2759     /* case ENOTBLK */
2760     case EBUSY: return SS$_DEVOFFLINE;
2761     case EEXIST: return RMS$_FEX;
2762     /* case EXDEV */
2763     case ENODEV: return SS$_NOSUCHDEV;
2764     case ENOTDIR: return RMS$_DIR;
2765     /* case EISDIR */
2766     case EINVAL: return SS$_INVARG;
2767     /* case ENFILE */
2768     /* case EMFILE */
2769     /* case ENOTTY */
2770     /* case ETXTBSY */
2771     /* case EFBIG */
2772     case ENOSPC: return SS$_DEVICEFULL;
2773     case ESPIPE: return LIB$_INVARG;
2774     /* case EROFS: */
2775     /* case EMLINK: */
2776     /* case EPIPE: */
2777     /* case EDOM */
2778     case ERANGE: return LIB$_INVARG;
2779     /* case EWOULDBLOCK */
2780     /* case EINPROGRESS */
2781     /* case EALREADY */
2782     /* case ENOTSOCK */
2783     /* case EDESTADDRREQ */
2784     /* case EMSGSIZE */
2785     /* case EPROTOTYPE */
2786     /* case ENOPROTOOPT */
2787     /* case EPROTONOSUPPORT */
2788     /* case ESOCKTNOSUPPORT */
2789     /* case EOPNOTSUPP */
2790     /* case EPFNOSUPPORT */
2791     /* case EAFNOSUPPORT */
2792     /* case EADDRINUSE */
2793     /* case EADDRNOTAVAIL */
2794     /* case ENETDOWN */
2795     /* case ENETUNREACH */
2796     /* case ENETRESET */
2797     /* case ECONNABORTED */
2798     /* case ECONNRESET */
2799     /* case ENOBUFS */
2800     /* case EISCONN */
2801     case ENOTCONN: return SS$_CLEARED;
2802     /* case ESHUTDOWN */
2803     /* case ETOOMANYREFS */
2804     /* case ETIMEDOUT */
2805     /* case ECONNREFUSED */
2806     /* case ELOOP */
2807     /* case ENAMETOOLONG */
2808     /* case EHOSTDOWN */
2809     /* case EHOSTUNREACH */
2810     /* case ENOTEMPTY */
2811     /* case EPROCLIM */
2812     /* case EUSERS  */
2813     /* case EDQUOT  */
2814     /* case ENOMSG  */
2815     /* case EIDRM */
2816     /* case EALIGN */
2817     /* case ESTALE */
2818     /* case EREMOTE */
2819     /* case ENOLCK */
2820     /* case ENOSYS */
2821     /* case EFTYPE */
2822     /* case ECANCELED */
2823     /* case EFAIL */
2824     /* case EINPROG */
2825     case ENOTSUP:
2826         return SS$_UNSUPPORTED;
2827     /* case EDEADLK */
2828     /* case ENWAIT */
2829     /* case EILSEQ */
2830     /* case EBADCAT */
2831     /* case EBADMSG */
2832     /* case EABANDONED */
2833     default:
2834         return SS$_ABORT; /* punt */
2835     }
2836 }
2837
2838
2839 /* default piping mailbox size */
2840 #define PERL_BUFSIZ        8192
2841
2842
2843 static void
2844 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2845 {
2846   unsigned long int mbxbufsiz;
2847   static unsigned long int syssize = 0;
2848   unsigned long int dviitm = DVI$_DEVNAM;
2849   char csize[LNM$C_NAMLENGTH+1];
2850   int sts;
2851
2852   if (!syssize) {
2853     unsigned long syiitm = SYI$_MAXBUF;
2854     /*
2855      * Get the SYSGEN parameter MAXBUF
2856      *
2857      * If the logical 'PERL_MBX_SIZE' is defined
2858      * use the value of the logical instead of PERL_BUFSIZ, but
2859      * keep the size between 128 and MAXBUF.
2860      *
2861      */
2862     _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2863   }
2864
2865   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2866       mbxbufsiz = atoi(csize);
2867   } else {
2868       mbxbufsiz = PERL_BUFSIZ;
2869   }
2870   if (mbxbufsiz < 128) mbxbufsiz = 128;
2871   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2872
2873   _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2874
2875   sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2876   _ckvmssts_noperl(sts);
2877   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2878
2879 }  /* end of create_mbx() */
2880
2881
2882 /*{{{  my_popen and my_pclose*/
2883
2884 typedef struct _iosb           IOSB;
2885 typedef struct _iosb*         pIOSB;
2886 typedef struct _pipe           Pipe;
2887 typedef struct _pipe*         pPipe;
2888 typedef struct pipe_details    Info;
2889 typedef struct pipe_details*  pInfo;
2890 typedef struct _srqp            RQE;
2891 typedef struct _srqp*          pRQE;
2892 typedef struct _tochildbuf      CBuf;
2893 typedef struct _tochildbuf*    pCBuf;
2894
2895 struct _iosb {
2896     unsigned short status;
2897     unsigned short count;
2898     unsigned long  dvispec;
2899 };
2900
2901 #pragma member_alignment save
2902 #pragma nomember_alignment quadword
2903 struct _srqp {          /* VMS self-relative queue entry */
2904     unsigned long qptr[2];
2905 };
2906 #pragma member_alignment restore
2907 static RQE  RQE_ZERO = {0,0};
2908
2909 struct _tochildbuf {
2910     RQE             q;
2911     int             eof;
2912     unsigned short  size;
2913     char            *buf;
2914 };
2915
2916 struct _pipe {
2917     RQE            free;
2918     RQE            wait;
2919     int            fd_out;
2920     unsigned short chan_in;
2921     unsigned short chan_out;
2922     char          *buf;
2923     unsigned int   bufsize;
2924     IOSB           iosb;
2925     IOSB           iosb2;
2926     int           *pipe_done;
2927     int            retry;
2928     int            type;
2929     int            shut_on_empty;
2930     int            need_wake;
2931     pPipe         *home;
2932     pInfo          info;
2933     pCBuf          curr;
2934     pCBuf          curr2;
2935 #if defined(PERL_IMPLICIT_CONTEXT)
2936     void            *thx;           /* Either a thread or an interpreter */
2937                                     /* pointer, depending on how we're built */
2938 #endif
2939 };
2940
2941
2942 struct pipe_details
2943 {
2944     pInfo           next;
2945     PerlIO *fp;  /* file pointer to pipe mailbox */
2946     int useFILE; /* using stdio, not perlio */
2947     int pid;   /* PID of subprocess */
2948     int mode;  /* == 'r' if pipe open for reading */
2949     int done;  /* subprocess has completed */
2950     int waiting; /* waiting for completion/closure */
2951     int             closing;        /* my_pclose is closing this pipe */
2952     unsigned long   completion;     /* termination status of subprocess */
2953     pPipe           in;             /* pipe in to sub */
2954     pPipe           out;            /* pipe out of sub */
2955     pPipe           err;            /* pipe of sub's sys$error */
2956     int             in_done;        /* true when in pipe finished */
2957     int             out_done;
2958     int             err_done;
2959     unsigned short  xchan;          /* channel to debug xterm */
2960     unsigned short  xchan_valid;    /* channel is assigned */
2961 };
2962
2963 struct exit_control_block
2964 {
2965     struct exit_control_block *flink;
2966     unsigned long int (*exit_routine)(void);
2967     unsigned long int arg_count;
2968     unsigned long int *status_address;
2969     unsigned long int exit_status;
2970 };
2971
2972 typedef struct _closed_pipes    Xpipe;
2973 typedef struct _closed_pipes*  pXpipe;
2974
2975 struct _closed_pipes {
2976     int             pid;            /* PID of subprocess */
2977     unsigned long   completion;     /* termination status of subprocess */
2978 };
2979 #define NKEEPCLOSED 50
2980 static Xpipe closed_list[NKEEPCLOSED];
2981 static int   closed_index = 0;
2982 static int   closed_num = 0;
2983
2984 #define RETRY_DELAY     "0 ::0.20"
2985 #define MAX_RETRY              50
2986
2987 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2988 static unsigned long mypid;
2989 static unsigned long delaytime[2];
2990
2991 static pInfo open_pipes = NULL;
2992 static $DESCRIPTOR(nl_desc, "NL:");
2993
2994 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2995
2996
2997
2998 static unsigned long int
2999 pipe_exit_routine(void)
3000 {
3001     pInfo info;
3002     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
3003     int sts, did_stuff, j;
3004
3005    /*
3006     * Flush any pending i/o, but since we are in process run-down, be
3007     * careful about referencing PerlIO structures that may already have
3008     * been deallocated.  We may not even have an interpreter anymore.
3009     */
3010     info = open_pipes;
3011     while (info) {
3012         if (info->fp) {
3013 #if defined(PERL_IMPLICIT_CONTEXT)
3014            /* We need to use the Perl context of the thread that created */
3015            /* the pipe. */
3016            pTHX;
3017            if (info->err)
3018                aTHX = info->err->thx;
3019            else if (info->out)
3020                aTHX = info->out->thx;
3021            else if (info->in)
3022                aTHX = info->in->thx;
3023 #endif
3024            if (!info->useFILE
3025 #if defined(USE_ITHREADS)
3026              && my_perl
3027 #endif
3028 #ifdef USE_PERLIO
3029              && PL_perlio_fd_refcnt
3030 #endif
3031               )
3032                PerlIO_flush(info->fp);
3033            else
3034                fflush((FILE *)info->fp);
3035         }
3036         info = info->next;
3037     }
3038
3039     /*
3040      next we try sending an EOF...ignore if doesn't work, make sure we
3041      don't hang
3042     */
3043     did_stuff = 0;
3044     info = open_pipes;
3045
3046     while (info) {
3047       _ckvmssts_noperl(sys$setast(0));
3048       if (info->in && !info->in->shut_on_empty) {
3049         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3050                                  0, 0, 0, 0, 0, 0));
3051         info->waiting = 1;
3052         did_stuff = 1;
3053       }
3054       _ckvmssts_noperl(sys$setast(1));
3055       info = info->next;
3056     }
3057
3058     /* wait for EOF to have effect, up to ~ 30 sec [default] */
3059
3060     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3061         int nwait = 0;
3062
3063         info = open_pipes;
3064         while (info) {
3065           _ckvmssts_noperl(sys$setast(0));
3066           if (info->waiting && info->done)
3067                 info->waiting = 0;
3068           nwait += info->waiting;
3069           _ckvmssts_noperl(sys$setast(1));
3070           info = info->next;
3071         }
3072         if (!nwait) break;
3073         sleep(1);
3074     }
3075
3076     did_stuff = 0;
3077     info = open_pipes;
3078     while (info) {
3079       _ckvmssts_noperl(sys$setast(0));
3080       if (!info->done) { /* Tap them gently on the shoulder . . .*/
3081         sts = sys$forcex(&info->pid,0,&abort);
3082         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3083         did_stuff = 1;
3084       }
3085       _ckvmssts_noperl(sys$setast(1));
3086       info = info->next;
3087     }
3088
3089     /* again, wait for effect */
3090
3091     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3092         int nwait = 0;
3093
3094         info = open_pipes;
3095         while (info) {
3096           _ckvmssts_noperl(sys$setast(0));
3097           if (info->waiting && info->done)
3098                 info->waiting = 0;
3099           nwait += info->waiting;
3100           _ckvmssts_noperl(sys$setast(1));
3101           info = info->next;
3102         }
3103         if (!nwait) break;
3104         sleep(1);
3105     }
3106
3107     info = open_pipes;
3108     while (info) {
3109       _ckvmssts_noperl(sys$setast(0));
3110       if (!info->done) {  /* We tried to be nice . . . */
3111         sts = sys$delprc(&info->pid,0);
3112         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3113         info->done = 1;  /* sys$delprc is as done as we're going to get. */
3114       }
3115       _ckvmssts_noperl(sys$setast(1));
3116       info = info->next;
3117     }
3118
3119     while(open_pipes) {
3120
3121 #if defined(PERL_IMPLICIT_CONTEXT)
3122       /* We need to use the Perl context of the thread that created */
3123       /* the pipe. */
3124       pTHX;
3125       if (open_pipes->err)
3126           aTHX = open_pipes->err->thx;
3127       else if (open_pipes->out)
3128           aTHX = open_pipes->out->thx;
3129       else if (open_pipes->in)
3130           aTHX = open_pipes->in->thx;
3131 #endif
3132       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3133       else if (!(sts & 1)) retsts = sts;
3134     }
3135     return retsts;
3136 }
3137
3138 static struct exit_control_block pipe_exitblock =
3139        {(struct exit_control_block *) 0,
3140         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3141
3142 static void pipe_mbxtofd_ast(pPipe p);
3143 static void pipe_tochild1_ast(pPipe p);
3144 static void pipe_tochild2_ast(pPipe p);
3145
3146 static void
3147 popen_completion_ast(pInfo info)
3148 {
3149   pInfo i = open_pipes;
3150   int iss;
3151
3152   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3153   closed_list[closed_index].pid = info->pid;
3154   closed_list[closed_index].completion = info->completion;
3155   closed_index++;
3156   if (closed_index == NKEEPCLOSED)
3157     closed_index = 0;
3158   closed_num++;
3159
3160   while (i) {
3161     if (i == info) break;
3162     i = i->next;
3163   }
3164   if (!i) return;       /* unlinked, probably freed too */
3165
3166   info->done = TRUE;
3167
3168 /*
3169     Writing to subprocess ...
3170             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3171
3172             chan_out may be waiting for "done" flag, or hung waiting
3173             for i/o completion to child...cancel the i/o.  This will
3174             put it into "snarf mode" (done but no EOF yet) that discards
3175             input.
3176
3177     Output from subprocess (stdout, stderr) needs to be flushed and
3178     shut down.   We try sending an EOF, but if the mbx is full the pipe
3179     routine should still catch the "shut_on_empty" flag, telling it to
3180     use immediate-style reads so that "mbx empty" -> EOF.
3181
3182
3183 */
3184   if (info->in && !info->in_done) {               /* only for mode=w */
3185         if (info->in->shut_on_empty && info->in->need_wake) {
3186             info->in->need_wake = FALSE;
3187             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3188         } else {
3189             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3190         }
3191   }
3192
3193   if (info->out && !info->out_done) {             /* were we also piping output? */
3194       info->out->shut_on_empty = TRUE;
3195       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3196       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3197       _ckvmssts_noperl(iss);
3198   }
3199
3200   if (info->err && !info->err_done) {        /* we were piping stderr */
3201         info->err->shut_on_empty = TRUE;
3202         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3203         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3204         _ckvmssts_noperl(iss);
3205   }
3206   _ckvmssts_noperl(sys$setef(pipe_ef));
3207
3208 }
3209
3210 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3211 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3212 static void pipe_infromchild_ast(pPipe p);
3213
3214 /*
3215     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3216     inside an AST routine without worrying about reentrancy and which Perl
3217     memory allocator is being used.
3218
3219     We read data and queue up the buffers, then spit them out one at a
3220     time to the output mailbox when the output mailbox is ready for one.
3221
3222 */
3223 #define INITIAL_TOCHILDQUEUE  2
3224
3225 static pPipe
3226 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3227 {
3228     pPipe p;
3229     pCBuf b;
3230     char mbx1[64], mbx2[64];
3231     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3232                                       DSC$K_CLASS_S, mbx1},
3233                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3234                                       DSC$K_CLASS_S, mbx2};
3235     unsigned int dviitm = DVI$_DEVBUFSIZ;
3236     int j, n;
3237
3238     n = sizeof(Pipe);
3239     _ckvmssts_noperl(lib$get_vm(&n, &p));
3240
3241     create_mbx(&p->chan_in , &d_mbx1);
3242     create_mbx(&p->chan_out, &d_mbx2);
3243     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3244
3245     p->buf           = 0;
3246     p->shut_on_empty = FALSE;
3247     p->need_wake     = FALSE;
3248     p->type          = 0;
3249     p->retry         = 0;
3250     p->iosb.status   = SS$_NORMAL;
3251     p->iosb2.status  = SS$_NORMAL;
3252     p->free          = RQE_ZERO;
3253     p->wait          = RQE_ZERO;
3254     p->curr          = 0;
3255     p->curr2         = 0;
3256     p->info          = 0;
3257 #ifdef PERL_IMPLICIT_CONTEXT
3258     p->thx           = aTHX;
3259 #endif
3260
3261     n = sizeof(CBuf) + p->bufsize;
3262
3263     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3264         _ckvmssts_noperl(lib$get_vm(&n, &b));
3265         b->buf = (char *) b + sizeof(CBuf);
3266         _ckvmssts_noperl(lib$insqhi(b, &p->free));
3267     }
3268
3269     pipe_tochild2_ast(p);
3270     pipe_tochild1_ast(p);
3271     strcpy(wmbx, mbx1);
3272     strcpy(rmbx, mbx2);
3273     return p;
3274 }
3275
3276 /*  reads the MBX Perl is writing, and queues */
3277
3278 static void
3279 pipe_tochild1_ast(pPipe p)
3280 {
3281     pCBuf b = p->curr;
3282     int iss = p->iosb.status;
3283     int eof = (iss == SS$_ENDOFFILE);
3284     int sts;
3285 #ifdef PERL_IMPLICIT_CONTEXT
3286     pTHX = p->thx;
3287 #endif
3288
3289     if (p->retry) {
3290         if (eof) {
3291             p->shut_on_empty = TRUE;
3292             b->eof     = TRUE;
3293             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3294         } else  {
3295             _ckvmssts_noperl(iss);
3296         }
3297
3298         b->eof  = eof;
3299         b->size = p->iosb.count;
3300         _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3301         if (p->need_wake) {
3302             p->need_wake = FALSE;
3303             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3304         }
3305     } else {
3306         p->retry = 1;   /* initial call */
3307     }
3308
3309     if (eof) {                  /* flush the free queue, return when done */
3310         int n = sizeof(CBuf) + p->bufsize;
3311         while (1) {
3312             iss = lib$remqti(&p->free, &b);
3313             if (iss == LIB$_QUEWASEMP) return;
3314             _ckvmssts_noperl(iss);
3315             _ckvmssts_noperl(lib$free_vm(&n, &b));
3316         }
3317     }
3318
3319     iss = lib$remqti(&p->free, &b);
3320     if (iss == LIB$_QUEWASEMP) {
3321         int n = sizeof(CBuf) + p->bufsize;
3322         _ckvmssts_noperl(lib$get_vm(&n, &b));
3323         b->buf = (char *) b + sizeof(CBuf);
3324     } else {
3325        _ckvmssts_noperl(iss);
3326     }
3327
3328     p->curr = b;
3329     iss = sys$qio(0,p->chan_in,
3330              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3331              &p->iosb,
3332              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3333     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3334     _ckvmssts_noperl(iss);
3335 }
3336
3337
3338 /* writes queued buffers to output, waits for each to complete before
3339    doing the next */
3340
3341 static void
3342 pipe_tochild2_ast(pPipe p)
3343 {
3344     pCBuf b = p->curr2;
3345     int iss = p->iosb2.status;
3346     int n = sizeof(CBuf) + p->bufsize;
3347     int done = (p->info && p->info->done) ||
3348               iss == SS$_CANCEL || iss == SS$_ABORT;
3349 #if defined(PERL_IMPLICIT_CONTEXT)
3350     pTHX = p->thx;
3351 #endif
3352
3353     do {
3354         if (p->type) {         /* type=1 has old buffer, dispose */
3355             if (p->shut_on_empty) {
3356                 _ckvmssts_noperl(lib$free_vm(&n, &b));
3357             } else {
3358                 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3359             }
3360             p->type = 0;
3361         }
3362
3363         iss = lib$remqti(&p->wait, &b);
3364         if (iss == LIB$_QUEWASEMP) {
3365             if (p->shut_on_empty) {
3366                 if (done) {
3367                     _ckvmssts_noperl(sys$dassgn(p->chan_out));
3368                     *p->pipe_done = TRUE;
3369                     _ckvmssts_noperl(sys$setef(pipe_ef));
3370                 } else {
3371                     _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3372                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3373                 }
3374                 return;
3375             }
3376             p->need_wake = TRUE;
3377             return;
3378         }
3379         _ckvmssts_noperl(iss);
3380         p->type = 1;
3381     } while (done);
3382
3383
3384     p->curr2 = b;
3385     if (b->eof) {
3386         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3387             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3388     } else {
3389         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3390             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3391     }
3392
3393     return;
3394
3395 }
3396
3397
3398 static pPipe
3399 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3400 {
3401     pPipe p;
3402     char mbx1[64], mbx2[64];
3403     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3404                                       DSC$K_CLASS_S, mbx1},
3405                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3406                                       DSC$K_CLASS_S, mbx2};
3407     unsigned int dviitm = DVI$_DEVBUFSIZ;
3408
3409     int n = sizeof(Pipe);
3410     _ckvmssts_noperl(lib$get_vm(&n, &p));
3411     create_mbx(&p->chan_in , &d_mbx1);
3412     create_mbx(&p->chan_out, &d_mbx2);
3413
3414     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3415     n = p->bufsize * sizeof(char);
3416     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3417     p->shut_on_empty = FALSE;
3418     p->info   = 0;
3419     p->type   = 0;
3420     p->iosb.status = SS$_NORMAL;
3421 #if defined(PERL_IMPLICIT_CONTEXT)
3422     p->thx = aTHX;
3423 #endif
3424     pipe_infromchild_ast(p);
3425
3426     strcpy(wmbx, mbx1);
3427     strcpy(rmbx, mbx2);
3428     return p;
3429 }
3430
3431 static void
3432 pipe_infromchild_ast(pPipe p)
3433 {
3434     int iss = p->iosb.status;
3435     int eof = (iss == SS$_ENDOFFILE);
3436     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3437     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3438 #if defined(PERL_IMPLICIT_CONTEXT)
3439     pTHX = p->thx;
3440 #endif
3441
3442     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3443         _ckvmssts_noperl(sys$dassgn(p->chan_out));
3444         p->chan_out = 0;
3445     }
3446
3447     /* read completed:
3448             input shutdown if EOF from self (done or shut_on_empty)
3449             output shutdown if closing flag set (my_pclose)
3450             send data/eof from child or eof from self
3451             otherwise, re-read (snarf of data from child)
3452     */
3453
3454     if (p->type == 1) {
3455         p->type = 0;
3456         if (myeof && p->chan_in) {                  /* input shutdown */
3457             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3458             p->chan_in = 0;
3459         }
3460
3461         if (p->chan_out) {
3462             if (myeof || kideof) {      /* pass EOF to parent */
3463                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3464                                          pipe_infromchild_ast, p,
3465                                          0, 0, 0, 0, 0, 0));
3466                 return;
3467             } else if (eof) {       /* eat EOF --- fall through to read*/
3468
3469             } else {                /* transmit data */
3470                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3471                                          pipe_infromchild_ast,p,
3472                                          p->buf, p->iosb.count, 0, 0, 0, 0));
3473                 return;
3474             }
3475         }
3476     }
3477
3478     /*  everything shut? flag as done */
3479
3480     if (!p->chan_in && !p->chan_out) {
3481         *p->pipe_done = TRUE;
3482         _ckvmssts_noperl(sys$setef(pipe_ef));
3483         return;
3484     }
3485
3486     /* write completed (or read, if snarfing from child)
3487             if still have input active,
3488                queue read...immediate mode if shut_on_empty so we get EOF if empty
3489             otherwise,
3490                check if Perl reading, generate EOFs as needed
3491     */
3492
3493     if (p->type == 0) {
3494         p->type = 1;
3495         if (p->chan_in) {
3496             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3497                           pipe_infromchild_ast,p,
3498                           p->buf, p->bufsize, 0, 0, 0, 0);
3499             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3500             _ckvmssts_noperl(iss);
3501         } else {           /* send EOFs for extra reads */
3502             p->iosb.status = SS$_ENDOFFILE;
3503             p->iosb.dvispec = 0;
3504             _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3505                                      0, 0, 0,
3506                                      pipe_infromchild_ast, p, 0, 0, 0, 0));
3507         }
3508     }
3509 }
3510
3511 static pPipe
3512 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3513 {
3514     pPipe p;
3515     char mbx[64];
3516     unsigned long dviitm = DVI$_DEVBUFSIZ;
3517     struct stat s;
3518     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3519                                       DSC$K_CLASS_S, mbx};
3520     int n = sizeof(Pipe);
3521
3522     /* things like terminals and mbx's don't need this filter */
3523     if (fd && fstat(fd,&s) == 0) {
3524         unsigned long devchar;
3525         char device[65];
3526         unsigned short dev_len;
3527         struct dsc$descriptor_s d_dev;
3528         char * cptr;
3529         struct item_list_3 items[3];
3530         int status;
3531         unsigned short dvi_iosb[4];
3532
3533         cptr = getname(fd, out, 1);
3534         if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3535         d_dev.dsc$a_pointer = out;
3536         d_dev.dsc$w_length = strlen(out);
3537         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3538         d_dev.dsc$b_class = DSC$K_CLASS_S;
3539
3540         items[0].len = 4;
3541         items[0].code = DVI$_DEVCHAR;
3542         items[0].bufadr = &devchar;
3543         items[0].retadr = NULL;
3544         items[1].len = 64;
3545         items[1].code = DVI$_FULLDEVNAM;
3546         items[1].bufadr = device;
3547         items[1].retadr = &dev_len;
3548         items[2].len = 0;
3549         items[2].code = 0;
3550
3551         status = sys$getdviw
3552                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3553         _ckvmssts_noperl(status);
3554         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3555             device[dev_len] = 0;
3556
3557             if (!(devchar & DEV$M_DIR)) {
3558                 strcpy(out, device);
3559                 return 0;
3560             }
3561         }
3562     }
3563
3564     _ckvmssts_noperl(lib$get_vm(&n, &p));
3565     p->fd_out = dup(fd);
3566     create_mbx(&p->chan_in, &d_mbx);
3567     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3568     n = (p->bufsize+1) * sizeof(char);
3569     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3570     p->shut_on_empty = FALSE;
3571     p->retry = 0;
3572     p->info  = 0;
3573     strcpy(out, mbx);
3574
3575     _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3576                              pipe_mbxtofd_ast, p,
3577                              p->buf, p->bufsize, 0, 0, 0, 0));
3578
3579     return p;
3580 }
3581
3582 static void
3583 pipe_mbxtofd_ast(pPipe p)
3584 {
3585     int iss = p->iosb.status;
3586     int done = p->info->done;
3587     int iss2;
3588     int eof = (iss == SS$_ENDOFFILE);
3589     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3590     int err = !(iss&1) && !eof;
3591 #if defined(PERL_IMPLICIT_CONTEXT)
3592     pTHX = p->thx;
3593 #endif
3594
3595     if (done && myeof) {               /* end piping */
3596         close(p->fd_out);
3597         sys$dassgn(p->chan_in);
3598         *p->pipe_done = TRUE;
3599         _ckvmssts_noperl(sys$setef(pipe_ef));
3600         return;
3601     }
3602
3603     if (!err && !eof) {             /* good data to send to file */
3604         p->buf[p->iosb.count] = '\n';
3605         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3606         if (iss2 < 0) {
3607             p->retry++;
3608             if (p->retry < MAX_RETRY) {
3609                 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3610                 return;
3611             }
3612         }
3613         p->retry = 0;
3614     } else if (err) {
3615         _ckvmssts_noperl(iss);
3616     }
3617
3618
3619     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3620           pipe_mbxtofd_ast, p,
3621           p->buf, p->bufsize, 0, 0, 0, 0);
3622     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3623     _ckvmssts_noperl(iss);
3624 }
3625
3626
3627 typedef struct _pipeloc     PLOC;
3628 typedef struct _pipeloc*   pPLOC;
3629
3630 struct _pipeloc {
3631     pPLOC   next;
3632     char    dir[NAM$C_MAXRSS+1];
3633 };
3634 static pPLOC  head_PLOC = 0;
3635
3636 void
3637 free_pipelocs(pTHX_ void *head)
3638 {
3639     pPLOC p, pnext;
3640     pPLOC *pHead = (pPLOC *)head;
3641
3642     p = *pHead;
3643     while (p) {
3644         pnext = p->next;
3645         PerlMem_free(p);
3646         p = pnext;
3647     }
3648     *pHead = 0;
3649 }
3650
3651 static void
3652 store_pipelocs(pTHX)
3653 {
3654     int    i;
3655     pPLOC  p;
3656     AV    *av = 0;
3657     SV    *dirsv;
3658     char  *dir, *x;
3659     char  *unixdir;
3660     char  temp[NAM$C_MAXRSS+1];
3661     STRLEN n_a;
3662
3663     if (head_PLOC)
3664         free_pipelocs(aTHX_ &head_PLOC);
3665
3666 /*  the . directory from @INC comes last */
3667
3668     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3669     if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3670     p->next = head_PLOC;
3671     head_PLOC = p;
3672     strcpy(p->dir,"./");
3673
3674 /*  get the directory from $^X */
3675
3676     unixdir = (char *)PerlMem_malloc(VMS_MAXRSS);
3677     if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3678
3679 #ifdef PERL_IMPLICIT_CONTEXT
3680     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3681 #else
3682     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3683 #endif
3684         my_strlcpy(temp, PL_origargv[0], sizeof(temp));
3685         x = strrchr(temp,']');
3686         if (x == NULL) {
3687         x = strrchr(temp,'>');
3688           if (x == NULL) {
3689             /* It could be a UNIX path */
3690             x = strrchr(temp,'/');
3691           }
3692         }
3693         if (x)
3694           x[1] = '\0';
3695         else {
3696           /* Got a bare name, so use default directory */
3697           temp[0] = '.';
3698           temp[1] = '\0';
3699         }
3700
3701         if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3702             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3703             if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3704             p->next = head_PLOC;
3705             head_PLOC = p;
3706             my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3707         }
3708     }
3709
3710 /*  reverse order of @INC entries, skip "." since entered above */
3711
3712 #ifdef PERL_IMPLICIT_CONTEXT
3713     if (aTHX)
3714 #endif
3715     if (PL_incgv) av = GvAVn(PL_incgv);
3716
3717     for (i = 0; av && i <= AvFILL(av); i++) {
3718         dirsv = *av_fetch(av,i,TRUE);
3719
3720         if (SvROK(dirsv)) continue;
3721         dir = SvPVx(dirsv,n_a);
3722         if (strcmp(dir,".") == 0) continue;
3723         if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3724             continue;
3725
3726         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3727         p->next = head_PLOC;
3728         head_PLOC = p;
3729         my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3730     }
3731
3732 /* most likely spot (ARCHLIB) put first in the list */
3733
3734 #ifdef ARCHLIB_EXP
3735     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3736         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3737         if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3738         p->next = head_PLOC;
3739         head_PLOC = p;
3740         my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3741     }
3742 #endif
3743     PerlMem_free(unixdir);
3744 }
3745
3746 static I32 Perl_cando_by_name_int(pTHX_ I32 bit, bool effective,
3747                                   const char *fname, int opts);
3748 #if !defined(PERL_IMPLICIT_CONTEXT)
3749 #define cando_by_name_int               Perl_cando_by_name_int
3750 #else
3751 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3752 #endif
3753
3754 static char *
3755 find_vmspipe(pTHX)
3756 {
3757     static int   vmspipe_file_status = 0;
3758     static char  vmspipe_file[NAM$C_MAXRSS+1];
3759
3760     /* already found? Check and use ... need read+execute permission */
3761
3762     if (vmspipe_file_status == 1) {
3763         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3764          && cando_by_name_int
3765            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3766             return vmspipe_file;
3767         }
3768         vmspipe_file_status = 0;
3769     }
3770
3771     /* scan through stored @INC, $^X */
3772
3773     if (vmspipe_file_status == 0) {
3774         char file[NAM$C_MAXRSS+1];
3775         pPLOC  p = head_PLOC;
3776
3777         while (p) {
3778             char * exp_res;
3779             int dirlen;
3780             dirlen = my_strlcpy(file, p->dir, sizeof(file));
3781             my_strlcat(file, "vmspipe.com", sizeof(file));
3782             p = p->next;
3783
3784             exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3785             if (!exp_res) continue;
3786
3787             if (cando_by_name_int
3788                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3789              && cando_by_name_int
3790                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3791                 vmspipe_file_status = 1;
3792                 return vmspipe_file;
3793             }
3794         }
3795         vmspipe_file_status = -1;   /* failed, use tempfiles */
3796     }
3797
3798     return 0;
3799 }
3800
3801 static FILE *
3802 vmspipe_tempfile(pTHX)
3803 {
3804     char file[NAM$C_MAXRSS+1];
3805     FILE *fp;
3806     static int index = 0;
3807     Stat_t s0, s1;
3808     int cmp_result;
3809
3810     /* create a tempfile */
3811
3812     /* we can't go from   W, shr=get to  R, shr=get without
3813        an intermediate vulnerable state, so don't bother trying...
3814
3815        and lib$spawn doesn't shr=put, so have to close the write
3816
3817        So... match up the creation date/time and the FID to
3818        make sure we're dealing with the same file
3819
3820     */
3821
3822     index++;
3823     if (!decc_filename_unix_only) {
3824       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3825       fp = fopen(file,"w");
3826       if (!fp) {
3827         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3828         fp = fopen(file,"w");
3829         if (!fp) {
3830             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3831             fp = fopen(file,"w");
3832         }
3833       }
3834      }
3835      else {
3836       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3837       fp = fopen(file,"w");
3838       if (!fp) {
3839         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3840         fp = fopen(file,"w");
3841         if (!fp) {
3842           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3843           fp = fopen(file,"w");
3844         }
3845       }
3846     }
3847     if (!fp) return 0;  /* we're hosed */
3848
3849     fprintf(fp,"$! 'f$verify(0)'\n");
3850     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3851     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3852     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3853     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3854     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3855     fprintf(fp,"$ perl_del    = \"delete\"\n");
3856     fprintf(fp,"$ pif         = \"if\"\n");
3857     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3858     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3859     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3860     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3861     fprintf(fp,"$!  --- build command line to get max possible length\n");
3862     fprintf(fp,"$c=perl_popen_cmd0\n");
3863     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3864     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3865     fprintf(fp,"$x=perl_popen_cmd3\n");
3866     fprintf(fp,"$c=c+x\n");
3867     fprintf(fp,"$ perl_on\n");
3868     fprintf(fp,"$ 'c'\n");
3869     fprintf(fp,"$ perl_status = $STATUS\n");
3870     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3871     fprintf(fp,"$ perl_exit 'perl_status'\n");
3872     fsync(fileno(fp));
3873
3874     fgetname(fp, file, 1);
3875     fstat(fileno(fp), &s0.crtl_stat);
3876     fclose(fp);
3877
3878     if (decc_filename_unix_only)
3879         int_tounixspec(file, file, NULL);
3880     fp = fopen(file,"r","shr=get");
3881     if (!fp) return 0;
3882     fstat(fileno(fp), &s1.crtl_stat);
3883
3884     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3885     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3886         fclose(fp);
3887         return 0;
3888     }
3889
3890     return fp;
3891 }
3892
3893
3894 static int
3895 vms_is_syscommand_xterm(void)
3896 {
3897     const static struct dsc$descriptor_s syscommand_dsc =
3898       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3899
3900     const static struct dsc$descriptor_s decwdisplay_dsc =
3901       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3902
3903     struct item_list_3 items[2];
3904     unsigned short dvi_iosb[4];
3905     unsigned long devchar;
3906     unsigned long devclass;
3907     int status;
3908
3909     /* Very simple check to guess if sys$command is a decterm? */
3910     /* First see if the DECW$DISPLAY: device exists */
3911     items[0].len = 4;
3912     items[0].code = DVI$_DEVCHAR;
3913     items[0].bufadr = &devchar;
3914     items[0].retadr = NULL;
3915     items[1].len = 0;
3916     items[1].code = 0;
3917
3918     status = sys$getdviw
3919         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3920
3921     if ($VMS_STATUS_SUCCESS(status)) {
3922         status = dvi_iosb[0];
3923     }
3924
3925     if (!$VMS_STATUS_SUCCESS(status)) {
3926         SETERRNO(EVMSERR, status);
3927         return -1;
3928     }
3929
3930     /* If it does, then for now assume that we are on a workstation */
3931     /* Now verify that SYS$COMMAND is a terminal */
3932     /* for creating the debugger DECTerm */
3933
3934     items[0].len = 4;
3935     items[0].code = DVI$_DEVCLASS;
3936     items[0].bufadr = &devclass;
3937     items[0].retadr = NULL;
3938     items[1].len = 0;
3939     items[1].code = 0;
3940
3941     status = sys$getdviw
3942         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3943
3944     if ($VMS_STATUS_SUCCESS(status)) {
3945         status = dvi_iosb[0];
3946     }
3947
3948     if (!$VMS_STATUS_SUCCESS(status)) {
3949         SETERRNO(EVMSERR, status);
3950         return -1;
3951     }
3952     else {
3953         if (devclass == DC$_TERM) {
3954             return 0;
3955         }
3956     }
3957     return -1;
3958 }
3959
3960 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3961 static PerlIO*
3962 create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3963 {
3964     int status;
3965     int ret_stat;
3966     char * ret_char;
3967     char device_name[65];
3968     unsigned short device_name_len;
3969     struct dsc$descriptor_s customization_dsc;
3970     struct dsc$descriptor_s device_name_dsc;
3971     const char * cptr;
3972     char customization[200];
3973     char title[40];
3974     pInfo info = NULL;
3975     char mbx1[64];
3976     unsigned short p_chan;
3977     int n;
3978     unsigned short iosb[4];
3979     const char * cust_str =
3980         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3981     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3982                                           DSC$K_CLASS_S, mbx1};
3983
3984      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3985     /*---------------------------------------*/
3986     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
3987
3988
3989     /* Make sure that this is from the Perl debugger */
3990     ret_char = strstr(cmd," xterm ");
3991     if (ret_char == NULL)
3992         return NULL;
3993     cptr = ret_char + 7;
3994     ret_char = strstr(cmd,"tty");
3995     if (ret_char == NULL)
3996         return NULL;
3997     ret_char = strstr(cmd,"sleep");
3998     if (ret_char == NULL)
3999         return NULL;
4000
4001     if (decw_term_port == 0) {
4002         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
4003         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
4004         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
4005
4006        status = lib$find_image_symbol
4007                                (&filename1_dsc,
4008                                 &decw_term_port_dsc,
4009                                 (void *)&decw_term_port,
4010                                 NULL,
4011                                 0);
4012
4013         /* Try again with the other image name */
4014         if (!$VMS_STATUS_SUCCESS(status)) {
4015
4016            status = lib$find_image_symbol
4017                                (&filename2_dsc,
4018                                 &decw_term_port_dsc,
4019                                 (void *)&decw_term_port,
4020                                 NULL,
4021                                 0);
4022
4023         }
4024
4025     }
4026
4027
4028     /* No decw$term_port, give it up */
4029     if (!$VMS_STATUS_SUCCESS(status))
4030         return NULL;
4031
4032     /* Are we on a workstation? */
4033     /* to do: capture the rows / columns and pass their properties */
4034     ret_stat = vms_is_syscommand_xterm();
4035     if (ret_stat < 0)
4036         return NULL;
4037
4038     /* Make the title: */
4039     ret_char = strstr(cptr,"-title");
4040     if (ret_char != NULL) {
4041         while ((*cptr != 0) && (*cptr != '\"')) {
4042             cptr++;
4043         }
4044         if (*cptr == '\"')
4045             cptr++;
4046         n = 0;
4047         while ((*cptr != 0) && (*cptr != '\"')) {
4048             title[n] = *cptr;
4049             n++;
4050             if (n == 39) {
4051                 title[39] = 0;
4052                 break;
4053             }
4054             cptr++;
4055         }
4056         title[n] = 0;
4057     }
4058     else {
4059             /* Default title */
4060             strcpy(title,"Perl Debug DECTerm");
4061     }
4062     sprintf(customization, cust_str, title);
4063
4064     customization_dsc.dsc$a_pointer = customization;
4065     customization_dsc.dsc$w_length = strlen(customization);
4066     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4067     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
4068
4069     device_name_dsc.dsc$a_pointer = device_name;
4070     device_name_dsc.dsc$w_length = sizeof device_name -1;
4071     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4072     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
4073
4074     device_name_len = 0;
4075
4076     /* Try to create the window */
4077      status = (*decw_term_port)
4078        (NULL,
4079         NULL,
4080         &customization_dsc,
4081         &device_name_dsc,
4082         &device_name_len,
4083         NULL,
4084         NULL,
4085         NULL);
4086     if (!$VMS_STATUS_SUCCESS(status)) {
4087         SETERRNO(EVMSERR, status);
4088         return NULL;
4089     }
4090
4091     device_name[device_name_len] = '\0';
4092
4093     /* Need to set this up to look like a pipe for cleanup */
4094     n = sizeof(Info);
4095     status = lib$get_vm(&n, &info);
4096     if (!$VMS_STATUS_SUCCESS(status)) {
4097         SETERRNO(ENOMEM, status);
4098         return NULL;
4099     }
4100
4101     info->mode = *mode;
4102     info->done = FALSE;
4103     info->completion = 0;
4104     info->closing    = FALSE;
4105     info->in         = 0;
4106     info->out        = 0;
4107     info->err        = 0;
4108     info->fp         = NULL;
4109     info->useFILE    = 0;
4110     info->waiting    = 0;
4111     info->in_done    = TRUE;
4112     info->out_done   = TRUE;
4113     info->err_done   = TRUE;
4114
4115     /* Assign a channel on this so that it will persist, and not login */
4116     /* We stash this channel in the info structure for reference. */
4117     /* The created xterm self destructs when the last channel is removed */
4118     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4119     /* So leave this assigned. */
4120     device_name_dsc.dsc$w_length = device_name_len;
4121     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4122     if (!$VMS_STATUS_SUCCESS(status)) {
4123         SETERRNO(EVMSERR, status);
4124         return NULL;
4125     }
4126     info->xchan_valid = 1;
4127
4128     /* Now create a mailbox to be read by the application */
4129
4130     create_mbx(&p_chan, &d_mbx1);
4131
4132     /* write the name of the created terminal to the mailbox */
4133     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4134             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4135
4136     if (!$VMS_STATUS_SUCCESS(status)) {
4137         SETERRNO(EVMSERR, status);
4138         return NULL;
4139     }
4140
4141     info->fp  = PerlIO_open(mbx1, mode);
4142
4143     /* Done with this channel */
4144     sys$dassgn(p_chan);
4145
4146     /* If any errors, then clean up */
4147     if (!info->fp) {
4148         n = sizeof(Info);
4149         _ckvmssts_noperl(lib$free_vm(&n, &info));
4150         return NULL;
4151         }
4152
4153     /* All done */
4154     return info->fp;
4155 }
4156
4157 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4158
4159 static PerlIO *
4160 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4161 {
4162     static int handler_set_up = FALSE;
4163     PerlIO * ret_fp;
4164     unsigned long int sts, flags = CLI$M_NOWAIT;
4165     /* The use of a GLOBAL table (as was done previously) rendered
4166      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4167      * environment.  Hence we've switched to LOCAL symbol table.
4168      */
4169     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4170     int j, wait = 0, n;
4171     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4172     char *in, *out, *err, mbx[512];
4173     FILE *tpipe = 0;
4174     char tfilebuf[NAM$C_MAXRSS+1];
4175     pInfo info = NULL;
4176     char cmd_sym_name[20];
4177     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4178                                       DSC$K_CLASS_S, symbol};
4179     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4180                                       DSC$K_CLASS_S, 0};
4181     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4182                                       DSC$K_CLASS_S, cmd_sym_name};
4183     struct dsc$descriptor_s *vmscmd;
4184     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4185     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4186     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4187
4188     /* Check here for Xterm create request.  This means looking for
4189      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4190      *  is possible to create an xterm.
4191      */
4192     if (*in_mode == 'r') {
4193         PerlIO * xterm_fd;
4194
4195 #if defined(PERL_IMPLICIT_CONTEXT)
4196         /* Can not fork an xterm with a NULL context */
4197         /* This probably could never happen */
4198         xterm_fd = NULL;
4199         if (aTHX != NULL)
4200 #endif
4201         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4202         if (xterm_fd != NULL)
4203             return xterm_fd;
4204     }
4205
4206     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4207
4208     /* once-per-program initialization...
4209        note that the SETAST calls and the dual test of pipe_ef
4210        makes sure that only the FIRST thread through here does
4211        the initialization...all other threads wait until it's
4212        done.
4213
4214        Yeah, uglier than a pthread call, it's got all the stuff inline
4215        rather than in a separate routine.
4216     */
4217
4218     if (!pipe_ef) {
4219         _ckvmssts_noperl(sys$setast(0));
4220         if (!pipe_ef) {
4221             unsigned long int pidcode = JPI$_PID;
4222             $DESCRIPTOR(d_delay, RETRY_DELAY);
4223             _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4224             _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4225             _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4226         }
4227         if (!handler_set_up) {
4228           _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4229           handler_set_up = TRUE;
4230         }
4231         _ckvmssts_noperl(sys$setast(1));
4232     }
4233
4234     /* see if we can find a VMSPIPE.COM */
4235
4236     tfilebuf[0] = '@';
4237     vmspipe = find_vmspipe(aTHX);
4238     if (vmspipe) {
4239         vmspipedsc.dsc$w_length = my_strlcpy(tfilebuf+1, vmspipe, sizeof(tfilebuf)-1) + 1;
4240     } else {        /* uh, oh...we're in tempfile hell */
4241         tpipe = vmspipe_tempfile(aTHX);
4242         if (!tpipe) {       /* a fish popular in Boston */
4243             if (ckWARN(WARN_PIPE)) {
4244                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4245             }
4246         return NULL;
4247         }
4248         fgetname(tpipe,tfilebuf+1,1);
4249         vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4250     }
4251     vmspipedsc.dsc$a_pointer = tfilebuf;
4252
4253     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4254     if (!(sts & 1)) {
4255       switch (sts) {
4256         case RMS$_FNF:  case RMS$_DNF:
4257           set_errno(ENOENT); break;
4258         case RMS$_DIR:
4259           set_errno(ENOTDIR); break;
4260         case RMS$_DEV:
4261           set_errno(ENODEV); break;
4262         case RMS$_PRV:
4263           set_errno(EACCES); break;
4264         case RMS$_SYN:
4265           set_errno(EINVAL); break;
4266         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4267           set_errno(E2BIG); break;
4268         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4269           _ckvmssts_noperl(sts); /* fall through */
4270         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4271           set_errno(EVMSERR);
4272       }
4273       set_vaxc_errno(sts);
4274       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4275         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4276       }
4277       *psts = sts;
4278       return NULL;
4279     }
4280     n = sizeof(Info);
4281     _ckvmssts_noperl(lib$get_vm(&n, &info));
4282
4283     my_strlcpy(mode, in_mode, sizeof(mode));
4284     info->mode = *mode;
4285     info->done = FALSE;
4286     info->completion = 0;
4287     info->closing    = FALSE;
4288     info->in         = 0;
4289     info->out        = 0;
4290     info->err        = 0;
4291     info->fp         = NULL;
4292     info->useFILE    = 0;
4293     info->waiting    = 0;
4294     info->in_done    = TRUE;
4295     info->out_done   = TRUE;
4296     info->err_done   = TRUE;
4297     info->xchan      = 0;
4298     info->xchan_valid = 0;
4299
4300     in = (char *)PerlMem_malloc(VMS_MAXRSS);
4301     if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4302     out = (char *)PerlMem_malloc(VMS_MAXRSS);
4303     if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4304     err = (char *)PerlMem_malloc(VMS_MAXRSS);
4305     if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4306
4307     in[0] = out[0] = err[0] = '\0';
4308
4309     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4310         info->useFILE = 1;
4311         strcpy(p,p+1);
4312     }
4313     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4314         wait = 1;
4315         strcpy(p,p+1);
4316     }
4317
4318     if (*mode == 'r') {             /* piping from subroutine */
4319
4320         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4321         if (info->out) {
4322             info->out->pipe_done = &info->out_done;
4323             info->out_done = FALSE;
4324             info->out->info = info;
4325         }
4326         if (!info->useFILE) {
4327             info->fp  = PerlIO_open(mbx, mode);
4328         } else {
4329             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4330             vmssetuserlnm("SYS$INPUT", mbx);
4331         }
4332
4333         if (!info->fp && info->out) {
4334             sys$cancel(info->out->chan_out);
4335
4336             while (!info->out_done) {
4337                 int done;
4338                 _ckvmssts_noperl(sys$setast(0));
4339                 done = info->out_done;
4340                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4341                 _ckvmssts_noperl(sys$setast(1));
4342                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4343             }
4344
4345             if (info->out->buf) {
4346                 n = info->out->bufsize * sizeof(char);
4347                 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4348             }
4349             n = sizeof(Pipe);
4350             _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4351             n = sizeof(Info);
4352             _ckvmssts_noperl(lib$free_vm(&n, &info));
4353             *psts = RMS$_FNF;
4354             return NULL;
4355         }
4356
4357         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4358         if (info->err) {
4359             info->err->pipe_done = &info->err_done;
4360             info->err_done = FALSE;
4361             info->err->info = info;
4362         }
4363
4364     } else if (*mode == 'w') {      /* piping to subroutine */
4365
4366         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4367         if (info->out) {
4368             info->out->pipe_done = &info->out_done;
4369             info->out_done = FALSE;
4370             info->out->info = info;
4371         }
4372
4373         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4374         if (info->err) {
4375             info->err->pipe_done = &info->err_done;
4376             info->err_done = FALSE;
4377             info->err->info = info;
4378         }
4379
4380         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4381         if (!info->useFILE) {
4382             info->fp  = PerlIO_open(mbx, mode);
4383         } else {
4384             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4385             vmssetuserlnm("SYS$OUTPUT", mbx);
4386         }
4387
4388         if (info->in) {
4389             info->in->pipe_done = &info->in_done;
4390             info->in_done = FALSE;
4391             info->in->info = info;
4392         }
4393
4394         /* error cleanup */
4395         if (!info->fp && info->in) {
4396             info->done = TRUE;
4397             _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4398                                       0, 0, 0, 0, 0, 0, 0, 0));
4399
4400             while (!info->in_done) {
4401                 int done;
4402                 _ckvmssts_noperl(sys$setast(0));
4403                 done = info->in_done;
4404                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4405                 _ckvmssts_noperl(sys$setast(1));
4406                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4407             }
4408
4409             if (info->in->buf) {
4410                 n = info->in->bufsize * sizeof(char);
4411                 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4412             }
4413             n = sizeof(Pipe);
4414             _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4415             n = sizeof(Info);
4416             _ckvmssts_noperl(lib$free_vm(&n, &info));
4417             *psts = RMS$_FNF;
4418             return NULL;
4419         }
4420
4421
4422     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4423         /* Let the child inherit standard input, unless it's a directory. */
4424         Stat_t st;
4425         if (my_trnlnm("SYS$INPUT", in, 0)) {
4426             if (flex_stat(in, &st) != 0 || S_ISDIR(st.st_mode))
4427                 *in = '\0';
4428         }
4429
4430         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4431         if (info->out) {
4432             info->out->pipe_done = &info->out_done;
4433             info->out_done = FALSE;
4434             info->out->info = info;
4435         }
4436
4437         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4438         if (info->err) {
4439             info->err->pipe_done = &info->err_done;
4440             info->err_done = FALSE;
4441             info->err->info = info;
4442         }
4443     }
4444
4445     d_symbol.dsc$w_length = my_strlcpy(symbol, in, sizeof(symbol));
4446     _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4447
4448     d_symbol.dsc$w_length = my_strlcpy(symbol, err, sizeof(symbol));
4449     _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4450
4451     d_symbol.dsc$w_length = my_strlcpy(symbol, out, sizeof(symbol));
4452     _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4453
4454     /* Done with the names for the pipes */
4455     PerlMem_free(err);
4456     PerlMem_free(out);
4457     PerlMem_free(in);
4458
4459     p = vmscmd->dsc$a_pointer;
4460     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4461     if (*p == '$') p++;                         /* remove leading $ */
4462     while (*p == ' ' || *p == '\t') p++;
4463
4464     for (j = 0; j < 4; j++) {
4465         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4466         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4467
4468     d_symbol.dsc$w_length = my_strlcpy(symbol, p, sizeof(symbol));
4469     _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4470
4471         if (strlen(p) > MAX_DCL_SYMBOL) {
4472             p += MAX_DCL_SYMBOL;
4473         } else {
4474             p += strlen(p);
4475         }
4476     }
4477     _ckvmssts_noperl(sys$setast(0));
4478     info->next=open_pipes;  /* prepend to list */
4479     open_pipes=info;
4480     _ckvmssts_noperl(sys$setast(1));
4481     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4482      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4483      * have SYS$COMMAND if we need it.
4484      */
4485     _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4486                       0, &info->pid, &info->completion,
4487                       0, popen_completion_ast,info,0,0,0));
4488
4489     /* if we were using a tempfile, close it now */
4490
4491     if (tpipe) fclose(tpipe);
4492
4493     /* once the subprocess is spawned, it has copied the symbols and
4494        we can get rid of ours */
4495
4496     for (j = 0; j < 4; j++) {
4497         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4498         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4499     _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4500     }
4501     _ckvmssts_noperl(lib$delete_symbol(&d_sym_in,  &table));
4502     _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4503     _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4504     vms_execfree(vmscmd);
4505
4506 #ifdef PERL_IMPLICIT_CONTEXT
4507     if (aTHX)
4508 #endif
4509     PL_forkprocess = info->pid;
4510
4511     ret_fp = info->fp;
4512     if (wait) {
4513          dSAVEDERRNO;
4514          int done = 0;
4515          while (!done) {
4516              _ckvmssts_noperl(sys$setast(0));
4517              done = info->done;
4518              if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4519              _ckvmssts_noperl(sys$setast(1));
4520              if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4521          }
4522         *psts = info->completion;
4523 /* Caller thinks it is open and tries to close it. */
4524 /* This causes some problems, as it changes the error status */
4525 /*        my_pclose(info->fp); */
4526
4527          /* If we did not have a file pointer open, then we have to */
4528          /* clean up here or eventually we will run out of something */
4529          SAVE_ERRNO;
4530          if (info->fp == NULL) {
4531              my_pclose_pinfo(aTHX_ info);
4532          }
4533          RESTORE_ERRNO;
4534
4535     } else {
4536         *psts = info->pid;
4537     }
4538     return ret_fp;
4539 }  /* end of safe_popen */
4540
4541
4542 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4543 PerlIO *
4544 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4545 {
4546     int sts;
4547     TAINT_ENV();
4548     TAINT_PROPER("popen");
4549     PERL_FLUSHALL_FOR_CHILD;
4550     return safe_popen(aTHX_ cmd,mode,&sts);
4551 }
4552
4553 /*}}}*/
4554
4555
4556 /* Routine to close and cleanup a pipe info structure */
4557
4558 static I32
4559 my_pclose_pinfo(pTHX_ pInfo info) {
4560
4561     unsigned long int retsts;
4562     int done, n;
4563     pInfo next, last;
4564
4565     /* If we were writing to a subprocess, insure that someone reading from
4566      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4567      * produce an EOF record in the mailbox.
4568      *
4569      *  well, at least sometimes it *does*, so we have to watch out for
4570      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4571      */
4572      if (info->fp) {
4573         if (!info->useFILE
4574 #if defined(USE_ITHREADS)
4575           && my_perl
4576 #endif
4577 #ifdef USE_PERLIO
4578           && PL_perlio_fd_refcnt
4579 #endif
4580            )
4581             PerlIO_flush(info->fp);
4582         else
4583             fflush((FILE *)info->fp);
4584     }
4585
4586     _ckvmssts(sys$setast(0));
4587      info->closing = TRUE;
4588      done = info->done && info->in_done && info->out_done && info->err_done;
4589      /* hanging on write to Perl's input? cancel it */
4590      if (info->mode == 'r' && info->out && !info->out_done) {
4591         if (info->out->chan_out) {
4592             _ckvmssts(sys$cancel(info->out->chan_out));
4593             if (!info->out->chan_in) {   /* EOF generation, need AST */
4594                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4595             }
4596         }
4597      }
4598      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4599          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4600                            0, 0, 0, 0, 0, 0));
4601     _ckvmssts(sys$setast(1));
4602     if (info->fp) {
4603      if (!info->useFILE
4604 #if defined(USE_ITHREADS)
4605          && my_perl
4606 #endif
4607 #ifdef USE_PERLIO
4608          && PL_perlio_fd_refcnt
4609 #endif
4610         )
4611         PerlIO_close(info->fp);
4612      else
4613         fclose((FILE *)info->fp);
4614     }
4615      /*
4616         we have to wait until subprocess completes, but ALSO wait until all
4617         the i/o completes...otherwise we'll be freeing the "info" structure
4618         that the i/o ASTs could still be using...
4619      */
4620
4621      while (!done) {
4622          _ckvmssts(sys$setast(0));
4623          done = info->done && info->in_done && info->out_done && info->err_done;
4624          if (!done) _ckvmssts(sys$clref(pipe_ef));
4625          _ckvmssts(sys$setast(1));
4626          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4627      }
4628      retsts = info->completion;
4629
4630     /* remove from list of open pipes */
4631     _ckvmssts(sys$setast(0));
4632     last = NULL;
4633     for (next = open_pipes; next != NULL; last = next, next = next->next) {
4634         if (next == info)
4635             break;
4636     }
4637
4638     if (last)
4639         last->next = info->next;
4640     else
4641         open_pipes = info->next;
4642     _ckvmssts(sys$setast(1));
4643
4644     /* free buffers and structures */
4645
4646     if (info->in) {
4647         if (info->in->buf) {
4648             n = info->in->bufsize * sizeof(char);
4649             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4650         }
4651         n = sizeof(Pipe);
4652         _ckvmssts(lib$free_vm(&n, &info->in));
4653     }
4654     if (info->out) {
4655         if (info->out->buf) {
4656             n = info->out->bufsize * sizeof(char);
4657             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4658         }
4659         n = sizeof(Pipe);
4660         _ckvmssts(lib$free_vm(&n, &info->out));
4661     }
4662     if (info->err) {
4663         if (info->err->buf) {
4664             n = info->err->bufsize * sizeof(char);
4665             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4666         }
4667         n = sizeof(Pipe);
4668         _ckvmssts(lib$free_vm(&n, &info->err));
4669     }
4670     n = sizeof(Info);
4671     _ckvmssts(lib$free_vm(&n, &info));
4672
4673     return retsts;
4674 }
4675
4676
4677 /*{{{  I32 my_pclose(PerlIO *fp)*/
4678 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4679 {
4680     pInfo info, last = NULL;
4681     I32 ret_status;
4682
4683     /* Fixme - need ast and mutex protection here */
4684     for (info = open_pipes; info != NULL; last = info, info = info->next)
4685         if (info->fp == fp) break;
4686
4687     if (info == NULL) {  /* no such pipe open */
4688       set_errno(ECHILD); /* quoth POSIX */
4689       set_vaxc_errno(SS$_NONEXPR);
4690       return -1;
4691     }
4692
4693     ret_status = my_pclose_pinfo(aTHX_ info);
4694
4695     return ret_status;
4696
4697 }  /* end of my_pclose() */
4698
4699   /* Roll our own prototype because we want this regardless of whether
4700    * _VMS_WAIT is defined.
4701    */
4702
4703 #ifdef __cplusplus
4704 extern "C" {
4705 #endif
4706   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4707 #ifdef __cplusplus
4708 }
4709 #endif
4710
4711 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4712    created with popen(); otherwise partially emulate waitpid() unless
4713    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4714    Also check processes not considered by the CRTL waitpid().
4715  */
4716 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4717 Pid_t
4718 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4719 {
4720     pInfo info;
4721     int done;
4722     int sts;
4723     int j;
4724
4725     if (statusp) *statusp = 0;
4726
4727     for (info = open_pipes; info != NULL; info = info->next)
4728         if (info->pid == pid) break;
4729
4730     if (info != NULL) {  /* we know about this child */
4731       while (!info->done) {
4732           _ckvmssts(sys$setast(0));
4733           done = info->done;
4734           if (!done) _ckvmssts(sys$clref(pipe_ef));
4735           _ckvmssts(sys$setast(1));
4736           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4737       }
4738
4739       if (statusp) *statusp = info->completion;
4740       return pid;
4741     }
4742
4743     /* child that already terminated? */
4744
4745     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4746         if (closed_list[j].pid == pid) {
4747             if (statusp) *statusp = closed_list[j].completion;
4748             return pid;
4749         }
4750     }
4751
4752     /* fall through if this child is not one of our own pipe children */
4753
4754       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4755        * in 7.2 did we get a version that fills in the VMS completion
4756        * status as Perl has always tried to do.
4757        */
4758
4759       sts = __vms_waitpid( pid, statusp, flags );
4760
4761       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4762          return sts;
4763
4764       /* If the real waitpid tells us the child does not exist, we
4765        * fall through here to implement waiting for a child that
4766        * was created by some means other than exec() (say, spawned
4767        * from DCL) or to wait for a process that is not a subprocess
4768        * of the current process.
4769        */
4770
4771     {
4772       $DESCRIPTOR(intdsc,"0 00:00:01");
4773       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4774       unsigned long int pidcode = JPI$_PID, mypid;
4775       unsigned long int interval[2];
4776       unsigned int jpi_iosb[2];
4777       struct itmlst_3 jpilist[2] = {
4778           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4779           {                      0,         0,                 0, 0}
4780       };
4781
4782       if (pid <= 0) {
4783         /* Sorry folks, we don't presently implement rooting around for
4784            the first child we can find, and we definitely don't want to
4785            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4786          */
4787         set_errno(ENOTSUP);
4788         return -1;
4789       }
4790
4791       /* Get the owner of the child so I can warn if it's not mine. If the
4792        * process doesn't exist or I don't have the privs to look at it,
4793        * I can go home early.
4794        */
4795       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4796       if (sts & 1) sts = jpi_iosb[0];
4797       if (!(sts & 1)) {
4798         switch (sts) {
4799             case SS$_NONEXPR:
4800                 set_errno(ECHILD);
4801                 break;
4802             case SS$_NOPRIV:
4803                 set_errno(EACCES);
4804                 break;
4805             default:
4806                 _ckvmssts(sts);
4807         }
4808         set_vaxc_errno(sts);
4809         return -1;
4810       }
4811
4812       if (ckWARN(WARN_EXEC)) {
4813         /* remind folks they are asking for non-standard waitpid behavior */
4814         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4815         if (ownerpid != mypid)
4816           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4817                       "waitpid: process %x is not a child of process %x",
4818                       pid,mypid);
4819       }
4820
4821       /* simply check on it once a second until it's not there anymore. */
4822
4823       _ckvmssts(sys$bintim(&intdsc,interval));
4824       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4825             _ckvmssts(sys$schdwk(0,0,interval,0));
4826             _ckvmssts(sys$hiber());
4827       }
4828       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4829
4830       _ckvmssts(sts);
4831       return pid;
4832     }
4833 }  /* end of waitpid() */
4834 /*}}}*/
4835 /*}}}*/
4836 /*}}}*/
4837
4838 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4839 char *
4840 my_gconvert(double val, int ndig, int trail, char *buf)
4841 {
4842   static char __gcvtbuf[DBL_DIG+1];
4843   char *loc;
4844
4845   loc = buf ? buf : __gcvtbuf;
4846
4847   if (val) {
4848     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4849     return gcvt(val,ndig,loc);
4850   }
4851   else {
4852     loc[0] = '0'; loc[1] = '\0';
4853     return loc;
4854   }
4855
4856 }
4857 /*}}}*/
4858
4859 #if !defined(NAML$C_MAXRSS)
4860 static int
4861 rms_free_search_context(struct FAB * fab)
4862 {
4863     struct NAM * nam;
4864
4865     nam = fab->fab$l_nam;
4866     nam->nam$b_nop |= NAM$M_SYNCHK;
4867     nam->nam$l_rlf = NULL;
4868     fab->fab$b_dns = 0;
4869     return sys$parse(fab, NULL, NULL);
4870 }
4871
4872 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4873 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4874 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4875 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4876 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4877 #define rms_nam_esll(nam) nam.nam$b_esl
4878 #define rms_nam_esl(nam) nam.nam$b_esl
4879 #define rms_nam_name(nam) nam.nam$l_name
4880 #define rms_nam_namel(nam) nam.nam$l_name
4881 #define rms_nam_type(nam) nam.nam$l_type
4882 #define rms_nam_typel(nam) nam.nam$l_type
4883 #define rms_nam_ver(nam) nam.nam$l_ver
4884 #define rms_nam_verl(nam) nam.nam$l_ver
4885 #define rms_nam_rsll(nam) nam.nam$b_rsl
4886 #define rms_nam_rsl(nam) nam.nam$b_rsl
4887 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4888 #define rms_set_fna(fab, nam, name, size) \
4889         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4890 #define rms_get_fna(fab, nam) fab.fab$l_fna
4891 #define rms_set_dna(fab, nam, name, size) \
4892         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4893 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4894 #define rms_set_esa(nam, name, size) \
4895         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4896 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4897         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4898 #define rms_set_rsa(nam, name, size) \
4899         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4900 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4901         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4902 #define rms_nam_name_type_l_size(nam) \
4903         (nam.nam$b_name + nam.nam$b_type)
4904 #else
4905 static int
4906 rms_free_search_context(struct FAB * fab)
4907 {
4908     struct NAML * nam;
4909
4910     nam = fab->fab$l_naml;
4911     nam->naml$b_nop |= NAM$M_SYNCHK;
4912     nam->naml$l_rlf = NULL;
4913     nam->naml$l_long_defname_size = 0;
4914
4915     fab->fab$b_dns = 0;
4916     return sys$parse(fab, NULL, NULL);
4917 }
4918
4919 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4920 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4921 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4922 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4923 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4924 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4925 #define rms_nam_esl(nam) nam.naml$b_esl
4926 #define rms_nam_name(nam) nam.naml$l_name
4927 #define rms_nam_namel(nam) nam.naml$l_long_name
4928 #define rms_nam_type(nam) nam.naml$l_type
4929 #define rms_nam_typel(nam) nam.naml$l_long_type
4930 #define rms_nam_ver(nam) nam.naml$l_ver
4931 #define rms_nam_verl(nam) nam.naml$l_long_ver
4932 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4933 #define rms_nam_rsl(nam) nam.naml$b_rsl
4934 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4935 #define rms_set_fna(fab, nam, name, size) \
4936         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4937         nam.naml$l_long_filename_size = size; \
4938         nam.naml$l_long_filename = name;}
4939 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4940 #define rms_set_dna(fab, nam, name, size) \
4941         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4942         nam.naml$l_long_defname_size = size; \
4943         nam.naml$l_long_defname = name; }
4944 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4945 #define rms_set_esa(nam, name, size) \
4946         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4947         nam.naml$l_long_expand_alloc = size; \
4948         nam.naml$l_long_expand = name; }
4949 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4950         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4951         nam.naml$l_long_expand = l_name; \
4952         nam.naml$l_long_expand_alloc = l_size; }
4953 #define rms_set_rsa(nam, name, size) \
4954         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4955         nam.naml$l_long_result = name; \
4956         nam.naml$l_long_result_alloc = size; }
4957 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4958         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4959         nam.naml$l_long_result = l_name; \
4960         nam.naml$l_long_result_alloc = l_size; }
4961 #define rms_nam_name_type_l_size(nam) \
4962         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4963 #endif
4964
4965
4966 /* rms_erase
4967  * The CRTL for 8.3 and later can create symbolic links in any mode,
4968  * however in 8.3 the unlink/remove/delete routines will only properly handle
4969  * them if one of the PCP modes is active.
4970  */
4971 static int
4972 rms_erase(const char * vmsname)
4973 {
4974   int status;
4975   struct FAB myfab = cc$rms_fab;
4976   rms_setup_nam(mynam);
4977
4978   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4979   rms_bind_fab_nam(myfab, mynam);
4980
4981 #ifdef NAML$M_OPEN_SPECIAL
4982   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4983 #endif
4984
4985   status = sys$erase(&myfab, 0, 0);
4986
4987   return status;
4988 }
4989
4990
4991 static int
4992 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4993                     const struct dsc$descriptor_s * vms_dst_dsc,
4994                     unsigned long flags)
4995 {
4996     /*  VMS and UNIX handle file permissions differently and the
4997      * the same ACL trick may be needed for renaming files,
4998      * especially if they are directories.
4999      */
5000
5001    /* todo: get kill_file and rename to share common code */
5002    /* I can not find online documentation for $change_acl
5003     * it appears to be replaced by $set_security some time ago */
5004
5005     const unsigned int access_mode = 0;
5006     $DESCRIPTOR(obj_file_dsc,"FILE");
5007     char *vmsname;
5008     char *rslt;
5009     unsigned long int jpicode = JPI$_UIC;
5010     int aclsts, fndsts, rnsts = -1;
5011     unsigned int ctx = 0;
5012     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5013     struct dsc$descriptor_s * clean_dsc;
5014
5015     struct myacedef {
5016         unsigned char myace$b_length;
5017         unsigned char myace$b_type;
5018         unsigned short int myace$w_flags;
5019         unsigned long int myace$l_access;
5020         unsigned long int myace$l_ident;
5021     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
5022              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
5023              0},
5024              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
5025
5026     struct item_list_3
5027         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
5028                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
5029                       {0,0,0,0}},
5030         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
5031         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
5032                      {0,0,0,0}};
5033
5034
5035     /* Expand the input spec using RMS, since we do not want to put
5036      * ACLs on the target of a symbolic link */
5037     vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
5038     if (vmsname == NULL)
5039         return SS$_INSFMEM;
5040
5041     rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
5042                         vmsname,
5043                         PERL_RMSEXPAND_M_SYMLINK);
5044     if (rslt == NULL) {
5045         PerlMem_free(vmsname);
5046         return SS$_INSFMEM;
5047     }
5048
5049     /* So we get our own UIC to use as a rights identifier,
5050      * and the insert an ACE at the head of the ACL which allows us
5051      * to delete the file.
5052      */
5053     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
5054
5055     fildsc.dsc$w_length = strlen(vmsname);
5056     fildsc.dsc$a_pointer = vmsname;
5057     ctx = 0;
5058     newace.myace$l_ident = oldace.myace$l_ident;
5059     rnsts = SS$_ABORT;
5060
5061     /* Grab any existing ACEs with this identifier in case we fail */
5062     clean_dsc = &fildsc;
5063     aclsts = fndsts = sys$get_security(&obj_file_dsc,
5064                                &fildsc,
5065                                NULL,
5066                                OSS$M_WLOCK,
5067                                findlst,
5068                                &ctx,
5069                                &access_mode);
5070
5071     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
5072         /* Add the new ACE . . . */
5073
5074         /* if the sys$get_security succeeded, then ctx is valid, and the
5075          * object/file descriptors will be ignored.  But otherwise they
5076          * are needed
5077          */
5078         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
5079                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
5080         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5081             set_errno(EVMSERR);
5082             set_vaxc_errno(aclsts);
5083             PerlMem_free(vmsname);
5084             return aclsts;
5085         }
5086
5087         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5088                                 NULL, NULL,
5089                                 &flags,
5090                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5091
5092         if ($VMS_STATUS_SUCCESS(rnsts)) {
5093             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5094         }
5095
5096         /* Put things back the way they were. */
5097         ctx = 0;
5098         aclsts = sys$get_security(&obj_file_dsc,
5099                                   clean_dsc,
5100                                   NULL,
5101                                   OSS$M_WLOCK,
5102                                   findlst,
5103                                   &ctx,
5104                                   &access_mode);
5105
5106         if ($VMS_STATUS_SUCCESS(aclsts)) {
5107         int sec_flags;
5108
5109             sec_flags = 0;
5110             if (!$VMS_STATUS_SUCCESS(fndsts))
5111                 sec_flags = OSS$M_RELCTX;
5112
5113             /* Get rid of the new ACE */
5114             aclsts = sys$set_security(NULL, NULL, NULL,
5115                                   sec_flags, dellst, &ctx, &access_mode);
5116
5117             /* If there was an old ACE, put it back */
5118             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5119                 addlst[0].bufadr = &oldace;
5120                 aclsts = sys$set_security(NULL, NULL, NULL,
5121                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
5122                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5123                     set_errno(EVMSERR);
5124                     set_vaxc_errno(aclsts);
5125                     rnsts = aclsts;
5126                 }
5127             } else {
5128             int aclsts2;
5129
5130                 /* Try to clear the lock on the ACL list */
5131                 aclsts2 = sys$set_security(NULL, NULL, NULL,
5132                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
5133
5134                 /* Rename errors are most important */
5135                 if (!$VMS_STATUS_SUCCESS(rnsts))
5136                     aclsts = rnsts;
5137                 set_errno(EVMSERR);
5138                 set_vaxc_errno(aclsts);
5139                 rnsts = aclsts;
5140             }
5141         }
5142         else {
5143             if (aclsts != SS$_ACLEMPTY)
5144                 rnsts = aclsts;
5145         }
5146     }
5147     else
5148         rnsts = fndsts;
5149
5150     PerlMem_free(vmsname);
5151     return rnsts;
5152 }
5153
5154
5155 /*{{{int rename(const char *, const char * */
5156 /* Not exactly what X/Open says to do, but doing it absolutely right
5157  * and efficiently would require a lot more work.  This should be close
5158  * enough to pass all but the most strict X/Open compliance test.
5159  */
5160 int
5161 Perl_rename(pTHX_ const char *src, const char * dst)
5162 {
5163     int retval;
5164     int pre_delete = 0;
5165     int src_sts;
5166     int dst_sts;
5167     Stat_t src_st;
5168     Stat_t dst_st;
5169
5170     /* Validate the source file */
5171     src_sts = flex_lstat(src, &src_st);
5172     if (src_sts != 0) {
5173
5174         /* No source file or other problem */
5175         return src_sts;
5176     }
5177     if (src_st.st_devnam[0] == 0)  {
5178         /* This may be possible so fail if it is seen. */
5179         errno = EIO;
5180         return -1;
5181     }
5182
5183     dst_sts = flex_lstat(dst, &dst_st);
5184     if (dst_sts == 0) {
5185
5186         if (dst_st.st_dev != src_st.st_dev) {
5187             /* Must be on the same device */
5188             errno = EXDEV;
5189             return -1;
5190         }
5191
5192         /* VMS_INO_T_COMPARE is true if the inodes are different
5193          * to match the output of memcmp
5194          */
5195
5196         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5197             /* That was easy, the files are the same! */
5198             return 0;
5199         }
5200
5201         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5202             /* If source is a directory, so must be dest */
5203                 errno = EISDIR;
5204                 return -1;
5205         }
5206
5207     }
5208
5209
5210     if ((dst_sts == 0) &&
5211         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5212
5213         /* We have issues here if vms_unlink_all_versions is set
5214          * If the destination exists, and is not a directory, then
5215          * we must delete in advance.
5216          *
5217          * If the src is a directory, then we must always pre-delete
5218          * the destination.
5219          *
5220          * If we successfully delete the dst in advance, and the rename fails
5221          * X/Open requires that errno be EIO.
5222          *
5223          */
5224
5225         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5226             int d_sts;
5227             d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam,
5228                                      S_ISDIR(dst_st.st_mode));
5229
5230            /* Need to delete all versions ? */
5231            if ((d_sts == 0) && (vms_unlink_all_versions == 1)) {
5232                 int i = 0;
5233
5234                 while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) {
5235                     d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 0);
5236                     if (d_sts != 0)
5237                         break;
5238                     i++;
5239
5240                     /* Make sure that we do not loop forever */
5241                     if (i > 32767) {
5242                         errno = EIO;
5243                         d_sts = -1;
5244                         break;
5245                     }
5246                 }
5247            }
5248
5249             if (d_sts != 0)
5250                 return d_sts;
5251
5252             /* We killed the destination, so only errno now is EIO */
5253             pre_delete = 1;
5254         }
5255     }
5256
5257     /* Originally the idea was to call the CRTL rename() and only
5258      * try the lib$rename_file if it failed.
5259      * It turns out that there are too many variants in what the
5260      * the CRTL rename might do, so only use lib$rename_file
5261      */
5262     retval = -1;
5263
5264     {
5265         /* Is the source and dest both in VMS format */
5266         /* if the source is a directory, then need to fileify */
5267         /*  and dest must be a directory or non-existent. */
5268
5269         char * vms_dst;
5270         int sts;
5271         char * ret_str;
5272         unsigned long flags;
5273         struct dsc$descriptor_s old_file_dsc;
5274         struct dsc$descriptor_s new_file_dsc;
5275
5276         /* We need to modify the src and dst depending
5277          * on if one or more of them are directories.
5278          */
5279
5280         vms_dst = (char *)PerlMem_malloc(VMS_MAXRSS);
5281         if (vms_dst == NULL)
5282             _ckvmssts_noperl(SS$_INSFMEM);
5283
5284         if (S_ISDIR(src_st.st_mode)) {
5285         char * ret_str;
5286         char * vms_dir_file;
5287
5288             vms_dir_file = (char *)PerlMem_malloc(VMS_MAXRSS);
5289             if (vms_dir_file == NULL)
5290                 _ckvmssts_noperl(SS$_INSFMEM);
5291
5292             /* If the dest is a directory, we must remove it */
5293             if (dst_sts == 0) {
5294                 int d_sts;
5295                 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1);
5296                 if (d_sts != 0) {
5297                     PerlMem_free(vms_dst);
5298                     errno = EIO;
5299                     return d_sts;
5300                 }
5301
5302                 pre_delete = 1;
5303             }
5304
5305            /* The dest must be a VMS file specification */
5306            ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5307            if (ret_str == NULL) {
5308                 PerlMem_free(vms_dst);
5309                 errno = EIO;
5310                 return -1;
5311            }
5312
5313             /* The source must be a file specification */
5314             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5315             if (ret_str == NULL) {
5316                 PerlMem_free(vms_dst);
5317                 PerlMem_free(vms_dir_file);
5318                 errno = EIO;
5319                 return -1;
5320             }
5321             PerlMem_free(vms_dst);
5322             vms_dst = vms_dir_file;
5323
5324         } else {
5325             /* File to file or file to new dir */
5326
5327             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5328                 /* VMS pathify a dir target */
5329                 ret_str = int_tovmspath(dst, vms_dst, NULL);
5330                 if (ret_str == NULL) {
5331                     PerlMem_free(vms_dst);
5332                     errno = EIO;
5333                     return -1;
5334                 }
5335             } else {
5336                 char * v_spec, * r_spec, * d_spec, * n_spec;
5337                 char * e_spec, * vs_spec;
5338                 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5339
5340                 /* fileify a target VMS file specification */
5341                 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5342                 if (ret_str == NULL) {
5343                     PerlMem_free(vms_dst);
5344                     errno = EIO;
5345                     return -1;
5346                 }
5347
5348                 sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len,
5349                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5350                              &e_len, &vs_spec, &vs_len);
5351                 if (sts == 0) {
5352                      if (e_len == 0) {
5353                          /* Get rid of the version */
5354                          if (vs_len != 0) {
5355                              *vs_spec = '\0';
5356                          }
5357                          /* Need to specify a '.' so that the extension */
5358                          /* is not inherited */
5359                          strcat(vms_dst,".");
5360                      }
5361                 }
5362             }
5363         }
5364
5365         old_file_dsc.dsc$a_pointer = src_st.st_devnam;
5366         old_file_dsc.dsc$w_length = strlen(src_st.st_devnam);
5367         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5368         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5369
5370         new_file_dsc.dsc$a_pointer = vms_dst;
5371         new_file_dsc.dsc$w_length = strlen(vms_dst);
5372         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5373         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5374
5375         flags = 0;
5376 #if defined(NAML$C_MAXRSS)
5377         flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5378 #endif
5379
5380         sts = lib$rename_file(&old_file_dsc,
5381                               &new_file_dsc,
5382                               NULL, NULL,
5383                               &flags,
5384                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5385         if (!$VMS_STATUS_SUCCESS(sts)) {
5386
5387            /* We could have failed because VMS style permissions do not
5388             * permit renames that UNIX will allow.  Just like the hack
5389             * in for kill_file.
5390             */
5391            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5392         }
5393
5394         PerlMem_free(vms_dst);
5395         if (!$VMS_STATUS_SUCCESS(sts)) {
5396             errno = EIO;
5397             return -1;
5398         }
5399         retval = 0;
5400     }
5401
5402     if (vms_unlink_all_versions) {
5403         /* Now get rid of any previous versions of the source file that
5404          * might still exist
5405          */
5406         int i = 0;
5407         dSAVEDERRNO;
5408         SAVE_ERRNO;
5409         src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5410                                    S_ISDIR(src_st.st_mode));
5411         while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) {
5412              src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5413                                        S_ISDIR(src_st.st_mode));
5414              if (src_sts != 0)
5415                  break;
5416              i++;
5417
5418              /* Make sure that we do not loop forever */
5419              if (i > 32767) {
5420                  src_sts = -1;
5421                  break;
5422              }
5423         }
5424         RESTORE_ERRNO;
5425     }
5426
5427     /* We deleted the destination, so must force the error to be EIO */
5428     if ((retval != 0) && (pre_delete != 0))
5429         errno = EIO;
5430
5431     return retval;
5432 }
5433 /*}}}*/
5434
5435
5436 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5437 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5438  * to expand file specification.  Allows for a single default file
5439  * specification and a simple mask of options.  If outbuf is non-NULL,
5440  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5441  * the resultant file specification is placed.  If outbuf is NULL, the
5442  * resultant file specification is placed into a static buffer.
5443  * The third argument, if non-NULL, is taken to be a default file
5444  * specification string.  The fourth argument is unused at present.
5445  * rmesexpand() returns the address of the resultant string if
5446  * successful, and NULL on error.
5447  *
5448  * New functionality for previously unused opts value:
5449  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5450  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5451  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5452  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5453  */
5454 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5455
5456 static char *
5457 int_rmsexpand
5458    (const char *filespec,
5459     char *outbuf,
5460     const char *defspec,
5461     unsigned opts,
5462     int * fs_utf8,
5463     int * dfs_utf8)
5464 {
5465   char * ret_spec;
5466   const char * in_spec;
5467   char * spec_buf;
5468   const char * def_spec;
5469   char * vmsfspec, *vmsdefspec;
5470   char * esa;
5471   char * esal = NULL;
5472   char * outbufl;
5473   struct FAB myfab = cc$rms_fab;
5474   rms_setup_nam(mynam);
5475   STRLEN speclen;
5476   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5477   int sts;
5478
5479   /* temp hack until UTF8 is actually implemented */
5480   if (fs_utf8 != NULL)
5481     *fs_utf8 = 0;
5482
5483   if (!filespec || !*filespec) {
5484     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5485     return NULL;
5486   }
5487
5488   vmsfspec = NULL;
5489   vmsdefspec = NULL;
5490   outbufl = NULL;
5491
5492   in_spec = filespec;
5493   isunix = 0;
5494   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5495       char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5496       int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5497
5498       /* If this is a UNIX file spec, convert it to VMS */
5499       sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5500                            &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5501                            &e_len, &vs_spec, &vs_len);
5502       if (sts != 0) {
5503           isunix = 1;
5504           char * ret_spec;
5505
5506           vmsfspec = (char *)PerlMem_malloc(VMS_MAXRSS);
5507           if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5508           ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5509           if (ret_spec == NULL) {
5510               PerlMem_free(vmsfspec);
5511               return NULL;
5512           }
5513           in_spec = (const char *)vmsfspec;
5514
5515           /* Unless we are forcing to VMS format, a UNIX input means
5516            * UNIX output, and that requires long names to be used
5517            */
5518           if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5519 #if defined(NAML$C_MAXRSS)
5520               opts |= PERL_RMSEXPAND_M_LONG;
5521 #else
5522               NOOP;
5523 #endif
5524           else
5525               isunix = 0;
5526       }
5527
5528   }
5529
5530   rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
5531   rms_bind_fab_nam(myfab, mynam);
5532
5533   /* Process the default file specification if present */
5534   def_spec = defspec;
5535   if (defspec && *defspec) {
5536     int t_isunix;
5537     t_isunix = is_unix_filespec(defspec);
5538     if (t_isunix) {
5539       vmsdefspec = (char *)PerlMem_malloc(VMS_MAXRSS);
5540       if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5541       ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5542
5543       if (ret_spec == NULL) {
5544           /* Clean up and bail */
5545           PerlMem_free(vmsdefspec);
5546           if (vmsfspec != NULL)
5547               PerlMem_free(vmsfspec);
5548               return NULL;
5549           }
5550           def_spec = (const char *)vmsdefspec;
5551       }
5552       rms_set_dna(myfab, mynam,
5553                   (char *)def_spec, strlen(def_spec)); /* cast ok */
5554   }
5555
5556   /* Now we need the expansion buffers */
5557   esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
5558   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5559 #if defined(NAML$C_MAXRSS)
5560   esal = (char *)PerlMem_malloc(VMS_MAXRSS);
5561   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5562 #endif
5563   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5564
5565   /* If a NAML block is used RMS always writes to the long and short
5566    * addresses unless you suppress the short name.
5567    */
5568 #if defined(NAML$C_MAXRSS)
5569   outbufl = (char *)PerlMem_malloc(VMS_MAXRSS);
5570   if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5571 #endif
5572    rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5573
5574 #ifdef NAM$M_NO_SHORT_UPCASE
5575   if (decc_efs_case_preserve)
5576     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5577 #endif
5578
5579    /* We may not want to follow symbolic links */
5580 #ifdef NAML$M_OPEN_SPECIAL
5581   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5582     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5583 #endif
5584
5585   /* First attempt to parse as an existing file */
5586   retsts = sys$parse(&myfab,0,0);
5587   if (!(retsts & STS$K_SUCCESS)) {
5588
5589     /* Could not find the file, try as syntax only if error is not fatal */
5590     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5591     if (retsts == RMS$_DNF ||
5592         retsts == RMS$_DIR ||
5593         retsts == RMS$_DEV ||
5594         retsts == RMS$_PRV) {
5595       retsts = sys$parse(&myfab,0,0);
5596       if (retsts & STS$K_SUCCESS) goto int_expanded;
5597     }
5598
5599      /* Still could not parse the file specification */
5600     /*----------------------------------------------*/
5601     sts = rms_free_search_context(&myfab); /* Free search context */
5602     if (vmsdefspec != NULL)
5603         PerlMem_free(vmsdefspec);
5604     if (vmsfspec != NULL)
5605         PerlMem_free(vmsfspec);
5606     if (outbufl != NULL)
5607         PerlMem_free(outbufl);
5608     PerlMem_free(esa);
5609     if (esal != NULL)
5610         PerlMem_free(esal);
5611     set_vaxc_errno(retsts);
5612     if      (retsts == RMS$_PRV) set_errno(EACCES);
5613     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5614     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5615     else                         set_errno(EVMSERR);
5616     return NULL;
5617   }
5618   retsts = sys$search(&myfab,0,0);
5619   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5620     sts = rms_free_search_context(&myfab); /* Free search context */
5621     if (vmsdefspec != NULL)
5622         PerlMem_free(vmsdefspec);
5623     if (vmsfspec != NULL)
5624         PerlMem_free(vmsfspec);
5625     if (outbufl != NULL)
5626         PerlMem_free(outbufl);
5627     PerlMem_free(esa);
5628     if (esal != NULL)
5629         PerlMem_free(esal);
5630     set_vaxc_errno(retsts);
5631     if      (retsts == RMS$_PRV) set_errno(EACCES);
5632     else                         set_errno(EVMSERR);
5633     return NULL;
5634   }
5635
5636   /* If the input filespec contained any lowercase characters,
5637    * downcase the result for compatibility with Unix-minded code. */
5638 int_expanded:
5639   if (!decc_efs_case_preserve) {
5640     char * tbuf;
5641     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5642       if (islower(*tbuf)) { haslower = 1; break; }
5643   }
5644
5645    /* Is a long or a short name expected */
5646   /*------------------------------------*/
5647   spec_buf = NULL;
5648 #if defined(NAML$C_MAXRSS)
5649   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5650     if (rms_nam_rsll(mynam)) {
5651         spec_buf = outbufl;
5652         speclen = rms_nam_rsll(mynam);
5653     }
5654     else {
5655         spec_buf = esal; /* Not esa */
5656         speclen = rms_nam_esll(mynam);
5657     }
5658   }
5659   else {
5660 #endif
5661     if (rms_nam_rsl(mynam)) {
5662         spec_buf = outbuf;
5663         speclen = rms_nam_rsl(mynam);
5664     }
5665     else {
5666         spec_buf = esa; /* Not esal */
5667         speclen = rms_nam_esl(mynam);
5668     }
5669 #if defined(NAML$C_MAXRSS)
5670   }
5671 #endif
5672   spec_buf[speclen] = '\0';
5673
5674   /* Trim off null fields added by $PARSE
5675    * If type > 1 char, must have been specified in original or default spec
5676    * (not true for version; $SEARCH may have added version of existing file).
5677    */
5678   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5679   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5680     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5681              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5682   }
5683   else {
5684     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5685              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5686   }
5687   if (trimver || trimtype) {
5688     if (defspec && *defspec) {
5689       char *defesal = NULL;
5690       char *defesa = NULL;
5691       defesa = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5692       if (defesa != NULL) {
5693         struct FAB deffab = cc$rms_fab;
5694 #if defined(NAML$C_MAXRSS)
5695         defesal = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5696         if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5697 #endif
5698         rms_setup_nam(defnam);
5699
5700         rms_bind_fab_nam(deffab, defnam);
5701
5702         /* Cast ok */
5703         rms_set_fna
5704             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5705
5706         /* RMS needs the esa/esal as a work area if wildcards are involved */
5707         rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5708
5709         rms_clear_nam_nop(defnam);
5710         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5711 #ifdef NAM$M_NO_SHORT_UPCASE
5712         if (decc_efs_case_preserve)
5713           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5714 #endif
5715 #ifdef NAML$M_OPEN_SPECIAL
5716         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5717           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5718 #endif
5719         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5720           if (trimver) {
5721              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5722           }
5723           if (trimtype) {
5724             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5725           }
5726         }
5727         if (defesal != NULL)
5728             PerlMem_free(defesal);
5729         PerlMem_free(defesa);
5730       } else {
5731           _ckvmssts_noperl(SS$_INSFMEM);
5732       }
5733     }
5734     if (trimver) {
5735       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5736         if (*(rms_nam_verl(mynam)) != '\"')
5737           speclen = rms_nam_verl(mynam) - spec_buf;
5738       }
5739       else {
5740         if (*(rms_nam_ver(mynam)) != '\"')
5741           speclen = rms_nam_ver(mynam) - spec_buf;
5742       }
5743     }
5744     if (trimtype) {
5745       /* If we didn't already trim version, copy down */
5746       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5747         if (speclen > rms_nam_verl(mynam) - spec_buf)
5748           memmove
5749            (rms_nam_typel(mynam),
5750             rms_nam_verl(mynam),
5751             speclen - (rms_nam_verl(mynam) - spec_buf));
5752           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5753       }
5754       else {
5755         if (speclen > rms_nam_ver(mynam) - spec_buf)
5756           memmove
5757            (rms_nam_type(mynam),
5758             rms_nam_ver(mynam),
5759             speclen - (rms_nam_ver(mynam) - spec_buf));
5760           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5761       }
5762     }
5763   }
5764
5765    /* Done with these copies of the input files */
5766   /*-------------------------------------------*/
5767   if (vmsfspec != NULL)
5768         PerlMem_free(vmsfspec);
5769   if (vmsdefspec != NULL)
5770         PerlMem_free(vmsdefspec);
5771
5772   /* If we just had a directory spec on input, $PARSE "helpfully"
5773    * adds an empty name and type for us */
5774 #if defined(NAML$C_MAXRSS)
5775   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5776     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5777         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5778         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5779       speclen = rms_nam_namel(mynam) - spec_buf;
5780   }
5781   else
5782 #endif
5783   {
5784     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5785         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5786         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5787       speclen = rms_nam_name(mynam) - spec_buf;
5788   }
5789
5790   /* Posix format specifications must have matching quotes */
5791   if (speclen < (VMS_MAXRSS - 1)) {
5792     if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5793       if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5794         spec_buf[speclen] = '\"';
5795         speclen++;
5796       }
5797     }
5798   }
5799   spec_buf[speclen] = '\0';
5800   if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
5801
5802   /* Have we been working with an expanded, but not resultant, spec? */
5803   /* Also, convert back to Unix syntax if necessary. */
5804   {
5805   int rsl;
5806
5807 #if defined(NAML$C_MAXRSS)
5808     if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5809       rsl = rms_nam_rsll(mynam);
5810     } else
5811 #endif
5812     {
5813       rsl = rms_nam_rsl(mynam);
5814     }
5815     if (!rsl) {
5816       /* rsl is not present, it means that spec_buf is either */
5817       /* esa or esal, and needs to be copied to outbuf */
5818       /* convert to Unix if desired */
5819       if (isunix) {
5820         ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5821       } else {
5822         /* VMS file specs are not in UTF-8 */
5823         if (fs_utf8 != NULL)
5824             *fs_utf8 = 0;
5825         my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
5826         ret_spec = outbuf;
5827       }
5828     }
5829     else {
5830       /* Now spec_buf is either outbuf or outbufl */
5831       /* We need the result into outbuf */
5832       if (isunix) {
5833            /* If we need this in UNIX, then we need another buffer */
5834            /* to keep things in order */
5835            char * src;
5836            char * new_src = NULL;
5837            if (spec_buf == outbuf) {
5838                new_src = (char *)PerlMem_malloc(VMS_MAXRSS);
5839                my_strlcpy(new_src, spec_buf, VMS_MAXRSS);
5840            } else {
5841                src = spec_buf;
5842            }
5843            ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5844            if (new_src) {
5845                PerlMem_free(new_src);
5846            }
5847       } else {
5848            /* VMS file specs are not in UTF-8 */
5849            if (fs_utf8 != NULL)
5850                *fs_utf8 = 0;
5851
5852            /* Copy the buffer if needed */
5853            if (outbuf != spec_buf)
5854                my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
5855            ret_spec = outbuf;
5856       }
5857     }
5858   }
5859
5860   /* Need to clean up the search context */
5861   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5862   sts = rms_free_search_context(&myfab); /* Free search context */
5863
5864   /* Clean up the extra buffers */
5865   if (esal != NULL)
5866       PerlMem_free(esal);
5867   PerlMem_free(esa);
5868   if (outbufl != NULL)
5869      PerlMem_free(outbufl);
5870
5871   /* Return the result */
5872   return ret_spec;
5873 }
5874
5875 /* Common simple case - Expand an already VMS spec */
5876 static char *
5877 int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5878     opts |= PERL_RMSEXPAND_M_VMS_IN;
5879     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5880 }
5881
5882 /* Common simple case - Expand to a VMS spec */
5883 static char *
5884 int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5885     opts |= PERL_RMSEXPAND_M_VMS;
5886     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5887 }
5888
5889
5890 /* Entry point used by perl routines */
5891 static char *
5892 mp_do_rmsexpand
5893    (pTHX_ const char *filespec,
5894     char *outbuf,
5895     int ts,
5896     const char *defspec,
5897     unsigned opts,
5898     int * fs_utf8,
5899     int * dfs_utf8)
5900 {
5901     static char __rmsexpand_retbuf[VMS_MAXRSS];
5902     char * expanded, *ret_spec, *ret_buf;
5903
5904     expanded = NULL;
5905     ret_buf = outbuf;
5906     if (ret_buf == NULL) {
5907         if (ts) {
5908             Newx(expanded, VMS_MAXRSS, char);
5909             if (expanded == NULL)
5910                 _ckvmssts(SS$_INSFMEM);
5911             ret_buf = expanded;
5912         } else {
5913             ret_buf = __rmsexpand_retbuf;
5914         }
5915     }
5916
5917
5918     ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
5919                              opts, fs_utf8,  dfs_utf8);
5920
5921     if (ret_spec == NULL) {
5922        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
5923        if (expanded)
5924            Safefree(expanded);
5925     }
5926
5927     return ret_spec;
5928 }
5929 /*}}}*/
5930 /* External entry points */
5931 char *
5932 Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5933 {
5934     return do_rmsexpand(spec, buf, 0, def, opt, NULL, NULL);
5935 }
5936
5937 char *
5938 Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5939 {
5940     return do_rmsexpand(spec, buf, 1, def, opt, NULL, NULL);
5941 }
5942
5943 char *
5944 Perl_rmsexpand_utf8(pTHX_ const char *spec, char *buf, const char *def,
5945                     unsigned opt, int * fs_utf8, int * dfs_utf8)
5946 {
5947     return do_rmsexpand(spec, buf, 0, def, opt, fs_utf8, dfs_utf8);
5948 }
5949
5950 char *
5951 Perl_rmsexpand_utf8_ts(pTHX_ const char *spec, char *buf, const char *def,
5952                        unsigned opt, int * fs_utf8, int * dfs_utf8)
5953 {
5954     return do_rmsexpand(spec, buf, 1, def, opt, fs_utf8, dfs_utf8);
5955 }
5956
5957
5958 /*
5959 ** The following routines are provided to make life easier when
5960 ** converting among VMS-style and Unix-style directory specifications.
5961 ** All will take input specifications in either VMS or Unix syntax. On
5962 ** failure, all return NULL.  If successful, the routines listed below
5963 ** return a pointer to a buffer containing the appropriately
5964 ** reformatted spec (and, therefore, subsequent calls to that routine
5965 ** will clobber the result), while the routines of the same names with
5966 ** a _ts suffix appended will return a pointer to a mallocd string
5967 ** containing the appropriately reformatted spec.
5968 ** In all cases, only explicit syntax is altered; no check is made that
5969 ** the resulting string is valid or that the directory in question
5970 ** actually exists.
5971 **
5972 **   fileify_dirspec() - convert a directory spec into the name of the
5973 **     directory file (i.e. what you can stat() to see if it's a dir).
5974 **     The style (VMS or Unix) of the result is the same as the style
5975 **     of the parameter passed in.
5976 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5977 **     what you prepend to a filename to indicate what directory it's in).
5978 **     The style (VMS or Unix) of the result is the same as the style
5979 **     of the parameter passed in.
5980 **   tounixpath() - convert a directory spec into a Unix-style path.
5981 **   tovmspath() - convert a directory spec into a VMS-style path.
5982 **   tounixspec() - convert any file spec into a Unix-style file spec.
5983 **   tovmsspec() - convert any file spec into a VMS-style spec.
5984 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5985 **
5986 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5987 ** Permission is given to distribute this code as part of the Perl
5988 ** standard distribution under the terms of the GNU General Public
5989 ** License or the Perl Artistic License.  Copies of each may be
5990 ** found in the Perl standard distribution.
5991  */
5992
5993 /*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5994 static char *
5995 int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
5996 {
5997     unsigned long int dirlen, retlen, hasfilename = 0;
5998     char *cp1, *cp2, *lastdir;
5999     char *trndir, *vmsdir;
6000     unsigned short int trnlnm_iter_count;
6001     int sts;
6002     if (utf8_fl != NULL)
6003         *utf8_fl = 0;
6004
6005     if (!dir || !*dir) {
6006       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6007     }
6008     dirlen = strlen(dir);
6009     while (dirlen && dir[dirlen-1] == '/') --dirlen;
6010     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
6011       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
6012         dir = "/sys$disk";
6013         dirlen = 9;
6014       }
6015       else
6016         dirlen = 1;
6017     }
6018     if (dirlen > (VMS_MAXRSS - 1)) {
6019       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
6020       return NULL;
6021     }
6022     trndir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
6023     if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6024     if (!strpbrk(dir+1,"/]>:")  &&
6025         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
6026       strcpy(trndir,*dir == '/' ? dir + 1: dir);
6027       trnlnm_iter_count = 0;
6028       while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
6029         trnlnm_iter_count++;
6030         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6031       }
6032       dirlen = strlen(trndir);
6033     }
6034     else {
6035       memcpy(trndir, dir, dirlen);
6036       trndir[dirlen] = '\0';
6037     }
6038
6039     /* At this point we are done with *dir and use *trndir which is a
6040      * copy that can be modified.  *dir must not be modified.
6041      */
6042
6043     /* If we were handed a rooted logical name or spec, treat it like a
6044      * simple directory, so that
6045      *    $ Define myroot dev:[dir.]
6046      *    ... do_fileify_dirspec("myroot",buf,1) ...
6047      * does something useful.
6048      */
6049     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
6050       trndir[--dirlen] = '\0';
6051       trndir[dirlen-1] = ']';
6052     }
6053     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
6054       trndir[--dirlen] = '\0';
6055       trndir[dirlen-1] = '>';
6056     }
6057
6058     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
6059       /* If we've got an explicit filename, we can just shuffle the string. */
6060       if (*(cp1+1)) hasfilename = 1;
6061       /* Similarly, we can just back up a level if we've got multiple levels
6062          of explicit directories in a VMS spec which ends with directories. */
6063       else {
6064         for (cp2 = cp1; cp2 > trndir; cp2--) {
6065           if (*cp2 == '.') {
6066             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
6067 /* fix-me, can not scan EFS file specs backward like this */
6068               *cp2 = *cp1; *cp1 = '\0';
6069               hasfilename = 1;
6070               break;
6071             }
6072           }
6073           if (*cp2 == '[' || *cp2 == '<') break;
6074         }
6075       }
6076     }
6077
6078     vmsdir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
6079     if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6080     cp1 = strpbrk(trndir,"]:>");
6081     if (cp1 && *(cp1+1) == ':')   /* DECNet node spec with :: */
6082         cp1 = strpbrk(cp1+2,"]:>");
6083
6084     if (hasfilename || !cp1) { /* filename present or not VMS */
6085
6086       if (trndir[0] == '.') {
6087         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
6088           PerlMem_free(trndir);
6089           PerlMem_free(vmsdir);
6090           return int_fileify_dirspec("[]", buf, NULL);
6091         }
6092         else if (trndir[1] == '.' &&
6093                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
6094           PerlMem_free(trndir);
6095           PerlMem_free(vmsdir);
6096           return int_fileify_dirspec("[-]", buf, NULL);
6097         }
6098       }
6099       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
6100         dirlen -= 1;                 /* to last element */
6101         lastdir = strrchr(trndir,'/');
6102       }
6103       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
6104         /* If we have "/." or "/..", VMSify it and let the VMS code
6105          * below expand it, rather than repeating the code to handle
6106          * relative components of a filespec here */
6107         do {
6108           if (*(cp1+2) == '.') cp1++;
6109           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
6110             char * ret_chr;
6111             if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
6112                 PerlMem_free(trndir);
6113                 PerlMem_free(vmsdir);
6114                 return NULL;
6115             }
6116             if (strchr(vmsdir,'/') != NULL) {
6117               /* If int_tovmsspec() returned it, it must have VMS syntax
6118                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
6119                * the time to check this here only so we avoid a recursion
6120                * loop; otherwise, gigo.
6121                */
6122               PerlMem_free(trndir);
6123               PerlMem_free(vmsdir);
6124               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
6125               return NULL;
6126             }
6127             if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6128                 PerlMem_free(trndir);
6129                 PerlMem_free(vmsdir);
6130                 return NULL;
6131             }
6132             ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6133             PerlMem_free(trndir);
6134             PerlMem_free(vmsdir);
6135             return ret_chr;
6136           }
6137           cp1++;
6138         } while ((cp1 = strstr(cp1,"/.")) != NULL);
6139         lastdir = strrchr(trndir,'/');
6140       }
6141       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
6142         char * ret_chr;
6143         /* Ditto for specs that end in an MFD -- let the VMS code
6144          * figure out whether it's a real device or a rooted logical. */
6145
6146         /* This should not happen any more.  Allowing the fake /000000
6147          * in a UNIX pathname causes all sorts of problems when trying
6148          * to run in UNIX emulation.  So the VMS to UNIX conversions
6149          * now remove the fake /000000 directories.
6150          */
6151
6152         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6153         if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6154             PerlMem_free(trndir);
6155             PerlMem_free(vmsdir);
6156             return NULL;
6157         }
6158         if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6159             PerlMem_free(trndir);
6160             PerlMem_free(vmsdir);
6161             return NULL;
6162         }
6163         ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6164         PerlMem_free(trndir);
6165         PerlMem_free(vmsdir);
6166         return ret_chr;
6167       }
6168       else {
6169
6170         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6171              !(lastdir = cp1 = strrchr(trndir,']')) &&
6172              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6173
6174         cp2 = strrchr(cp1,'.');
6175         if (cp2) {
6176             int e_len, vs_len = 0;
6177             int is_dir = 0;
6178             char * cp3;
6179             cp3 = strchr(cp2,';');
6180             e_len = strlen(cp2);
6181             if (cp3) {
6182                 vs_len = strlen(cp3);
6183                 e_len = e_len - vs_len;
6184             }
6185             is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6186             if (!is_dir) {
6187                 if (!decc_efs_charset) {
6188                     /* If this is not EFS, then not a directory */
6189                     PerlMem_free(trndir);
6190                     PerlMem_free(vmsdir);
6191                     set_errno(ENOTDIR);
6192                     set_vaxc_errno(RMS$_DIR);
6193                     return NULL;
6194                 }
6195             } else {
6196                 /* Ok, here we have an issue, technically if a .dir shows */
6197                 /* from inside a directory, then we should treat it as */
6198                 /* xxx^.dir.dir.  But we do not have that context at this */
6199                 /* point unless this is totally restructured, so we remove */
6200                 /* The .dir for now, and fix this better later */
6201                 dirlen = cp2 - trndir;
6202             }
6203             if (decc_efs_charset && !strchr(trndir,'/')) {
6204                 /* Dots are allowed in dir names, so escape them if input not in Unix syntax. */
6205                 char *cp4 = is_dir ? (cp2 - 1) : cp2;
6206
6207                 for (; cp4 > cp1; cp4--) {
6208                     if (*cp4 == '.') {
6209                         if ((cp4 - 1 > trndir) && (*(cp4 - 1) != '^')) {
6210                             memmove(cp4 + 1, cp4, trndir + dirlen - cp4 + 1);
6211                             *cp4 = '^';
6212                             dirlen++;
6213                         }
6214                     }
6215                 }
6216             }
6217         }
6218
6219       }
6220
6221       retlen = dirlen + 6;
6222       memcpy(buf, trndir, dirlen);
6223       buf[dirlen] = '\0';
6224
6225       /* We've picked up everything up to the directory file name.
6226          Now just add the type and version, and we're set. */
6227       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
6228           strcat(buf,".dir");
6229       else
6230           strcat(buf,".DIR");
6231       if (!decc_filename_unix_no_version)
6232           strcat(buf,";1");
6233       PerlMem_free(trndir);
6234       PerlMem_free(vmsdir);
6235       return buf;
6236     }
6237     else {  /* VMS-style directory spec */
6238
6239       char *esa, *esal, term, *cp;
6240       char *my_esa;
6241       int my_esa_len;
6242       unsigned long int cmplen, haslower = 0;
6243       struct FAB dirfab = cc$rms_fab;
6244       rms_setup_nam(savnam);
6245       rms_setup_nam(dirnam);
6246
6247       esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
6248       if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6249       esal = NULL;
6250 #if defined(NAML$C_MAXRSS)
6251       esal = (char *)PerlMem_malloc(VMS_MAXRSS);
6252       if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6253 #endif
6254       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6255       rms_bind_fab_nam(dirfab, dirnam);
6256       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6257       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6258 #ifdef NAM$M_NO_SHORT_UPCASE
6259       if (decc_efs_case_preserve)
6260         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6261 #endif
6262
6263       for (cp = trndir; *cp; cp++)
6264         if (islower(*cp)) { haslower = 1; break; }
6265       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6266         if ((dirfab.fab$l_sts == RMS$_DIR) ||
6267             (dirfab.fab$l_sts == RMS$_DNF) ||
6268             (dirfab.fab$l_sts == RMS$_PRV)) {
6269             rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6270             sts = sys$parse(&dirfab);
6271         }
6272         if (!sts) {
6273           PerlMem_free(esa);
6274           if (esal != NULL)
6275               PerlMem_free(esal);
6276           PerlMem_free(trndir);
6277           PerlMem_free(vmsdir);
6278           set_errno(EVMSERR);
6279           set_vaxc_errno(dirfab.fab$l_sts);
6280           return NULL;
6281         }
6282       }
6283       else {
6284         savnam = dirnam;
6285         /* Does the file really exist? */
6286         if (sys$search(&dirfab)& STS$K_SUCCESS) {
6287           /* Yes; fake the fnb bits so we'll check type below */
6288           rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6289         }
6290         else { /* No; just work with potential name */
6291           if (dirfab.fab$l_sts    == RMS$_FNF
6292               || dirfab.fab$l_sts == RMS$_DNF
6293               || dirfab.fab$l_sts == RMS$_FND)
6294                 dirnam = savnam;
6295           else {
6296             int fab_sts;
6297             fab_sts = dirfab.fab$l_sts;
6298             sts = rms_free_search_context(&dirfab);
6299             PerlMem_free(esa);
6300             if (esal != NULL)
6301                 PerlMem_free(esal);
6302             PerlMem_free(trndir);
6303             PerlMem_free(vmsdir);
6304             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
6305             return NULL;
6306           }
6307         }
6308       }
6309
6310       /* Make sure we are using the right buffer */
6311 #if defined(NAML$C_MAXRSS)
6312       if (esal != NULL) {
6313         my_esa = esal;
6314         my_esa_len = rms_nam_esll(dirnam);
6315       } else {
6316 #endif
6317         my_esa = esa;
6318         my_esa_len = rms_nam_esl(dirnam);
6319 #if defined(NAML$C_MAXRSS)
6320       }
6321 #endif
6322       my_esa[my_esa_len] = '\0';
6323       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6324         cp1 = strchr(my_esa,']');
6325         if (!cp1) cp1 = strchr(my_esa,'>');
6326         if (cp1) {  /* Should always be true */
6327           my_esa_len -= cp1 - my_esa - 1;
6328           memmove(my_esa, cp1 + 1, my_esa_len);
6329         }
6330       }
6331       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6332         /* Yep; check version while we're at it, if it's there. */
6333         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6334         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6335           /* Something other than .DIR[;1].  Bzzt. */
6336           sts = rms_free_search_context(&dirfab);
6337           PerlMem_free(esa);
6338           if (esal != NULL)
6339              PerlMem_free(esal);
6340           PerlMem_free(trndir);
6341           PerlMem_free(vmsdir);
6342           set_errno(ENOTDIR);
6343           set_vaxc_errno(RMS$_DIR);
6344           return NULL;
6345         }
6346       }
6347
6348       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6349         /* They provided at least the name; we added the type, if necessary, */
6350         my_strlcpy(buf, my_esa, VMS_MAXRSS);
6351         sts = rms_free_search_context(&dirfab);
6352         PerlMem_free(trndir);
6353         PerlMem_free(esa);
6354         if (esal != NULL)
6355             PerlMem_free(esal);
6356         PerlMem_free(vmsdir);
6357         return buf;
6358       }
6359       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6360         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6361         *cp1 = '\0';
6362         my_esa_len -= 9;
6363       }
6364       if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6365       if (cp1 == NULL) { /* should never happen */
6366         sts = rms_free_search_context(&dirfab);
6367         PerlMem_free(trndir);
6368         PerlMem_free(esa);
6369         if (esal != NULL)
6370             PerlMem_free(esal);
6371         PerlMem_free(vmsdir);
6372         return NULL;
6373       }
6374       term = *cp1;
6375       *cp1 = '\0';
6376       retlen = strlen(my_esa);
6377       cp1 = strrchr(my_esa,'.');
6378       /* ODS-5 directory specifications can have extra "." in them. */
6379       /* Fix-me, can not scan EFS file specifications backwards */
6380       while (cp1 != NULL) {
6381         if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6382           break;
6383         else {
6384            cp1--;
6385            while ((cp1 > my_esa) && (*cp1 != '.'))
6386              cp1--;
6387         }
6388         if (cp1 == my_esa)
6389           cp1 = NULL;
6390       }
6391
6392       if ((cp1) != NULL) {
6393         /* There's more than one directory in the path.  Just roll back. */
6394         *cp1 = term;
6395         my_strlcpy(buf, my_esa, VMS_MAXRSS);
6396       }
6397       else {
6398         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6399           /* Go back and expand rooted logical name */
6400           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6401 #ifdef NAM$M_NO_SHORT_UPCASE
6402           if (decc_efs_case_preserve)
6403             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6404 #endif
6405           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6406             sts = rms_free_search_context(&dirfab);
6407             PerlMem_free(esa);
6408             if (esal != NULL)
6409                 PerlMem_free(esal);
6410             PerlMem_free(trndir);
6411             PerlMem_free(vmsdir);
6412             set_errno(EVMSERR);
6413             set_vaxc_errno(dirfab.fab$l_sts);
6414             return NULL;
6415           }
6416
6417           /* This changes the length of the string of course */
6418           if (esal != NULL) {
6419               my_esa_len = rms_nam_esll(dirnam);
6420           } else {
6421               my_esa_len = rms_nam_esl(dirnam);
6422           }
6423
6424           retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6425           cp1 = strstr(my_esa,"][");
6426           if (!cp1) cp1 = strstr(my_esa,"]<");
6427           dirlen = cp1 - my_esa;
6428           memcpy(buf, my_esa, dirlen);
6429           if (!strncmp(cp1+2,"000000]",7)) {
6430             buf[dirlen-1] = '\0';
6431             /* fix-me Not full ODS-5, just extra dots in directories for now */
6432             cp1 = buf + dirlen - 1;
6433             while (cp1 > buf)
6434             {
6435               if (*cp1 == '[')
6436                 break;
6437               if (*cp1 == '.') {
6438                 if (*(cp1-1) != '^')
6439                   break;
6440               }
6441               cp1--;
6442             }
6443             if (*cp1 == '.') *cp1 = ']';
6444             else {
6445               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6446               memmove(cp1+1,"000000]",7);
6447             }
6448           }
6449           else {
6450             memmove(buf+dirlen, cp1+2, retlen-dirlen);
6451             buf[retlen] = '\0';
6452             /* Convert last '.' to ']' */
6453             cp1 = buf+retlen-1;
6454             while (*cp != '[') {
6455               cp1--;
6456               if (*cp1 == '.') {
6457                 /* Do not trip on extra dots in ODS-5 directories */
6458                 if ((cp1 == buf) || (*(cp1-1) != '^'))
6459                 break;
6460               }
6461             }
6462             if (*cp1 == '.') *cp1 = ']';
6463             else {
6464               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6465               memmove(cp1+1,"000000]",7);
6466             }
6467           }
6468         }
6469         else {  /* This is a top-level dir.  Add the MFD to the path. */
6470           cp1 = strrchr(my_esa, ':');
6471           assert(cp1);
6472           memmove(buf, my_esa, cp1 - my_esa + 1);
6473           memmove(buf + (cp1 - my_esa) + 1, "[000000]", 8);
6474           memmove(buf + (cp1 - my_esa) + 9, cp1 + 2, retlen - (cp1 - my_esa + 2));
6475           buf[retlen + 7] = '\0';  /* We've inserted '000000]' */
6476         }
6477       }
6478       sts = rms_free_search_context(&dirfab);
6479       /* We've set up the string up through the filename.  Add the
6480          type and version, and we're done. */
6481       strcat(buf,".DIR;1");
6482
6483       /* $PARSE may have upcased filespec, so convert output to lower
6484        * case if input contained any lowercase characters. */
6485       if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
6486       PerlMem_free(trndir);
6487       PerlMem_free(esa);
6488       if (esal != NULL)
6489         PerlMem_free(esal);
6490       PerlMem_free(vmsdir);
6491       return buf;
6492     }
6493 }  /* end of int_fileify_dirspec() */
6494
6495
6496 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6497 static char *
6498 mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
6499 {
6500     static char __fileify_retbuf[VMS_MAXRSS];
6501     char * fileified, *ret_spec, *ret_buf;
6502
6503     fileified = NULL;
6504     ret_buf = buf;
6505     if (ret_buf == NULL) {
6506         if (ts) {
6507             Newx(fileified, VMS_MAXRSS, char);
6508             if (fileified == NULL)
6509                 _ckvmssts(SS$_INSFMEM);
6510             ret_buf = fileified;
6511         } else {
6512             ret_buf = __fileify_retbuf;
6513         }
6514     }
6515
6516     ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6517
6518     if (ret_spec == NULL) {
6519        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6520        if (fileified)
6521            Safefree(fileified);
6522     }
6523
6524     return ret_spec;
6525 }  /* end of do_fileify_dirspec() */
6526 /*}}}*/
6527
6528 /* External entry points */
6529 char *
6530 Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6531 {
6532     return do_fileify_dirspec(dir, buf, 0, NULL);
6533 }
6534
6535 char *
6536 Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6537 {
6538     return do_fileify_dirspec(dir, buf, 1, NULL);
6539 }
6540
6541 char *
6542 Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6543 {
6544     return do_fileify_dirspec(dir, buf, 0, utf8_fl);
6545 }
6546
6547 char *
6548 Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6549 {
6550     return do_fileify_dirspec(dir, buf, 1, utf8_fl);
6551 }
6552
6553 static char *
6554 int_pathify_dirspec_simple(const char * dir, char * buf,
6555     char * v_spec, int v_len, char * r_spec, int r_len,
6556     char * d_spec, int d_len, char * n_spec, int n_len,
6557     char * e_spec, int e_len, char * vs_spec, int vs_len)
6558 {
6559
6560     /* VMS specification - Try to do this the simple way */
6561     if ((v_len + r_len > 0) || (d_len > 0)) {
6562         int is_dir;
6563
6564         /* No name or extension component, already a directory */
6565         if ((n_len + e_len + vs_len) == 0) {
6566             strcpy(buf, dir);
6567             return buf;
6568         }
6569
6570         /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6571         /* This results from catfile() being used instead of catdir() */
6572         /* So even though it should not work, we need to allow it */
6573
6574         /* If this is .DIR;1 then do a simple conversion */
6575         is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6576         if (is_dir || (e_len == 0) && (d_len > 0)) {
6577              int len;
6578              len = v_len + r_len + d_len - 1;
6579              char dclose = d_spec[d_len - 1];
6580              memcpy(buf, dir, len);
6581              buf[len] = '.';
6582              len++;
6583              memcpy(&buf[len], n_spec, n_len);
6584              len += n_len;
6585              buf[len] = dclose;
6586              buf[len + 1] = '\0';
6587              return buf;
6588         }
6589
6590 #ifdef HAS_SYMLINK
6591         else if (d_len > 0) {
6592             /* In the olden days, a directory needed to have a .DIR */
6593             /* extension to be a valid directory, but now it could  */
6594             /* be a symbolic link */
6595             int len;
6596             len = v_len + r_len + d_len - 1;
6597             char dclose = d_spec[d_len - 1];
6598             memcpy(buf, dir, len);
6599             buf[len] = '.';
6600             len++;
6601             memcpy(&buf[len], n_spec, n_len);
6602             len += n_len;
6603             if (e_len > 0) {
6604                 if (decc_efs_charset) {
6605                     if (e_len == 4
6606                         && (toupper(e_spec[1]) == 'D')
6607                         && (toupper(e_spec[2]) == 'I')
6608                         && (toupper(e_spec[3]) == 'R')) {
6609
6610                         /* Corner case: directory spec with invalid version.
6611                          * Valid would have followed is_dir path above.
6612                          */
6613                         SETERRNO(ENOTDIR, RMS$_DIR);
6614                         return NULL;
6615                     }
6616                     else {
6617                         buf[len] = '^';
6618                         len++;
6619                         memcpy(&buf[len], e_spec, e_len);
6620                         len += e_len;
6621                     }
6622                 }
6623                 else {
6624                     SETERRNO(ENOTDIR, RMS$_DIR);
6625                     return NULL;
6626                 }
6627             }
6628             buf[len] = dclose;
6629             buf[len + 1] = '\0';
6630             return buf;
6631         }
6632 #else
6633         else {
6634             set_vaxc_errno(RMS$_DIR);
6635             set_errno(ENOTDIR);
6636             return NULL;
6637         }
6638 #endif
6639     }
6640     set_vaxc_errno(RMS$_DIR);
6641     set_errno(ENOTDIR);
6642     return NULL;
6643 }
6644
6645
6646 /* Internal routine to make sure or convert a directory to be in a */
6647 /* path specification.  No utf8 flag because it is not changed or used */
6648 static char *
6649 int_pathify_dirspec(const char *dir, char *buf)
6650 {
6651     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6652     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6653     char * exp_spec, *ret_spec;
6654     char * trndir;
6655     unsigned short int trnlnm_iter_count;
6656     STRLEN trnlen;
6657     int need_to_lower;
6658
6659     if (vms_debug_fileify) {
6660         if (dir == NULL)
6661             fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6662         else
6663             fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6664     }
6665
6666     /* We may need to lower case the result if we translated  */
6667     /* a logical name or got the current working directory */
6668     need_to_lower = 0;
6669
6670     if (!dir || !*dir) {
6671       set_errno(EINVAL);
6672       set_vaxc_errno(SS$_BADPARAM);
6673       return NULL;
6674     }
6675
6676     trndir = (char *)PerlMem_malloc(VMS_MAXRSS);
6677     if (trndir == NULL)
6678         _ckvmssts_noperl(SS$_INSFMEM);
6679
6680     /* If no directory specified use the current default */
6681     if (*dir)
6682         my_strlcpy(trndir, dir, VMS_MAXRSS);
6683     else {
6684         getcwd(trndir, VMS_MAXRSS - 1);
6685         need_to_lower = 1;
6686     }
6687
6688     /* now deal with bare names that could be logical names */
6689     trnlnm_iter_count = 0;
6690     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6691            && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6692         trnlnm_iter_count++;
6693         need_to_lower = 1;
6694         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6695             break;
6696         trnlen = strlen(trndir);
6697
6698         /* Trap simple rooted lnms, and return lnm:[000000] */
6699         if (!strcmp(trndir+trnlen-2,".]")) {
6700             my_strlcpy(buf, dir, VMS_MAXRSS);
6701             strcat(buf, ":[000000]");
6702             PerlMem_free(trndir);
6703
6704             if (vms_debug_fileify) {
6705                 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6706             }
6707             return buf;
6708         }
6709     }
6710
6711     /* At this point we do not work with *dir, but the copy in  *trndir */
6712
6713     if (need_to_lower && !decc_efs_case_preserve) {
6714         /* Legacy mode, lower case the returned value */
6715         __mystrtolower(trndir);
6716     }
6717
6718
6719     /* Some special cases, '..', '.' */
6720     sts = 0;
6721     if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6722        /* Force UNIX filespec */
6723        sts = 1;
6724
6725     } else {
6726         /* Is this Unix or VMS format? */
6727         sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6728                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6729                              &e_len, &vs_spec, &vs_len);
6730         if (sts == 0) {
6731
6732             /* Just a filename? */
6733             if ((v_len + r_len + d_len) == 0) {
6734
6735                 /* Now we have a problem, this could be Unix or VMS */
6736                 /* We have to guess.  .DIR usually means VMS */
6737
6738                 /* In UNIX report mode, the .DIR extension is removed */
6739                 /* if one shows up, it is for a non-directory or a directory */
6740                 /* in EFS charset mode */
6741
6742                 /* So if we are in Unix report mode, assume that this */
6743                 /* is a relative Unix directory specification */
6744
6745                 sts = 1;
6746                 if (!decc_filename_unix_report && decc_efs_charset) {
6747                     int is_dir;
6748                     is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6749
6750                     if (is_dir) {
6751                         /* Traditional mode, assume .DIR is directory */
6752                         buf[0] = '[';
6753                         buf[1] = '.';
6754                         memcpy(&buf[2], n_spec, n_len);
6755                         buf[n_len + 2] = ']';
6756                         buf[n_len + 3] = '\0';
6757                         PerlMem_free(trndir);
6758                         if (vms_debug_fileify) {
6759                             fprintf(stderr,
6760                                     "int_pathify_dirspec: buf = %s\n",
6761                                     buf);
6762                         }
6763                         return buf;
6764                     }
6765                 }
6766             }
6767         }
6768     }
6769     if (sts == 0) {
6770         ret_spec = int_pathify_dirspec_simple(trndir, buf,
6771             v_spec, v_len, r_spec, r_len,
6772             d_spec, d_len, n_spec, n_len,
6773             e_spec, e_len, vs_spec, vs_len);
6774
6775         if (ret_spec != NULL) {
6776             PerlMem_free(trndir);
6777             if (vms_debug_fileify) {
6778                 fprintf(stderr,
6779                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6780             }
6781             return ret_spec;
6782         }
6783
6784         /* Simple way did not work, which means that a logical name */
6785         /* was present for the directory specification.             */
6786         /* Need to use an rmsexpand variant to decode it completely */
6787         exp_spec = (char *)PerlMem_malloc(VMS_MAXRSS);
6788         if (exp_spec == NULL)
6789             _ckvmssts_noperl(SS$_INSFMEM);
6790
6791         ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6792         if (ret_spec != NULL) {
6793             sts = vms_split_path(exp_spec, &v_spec, &v_len,
6794                                  &r_spec, &r_len, &d_spec, &d_len,
6795                                  &n_spec, &n_len, &e_spec,
6796                                  &e_len, &vs_spec, &vs_len);
6797             if (sts == 0) {
6798                 ret_spec = int_pathify_dirspec_simple(
6799                     exp_spec, buf, v_spec, v_len, r_spec, r_len,
6800                     d_spec, d_len, n_spec, n_len,
6801                     e_spec, e_len, vs_spec, vs_len);
6802
6803                 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6804                     /* Legacy mode, lower case the returned value */
6805                     __mystrtolower(ret_spec);
6806                 }
6807             } else {
6808                 set_vaxc_errno(RMS$_DIR);
6809                 set_errno(ENOTDIR);
6810                 ret_spec = NULL;
6811             }
6812         }
6813         PerlMem_free(exp_spec);
6814         PerlMem_free(trndir);
6815         if (vms_debug_fileify) {
6816             if (ret_spec == NULL)
6817                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6818             else
6819                 fprintf(stderr,
6820                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6821         }
6822         return ret_spec;
6823
6824     } else {
6825         /* Unix specification, Could be trivial conversion, */
6826         /* but have to deal with trailing '.dir' or extra '.' */
6827
6828         char * lastdot;
6829         char * lastslash;
6830         int is_dir;
6831         STRLEN dir_len = strlen(trndir);
6832
6833         lastslash = strrchr(trndir, '/');
6834         if (lastslash == NULL)
6835             lastslash = trndir;
6836         else
6837             lastslash++;
6838
6839         lastdot = NULL;
6840
6841         /* '..' or '.' are valid directory components */
6842         is_dir = 0;
6843         if (lastslash[0] == '.') {
6844             if (lastslash[1] == '\0') {
6845                is_dir = 1;
6846             } else if (lastslash[1] == '.') {
6847                 if (lastslash[2] == '\0') {
6848                     is_dir = 1;
6849                 } else {
6850                     /* And finally allow '...' */
6851                     if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
6852                         is_dir = 1;
6853                     }
6854                 }
6855             }
6856         }
6857
6858         if (!is_dir) {
6859            lastdot = strrchr(lastslash, '.');
6860         }
6861         if (lastdot != NULL) {
6862             STRLEN e_len;
6863              /* '.dir' is discarded, and any other '.' is invalid */
6864             e_len = strlen(lastdot);
6865
6866             is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
6867
6868             if (is_dir) {
6869                 dir_len = dir_len - 4;
6870             }
6871         }
6872
6873         my_strlcpy(buf, trndir, VMS_MAXRSS);
6874         if (buf[dir_len - 1] != '/') {
6875             buf[dir_len] = '/';
6876             buf[dir_len + 1] = '\0';
6877         }
6878
6879         /* Under ODS-2 rules, '.' becomes '_', so fix it up */
6880         if (!decc_efs_charset) {
6881              int dir_start = 0;
6882              char * str = buf;
6883              if (str[0] == '.') {
6884                  char * dots = str;
6885                  int cnt = 1;
6886                  while ((dots[cnt] == '.') && (cnt < 3))
6887                      cnt++;
6888                  if (cnt <= 3) {
6889                      if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
6890                          dir_start = 1;
6891                          str += cnt;
6892                      }
6893                  }
6894              }
6895              for (; *str; ++str) {
6896                  while (*str == '/') {
6897                      dir_start = 1;
6898                      *str++;
6899                  }
6900                  if (dir_start) {
6901
6902                      /* Have to skip up to three dots which could be */
6903                      /* directories, 3 dots being a VMS extension for Perl */
6904                      char * dots = str;
6905                      int cnt = 0;
6906                      while ((dots[cnt] == '.') && (cnt < 3)) {
6907                          cnt++;
6908                      }
6909                      if (dots[cnt] == '\0')
6910                          break;
6911                      if ((cnt > 1) && (dots[cnt] != '/')) {
6912                          dir_start = 0;
6913                      } else {
6914                          str += cnt;
6915                      }
6916
6917                      /* too many dots? */
6918                      if ((cnt == 0) || (cnt > 3)) {
6919                          dir_start = 0;
6920                      }
6921                  }
6922                  if (!dir_start && (*str == '.')) {
6923                      *str = '_';
6924                  }
6925              }
6926         }
6927         PerlMem_free(trndir);
6928         ret_spec = buf;
6929         if (vms_debug_fileify) {
6930             if (ret_spec == NULL)
6931                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6932             else
6933                 fprintf(stderr,
6934                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6935         }
6936         return ret_spec;
6937     }
6938 }
6939
6940 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6941 static char *
6942 mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6943 {
6944     static char __pathify_retbuf[VMS_MAXRSS];
6945     char * pathified, *ret_spec, *ret_buf;
6946
6947     pathified = NULL;
6948     ret_buf = buf;
6949     if (ret_buf == NULL) {
6950         if (ts) {
6951             Newx(pathified, VMS_MAXRSS, char);
6952             if (pathified == NULL)
6953                 _ckvmssts(SS$_INSFMEM);
6954             ret_buf = pathified;
6955         } else {
6956             ret_buf = __pathify_retbuf;
6957         }
6958     }
6959
6960     ret_spec = int_pathify_dirspec(dir, ret_buf);
6961
6962     if (ret_spec == NULL) {
6963        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6964        if (pathified)
6965            Safefree(pathified);
6966     }
6967
6968     return ret_spec;
6969
6970 }  /* end of do_pathify_dirspec() */
6971
6972
6973 /* External entry points */
6974 char *
6975 Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6976 {
6977     return do_pathify_dirspec(dir, buf, 0, NULL);
6978 }
6979
6980 char *
6981 Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6982 {
6983     return do_pathify_dirspec(dir, buf, 1, NULL);
6984 }
6985
6986 char *
6987 Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6988 {
6989     return do_pathify_dirspec(dir, buf, 0, utf8_fl);
6990 }
6991
6992 char *
6993 Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6994 {
6995     return do_pathify_dirspec(dir, buf, 1, utf8_fl);
6996 }
6997
6998 /* Internal tounixspec routine that does not use a thread context */
6999 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
7000 static char *
7001 int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
7002 {
7003   char *dirend, *cp1, *cp3, *tmp;
7004   const char *cp2;
7005   int dirlen;
7006   unsigned short int trnlnm_iter_count;
7007   int cmp_rslt, outchars_added;
7008   if (utf8_fl != NULL)
7009     *utf8_fl = 0;
7010
7011   if (vms_debug_fileify) {
7012       if (spec == NULL)
7013           fprintf(stderr, "int_tounixspec: spec = NULL\n");
7014       else
7015           fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
7016   }
7017
7018
7019   if (spec == NULL) {
7020       set_errno(EINVAL);
7021       set_vaxc_errno(SS$_BADPARAM);
7022       return NULL;
7023   }
7024   if (strlen(spec) > (VMS_MAXRSS-1)) {
7025       set_errno(E2BIG);
7026       set_vaxc_errno(SS$_BUFFEROVF);
7027       return NULL;
7028   }
7029
7030   /* New VMS specific format needs translation
7031    * glob passes filenames with trailing '\n' and expects this preserved.
7032    */
7033   if (decc_posix_compliant_pathnames) {
7034     if (strncmp(spec, "\"^UP^", 5) == 0) {
7035       char * uspec;
7036       char *tunix;
7037       int tunix_len;
7038       int nl_flag;
7039
7040       tunix = (char *)PerlMem_malloc(VMS_MAXRSS);
7041       if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7042       tunix_len = my_strlcpy(tunix, spec, VMS_MAXRSS);
7043       nl_flag = 0;
7044       if (tunix[tunix_len - 1] == '\n') {
7045         tunix[tunix_len - 1] = '\"';
7046         tunix[tunix_len] = '\0';
7047         tunix_len--;
7048         nl_flag = 1;
7049       }
7050       uspec = decc$translate_vms(tunix);
7051       PerlMem_free(tunix);
7052       if ((int)uspec > 0) {
7053         my_strlcpy(rslt, uspec, VMS_MAXRSS);
7054         if (nl_flag) {
7055           strcat(rslt,"\n");
7056         }
7057         else {
7058           /* If we can not translate it, makemaker wants as-is */
7059           my_strlcpy(rslt, spec, VMS_MAXRSS);
7060         }
7061         return rslt;
7062       }
7063     }
7064   }
7065
7066   cmp_rslt = 0; /* Presume VMS */
7067   cp1 = strchr(spec, '/');
7068   if (cp1 == NULL)
7069     cmp_rslt = 0;
7070
7071     /* Look for EFS ^/ */
7072     if (decc_efs_charset) {
7073       while (cp1 != NULL) {
7074         cp2 = cp1 - 1;
7075         if (*cp2 != '^') {
7076           /* Found illegal VMS, assume UNIX */
7077           cmp_rslt = 1;
7078           break;
7079         }
7080       cp1++;
7081       cp1 = strchr(cp1, '/');
7082     }
7083   }
7084
7085   /* Look for "." and ".." */
7086   if (decc_filename_unix_report) {
7087     if (spec[0] == '.') {
7088       if ((spec[1] == '\0') || (spec[1] == '\n')) {
7089         cmp_rslt = 1;
7090       }
7091       else {
7092         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
7093           cmp_rslt = 1;
7094         }
7095       }
7096     }
7097   }
7098
7099   cp1 = rslt;
7100   cp2 = spec;
7101
7102   /* This is already UNIX or at least nothing VMS understands,
7103    * so all we can reasonably do is unescape extended chars.
7104    */
7105   if (cmp_rslt) {
7106     while (*cp2) {
7107         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7108         cp1 += outchars_added;
7109     }
7110     *cp1 = '\0';
7111     if (vms_debug_fileify) {
7112         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7113     }
7114     return rslt;
7115   }
7116
7117   dirend = strrchr(spec,']');
7118   if (dirend == NULL) dirend = strrchr(spec,'>');
7119   if (dirend == NULL) dirend = strchr(spec,':');
7120   if (dirend == NULL) {
7121     while (*cp2) {
7122         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7123         cp1 += outchars_added;
7124     }
7125     *cp1 = '\0';
7126     if (vms_debug_fileify) {
7127         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7128     }
7129     return rslt;
7130   }
7131
7132   /* Special case 1 - sys$posix_root = / */
7133   if (!decc_disable_posix_root) {
7134     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
7135       *cp1 = '/';
7136       cp1++;
7137       cp2 = cp2 + 15;
7138       }
7139   }
7140
7141   /* Special case 2 - Convert NLA0: to /dev/null */
7142   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
7143   if (cmp_rslt == 0) {
7144     strcpy(rslt, "/dev/null");
7145     cp1 = cp1 + 9;
7146     cp2 = cp2 + 5;
7147     if (spec[6] != '\0') {
7148       cp1[9] = '/';
7149       cp1++;
7150       cp2++;
7151     }
7152   }
7153
7154    /* Also handle special case "SYS$SCRATCH:" */
7155   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
7156   tmp = (char *)PerlMem_malloc(VMS_MAXRSS);
7157   if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7158   if (cmp_rslt == 0) {
7159   int islnm;
7160
7161     islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
7162     if (!islnm) {
7163       strcpy(rslt, "/tmp");
7164       cp1 = cp1 + 4;
7165       cp2 = cp2 + 12;
7166       if (spec[12] != '\0') {
7167         cp1[4] = '/';
7168         cp1++;
7169         cp2++;
7170       }
7171     }
7172   }
7173
7174   if (*cp2 != '[' && *cp2 != '<') {
7175     *(cp1++) = '/';
7176   }
7177   else {  /* the VMS spec begins with directories */
7178     cp2++;
7179     if (*cp2 == ']' || *cp2 == '>') {
7180       *(cp1++) = '.';
7181       *(cp1++) = '/';
7182     }
7183     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
7184       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
7185         PerlMem_free(tmp);
7186         if (vms_debug_fileify) {
7187             fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7188         }
7189         return NULL;
7190       }
7191       trnlnm_iter_count = 0;
7192       do {
7193         cp3 = tmp;
7194         while (*cp3 != ':' && *cp3) cp3++;
7195         *(cp3++) = '\0';
7196         if (strchr(cp3,']') != NULL) break;
7197         trnlnm_iter_count++;
7198         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7199       } while (vmstrnenv(tmp,tmp,0,fildev,0));
7200       cp1 = rslt;
7201       cp3 = tmp;
7202       *(cp1++) = '/';
7203       while (*cp3) {
7204         *(cp1++) = *(cp3++);
7205         if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7206             PerlMem_free(tmp);
7207             set_errno(ENAMETOOLONG);
7208             set_vaxc_errno(SS$_BUFFEROVF);
7209             if (vms_debug_fileify) {
7210                 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7211             }
7212             return NULL; /* No room */
7213         }
7214       }
7215       *(cp1++) = '/';
7216     }
7217     if ((*cp2 == '^')) {
7218         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7219         cp1 += outchars_added;
7220     }
7221     else if ( *cp2 == '.') {
7222       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7223         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7224         cp2 += 3;
7225       }
7226       else cp2++;
7227     }
7228   }
7229   PerlMem_free(tmp);
7230   for (; cp2 <= dirend; cp2++) {
7231     if ((*cp2 == '^')) {
7232         /* EFS file escape -- unescape it. */
7233         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added) - 1;
7234         cp1 += outchars_added;
7235     }
7236     else if (*cp2 == ':') {
7237       *(cp1++) = '/';
7238       if (*(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7239     }
7240     else if (*cp2 == ']' || *cp2 == '>') {
7241       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7242     }
7243     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7244       *(cp1++) = '/';
7245       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7246         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7247                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7248         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7249             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7250       }
7251       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7252         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7253         cp2 += 2;
7254       }
7255     }
7256     else if (*cp2 == '-') {
7257       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7258         while (*cp2 == '-') {
7259           cp2++;
7260           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7261         }
7262         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7263                                                          /* filespecs like */
7264           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
7265           if (vms_debug_fileify) {
7266               fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7267           }
7268           return NULL;
7269         }
7270       }
7271       else *(cp1++) = *cp2;
7272     }
7273     else *(cp1++) = *cp2;
7274   }
7275   /* Translate the rest of the filename. */
7276   while (*cp2) {
7277       int dot_seen = 0;
7278       switch(*cp2) {
7279       /* Fixme - for compatibility with the CRTL we should be removing */
7280       /* spaces from the file specifications, but this may show that */
7281       /* some tests that were appearing to pass are not really passing */
7282       case '%':
7283           cp2++;
7284           *(cp1++) = '?';
7285           break;
7286       case '^':
7287           cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7288           cp1 += outchars_added;
7289           break;
7290       case ';':
7291           if (decc_filename_unix_no_version) {
7292               /* Easy, drop the version */
7293               while (*cp2)
7294                   cp2++;
7295               break;
7296           } else {
7297               /* Punt - passing the version as a dot will probably */
7298               /* break perl in weird ways, but so did passing */
7299               /* through the ; as a version.  Follow the CRTL and */
7300               /* hope for the best. */
7301               cp2++;
7302               *(cp1++) = '.';
7303           }
7304           break;
7305       case '.':
7306           if (dot_seen) {
7307               /* We will need to fix this properly later */
7308               /* As Perl may be installed on an ODS-5 volume, but not */
7309               /* have the EFS_CHARSET enabled, it still may encounter */
7310               /* filenames with extra dots in them, and a precedent got */
7311               /* set which allowed them to work, that we will uphold here */
7312               /* If extra dots are present in a name and no ^ is on them */
7313               /* VMS assumes that the first one is the extension delimiter */
7314               /* the rest have an implied ^. */
7315
7316               /* this is also a conflict as the . is also a version */
7317               /* delimiter in VMS, */
7318
7319               *(cp1++) = *(cp2++);
7320               break;
7321           }
7322           dot_seen = 1;
7323           /* This is an extension */
7324           if (decc_readdir_dropdotnotype) {
7325               cp2++;
7326               if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7327                   /* Drop the dot for the extension */
7328                   break;
7329               } else {
7330                   *(cp1++) = '.';
7331               }
7332               break;
7333           }
7334       default:
7335           *(cp1++) = *(cp2++);
7336       }
7337   }
7338   *cp1 = '\0';
7339
7340   /* This still leaves /000000/ when working with a
7341    * VMS device root or concealed root.
7342    */
7343   {
7344       int ulen;
7345       char * zeros;
7346
7347       ulen = strlen(rslt);
7348
7349       /* Get rid of "000000/ in rooted filespecs */
7350       if (ulen > 7) {
7351         zeros = strstr(rslt, "/000000/");
7352         if (zeros != NULL) {
7353           int mlen;
7354           mlen = ulen - (zeros - rslt) - 7;
7355           memmove(zeros, &zeros[7], mlen);
7356           ulen = ulen - 7;
7357           rslt[ulen] = '\0';
7358         }
7359       }
7360   }
7361
7362   if (vms_debug_fileify) {
7363       fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7364   }
7365   return rslt;
7366
7367 }  /* end of int_tounixspec() */
7368
7369
7370 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7371 static char *
7372 mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7373 {
7374     static char __tounixspec_retbuf[VMS_MAXRSS];
7375     char * unixspec, *ret_spec, *ret_buf;
7376
7377     unixspec = NULL;
7378     ret_buf = buf;
7379     if (ret_buf == NULL) {
7380         if (ts) {
7381             Newx(unixspec, VMS_MAXRSS, char);
7382             if (unixspec == NULL)
7383                 _ckvmssts(SS$_INSFMEM);
7384             ret_buf = unixspec;
7385         } else {
7386             ret_buf = __tounixspec_retbuf;
7387         }
7388     }
7389
7390     ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7391
7392     if (ret_spec == NULL) {
7393        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7394        if (unixspec)
7395            Safefree(unixspec);
7396     }
7397
7398     return ret_spec;
7399
7400 }  /* end of do_tounixspec() */
7401 /*}}}*/
7402 /* External entry points */
7403 char *
7404 Perl_tounixspec(pTHX_ const char *spec, char *buf)
7405 {
7406     return do_tounixspec(spec, buf, 0, NULL);
7407 }
7408
7409 char *
7410 Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7411 {
7412     return do_tounixspec(spec,buf,1, NULL);
7413 }
7414
7415 char *
7416 Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7417 {
7418     return do_tounixspec(spec,buf,0, utf8_fl);
7419 }
7420
7421 char *
7422 Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7423 {
7424     return do_tounixspec(spec,buf,1, utf8_fl);
7425 }
7426
7427 /*
7428  This procedure is used to identify if a path is based in either
7429  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7430  it returns the OpenVMS format directory for it.
7431
7432  It is expecting specifications of only '/' or '/xxxx/'
7433
7434  If a posix root does not exist, or 'xxxx' is not a directory
7435  in the posix root, it returns a failure.
7436
7437  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7438
7439  It is used only internally by posix_to_vmsspec_hardway().
7440  */
7441
7442 static int
7443 posix_root_to_vms(char *vmspath, int vmspath_len,
7444                   const char *unixpath, const int * utf8_fl)
7445 {
7446   int sts;
7447   struct FAB myfab = cc$rms_fab;
7448   rms_setup_nam(mynam);
7449   struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7450   struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7451   char * esa, * esal, * rsa, * rsal;
7452   int dir_flag;
7453   int unixlen;
7454
7455   dir_flag = 0;
7456   vmspath[0] = '\0';
7457   unixlen = strlen(unixpath);
7458   if (unixlen == 0) {
7459     return RMS$_FNF;
7460   }
7461
7462 #if __CRTL_VER >= 80200000
7463   /* If not a posix spec already, convert it */
7464   if (decc_posix_compliant_pathnames) {
7465     if (strncmp(unixpath,"\"^UP^",5) != 0) {
7466       sprintf(vmspath,"\"^UP^%s\"",unixpath);
7467     }
7468     else {
7469       /* This is already a VMS specification, no conversion */
7470       unixlen--;
7471       my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7472     }
7473   }
7474   else
7475 #endif
7476   {
7477      int path_len;
7478      int i,j;
7479
7480      /* Check to see if this is under the POSIX root */
7481      if (decc_disable_posix_root) {
7482         return RMS$_FNF;
7483      }
7484
7485      /* Skip leading / */
7486      if (unixpath[0] == '/') {
7487         unixpath++;
7488         unixlen--;
7489      }
7490
7491
7492      strcpy(vmspath,"SYS$POSIX_ROOT:");
7493
7494      /* If this is only the / , or blank, then... */
7495      if (unixpath[0] == '\0') {
7496         /* by definition, this is the answer */
7497         return SS$_NORMAL;
7498      }
7499
7500      /* Need to look up a directory */
7501      vmspath[15] = '[';
7502      vmspath[16] = '\0';
7503
7504      /* Copy and add '^' escape characters as needed */
7505      j = 16;
7506      i = 0;
7507      while (unixpath[i] != 0) {
7508      int k;
7509
7510         j += copy_expand_unix_filename_escape
7511             (&vmspath[j], &unixpath[i], &k, utf8_fl);
7512         i += k;
7513      }
7514
7515      path_len = strlen(vmspath);
7516      if (vmspath[path_len - 1] == '/')
7517         path_len--;
7518      vmspath[path_len] = ']';
7519      path_len++;
7520      vmspath[path_len] = '\0';
7521
7522   }
7523   vmspath[vmspath_len] = 0;
7524   if (unixpath[unixlen - 1] == '/')
7525   dir_flag = 1;
7526   esal = (char *)PerlMem_malloc(VMS_MAXRSS);
7527   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7528   esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
7529   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7530   rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
7531   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7532   rsa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
7533   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7534   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7535   rms_bind_fab_nam(myfab, mynam);
7536   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7537   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7538   if (decc_efs_case_preserve)
7539     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7540 #ifdef NAML$M_OPEN_SPECIAL
7541   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7542 #endif
7543
7544   /* Set up the remaining naml fields */
7545   sts = sys$parse(&myfab);
7546
7547   /* It failed! Try again as a UNIX filespec */
7548   if (!(sts & 1)) {
7549     PerlMem_free(esal);
7550     PerlMem_free(esa);
7551     PerlMem_free(rsal);
7552     PerlMem_free(rsa);
7553     return sts;
7554   }
7555
7556    /* get the Device ID and the FID */
7557    sts = sys$search(&myfab);
7558
7559    /* These are no longer needed */
7560    PerlMem_free(esa);
7561    PerlMem_free(rsal);
7562    PerlMem_free(rsa);
7563
7564    /* on any failure, returned the POSIX ^UP^ filespec */
7565    if (!(sts & 1)) {
7566       PerlMem_free(esal);
7567       return sts;
7568    }
7569    specdsc.dsc$a_pointer = vmspath;
7570    specdsc.dsc$w_length = vmspath_len;
7571
7572    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7573    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7574    sts = lib$fid_to_name
7575       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7576
7577   /* on any failure, returned the POSIX ^UP^ filespec */
7578   if (!(sts & 1)) {
7579      /* This can happen if user does not have permission to read directories */
7580      if (strncmp(unixpath,"\"^UP^",5) != 0)
7581        sprintf(vmspath,"\"^UP^%s\"",unixpath);
7582      else
7583        my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7584   }
7585   else {
7586     vmspath[specdsc.dsc$w_length] = 0;
7587
7588     /* Are we expecting a directory? */
7589     if (dir_flag != 0) {
7590     int i;
7591     char *eptr;
7592
7593       eptr = NULL;
7594
7595       i = specdsc.dsc$w_length - 1;
7596       while (i > 0) {
7597       int zercnt;
7598         zercnt = 0;
7599         /* Version must be '1' */
7600         if (vmspath[i--] != '1')
7601           break;
7602         /* Version delimiter is one of ".;" */
7603         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7604           break;
7605         i--;
7606         if (vmspath[i--] != 'R')
7607           break;
7608         if (vmspath[i--] != 'I')
7609           break;
7610         if (vmspath[i--] != 'D')
7611           break;
7612         if (vmspath[i--] != '.')
7613           break;
7614         eptr = &vmspath[i+1];
7615         while (i > 0) {
7616           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7617             if (vmspath[i-1] != '^') {
7618               if (zercnt != 6) {
7619                 *eptr = vmspath[i];
7620                 eptr[1] = '\0';
7621                 vmspath[i] = '.';
7622                 break;
7623               }
7624               else {
7625                 /* Get rid of 6 imaginary zero directory filename */
7626                 vmspath[i+1] = '\0';
7627               }
7628             }
7629           }
7630           if (vmspath[i] == '0')
7631             zercnt++;
7632           else
7633             zercnt = 10;
7634           i--;
7635         }
7636         break;
7637       }
7638     }
7639   }
7640   PerlMem_free(esal);
7641   return sts;
7642 }
7643
7644 /* /dev/mumble needs to be handled special.
7645    /dev/null becomes NLA0:, And there is the potential for other stuff
7646    like /dev/tty which may need to be mapped to something.
7647 */
7648
7649 static int
7650 slash_dev_special_to_vms(const char *unixptr, char *vmspath, int vmspath_len)
7651 {
7652     char * nextslash;
7653     int len;
7654     int cmp;
7655
7656     unixptr += 4;
7657     nextslash = strchr(unixptr, '/');
7658     len = strlen(unixptr);
7659     if (nextslash != NULL)
7660         len = nextslash - unixptr;
7661     cmp = strncmp("null", unixptr, 5);
7662     if (cmp == 0) {
7663         if (vmspath_len >= 6) {
7664             strcpy(vmspath, "_NLA0:");
7665             return SS$_NORMAL;
7666         }
7667     }
7668     return 0;
7669 }
7670
7671
7672 /* The built in routines do not understand perl's special needs, so
7673     doing a manual conversion from UNIX to VMS
7674
7675     If the utf8_fl is not null and points to a non-zero value, then
7676     treat 8 bit characters as UTF-8.
7677
7678     The sequence starting with '$(' and ending with ')' will be passed
7679     through with out interpretation instead of being escaped.
7680
7681   */
7682 static int
7683 posix_to_vmsspec_hardway(char *vmspath, int vmspath_len, const char *unixpath,
7684                          int dir_flag, int * utf8_fl)
7685 {
7686
7687   char *esa;
7688   const char *unixptr;
7689   const char *unixend;
7690   char *vmsptr;
7691   const char *lastslash;
7692   const char *lastdot;
7693   int unixlen;
7694   int vmslen;
7695   int dir_start;
7696   int dir_dot;
7697   int quoted;
7698   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7699   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7700
7701   if (utf8_fl != NULL)
7702     *utf8_fl = 0;
7703
7704   unixptr = unixpath;
7705   dir_dot = 0;
7706
7707   /* Ignore leading "/" characters */
7708   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7709     unixptr++;
7710   }
7711   unixlen = strlen(unixptr);
7712
7713   /* Do nothing with blank paths */
7714   if (unixlen == 0) {
7715     vmspath[0] = '\0';
7716     return SS$_NORMAL;
7717   }
7718
7719   quoted = 0;
7720   /* This could have a "^UP^ on the front */
7721   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7722     quoted = 1;
7723     unixptr+= 5;
7724     unixlen-= 5;
7725   }
7726
7727   lastslash = strrchr(unixptr,'/');
7728   lastdot = strrchr(unixptr,'.');
7729   unixend = strrchr(unixptr,'\"');
7730   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7731     unixend = unixptr + unixlen;
7732   }
7733
7734   /* last dot is last dot or past end of string */
7735   if (lastdot == NULL)
7736     lastdot = unixptr + unixlen;
7737
7738   /* if no directories, set last slash to beginning of string */
7739   if (lastslash == NULL) {
7740     lastslash = unixptr;
7741   }
7742   else {
7743     /* Watch out for trailing "." after last slash, still a directory */
7744     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7745       lastslash = unixptr + unixlen;
7746     }
7747
7748     /* Watch out for trailing ".." after last slash, still a directory */
7749     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7750       lastslash = unixptr + unixlen;
7751     }
7752
7753     /* dots in directories are aways escaped */
7754     if (lastdot < lastslash)
7755       lastdot = unixptr + unixlen;
7756   }
7757
7758   /* if (unixptr < lastslash) then we are in a directory */
7759
7760   dir_start = 0;
7761
7762   vmsptr = vmspath;
7763   vmslen = 0;
7764
7765   /* Start with the UNIX path */
7766   if (*unixptr != '/') {
7767     /* relative paths */
7768
7769     /* If allowing logical names on relative pathnames, then handle here */
7770     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7771         !decc_posix_compliant_pathnames) {
7772     char * nextslash;
7773     int seg_len;
7774     char * trn;
7775     int islnm;
7776
7777         /* Find the next slash */
7778         nextslash = strchr(unixptr,'/');
7779
7780         esa = (char *)PerlMem_malloc(vmspath_len);
7781         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7782
7783         trn = (char *)PerlMem_malloc(VMS_MAXRSS);
7784         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7785
7786         if (nextslash != NULL) {
7787
7788             seg_len = nextslash - unixptr;
7789             memcpy(esa, unixptr, seg_len);
7790             esa[seg_len] = 0;
7791         }
7792         else {
7793             seg_len = my_strlcpy(esa, unixptr, sizeof(esa));
7794         }
7795         /* trnlnm(section) */
7796         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7797
7798         if (islnm) {
7799             /* Now fix up the directory */
7800
7801             /* Split up the path to find the components */
7802             sts = vms_split_path
7803                   (trn,
7804                    &v_spec,
7805                    &v_len,
7806                    &r_spec,
7807                    &r_len,
7808                    &d_spec,
7809                    &d_len,
7810                    &n_spec,
7811                    &n_len,
7812                    &e_spec,
7813                    &e_len,
7814                    &vs_spec,
7815                    &vs_len);
7816
7817             while (sts == 0) {
7818             int cmp;
7819
7820                 /* A logical name must be a directory  or the full
7821                    specification.  It is only a full specification if
7822                    it is the only component */
7823                 if ((unixptr[seg_len] == '\0') ||
7824                     (unixptr[seg_len+1] == '\0')) {
7825
7826                     /* Is a directory being required? */
7827                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7828                         /* Not a logical name */
7829                         break;
7830                     }
7831
7832
7833                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7834                         /* This must be a directory */
7835                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7836                             vmslen = my_strlcpy(vmsptr, esa, vmspath_len - 1);
7837                             vmsptr[vmslen] = ':';
7838                             vmslen++;
7839                             vmsptr[vmslen] = '\0';
7840                             return SS$_NORMAL;
7841                         }
7842                     }
7843
7844                 }
7845
7846
7847                 /* must be dev/directory - ignore version */
7848                 if ((n_len + e_len) != 0)
7849                     break;
7850
7851                 /* transfer the volume */
7852                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7853                     memcpy(vmsptr, v_spec, v_len);
7854                     vmsptr += v_len;
7855                     vmsptr[0] = '\0';
7856                     vmslen += v_len;
7857                 }
7858
7859                 /* unroot the rooted directory */
7860                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7861                     r_spec[0] = '[';
7862                     r_spec[r_len - 1] = ']';
7863
7864                     /* This should not be there, but nothing is perfect */
7865                     if (r_len > 9) {
7866                         cmp = strcmp(&r_spec[1], "000000.");
7867                         if (cmp == 0) {
7868                             r_spec += 7;
7869                             r_spec[7] = '[';
7870                             r_len -= 7;
7871                             if (r_len == 2)
7872                                 r_len = 0;
7873                         }
7874                     }
7875                     if (r_len > 0) {
7876                         memcpy(vmsptr, r_spec, r_len);
7877                         vmsptr += r_len;
7878                         vmslen += r_len;
7879                         vmsptr[0] = '\0';
7880                     }
7881                 }
7882                 /* Bring over the directory. */
7883                 if ((d_len > 0) &&
7884                     ((d_len + vmslen) < vmspath_len)) {
7885                     d_spec[0] = '[';
7886                     d_spec[d_len - 1] = ']';
7887                     if (d_len > 9) {
7888                         cmp = strcmp(&d_spec[1], "000000.");
7889                         if (cmp == 0) {
7890                             d_spec += 7;
7891                             d_spec[7] = '[';
7892                             d_len -= 7;
7893                             if (d_len == 2)
7894                                 d_len = 0;
7895                         }
7896                     }
7897
7898                     if (r_len > 0) {
7899                         /* Remove the redundant root */
7900                         if (r_len > 0) {
7901                             /* remove the ][ */
7902                             vmsptr--;
7903                             vmslen--;
7904                             d_spec++;
7905                             d_len--;
7906                         }
7907                         memcpy(vmsptr, d_spec, d_len);
7908                             vmsptr += d_len;
7909                             vmslen += d_len;
7910                             vmsptr[0] = '\0';
7911                     }
7912                 }
7913                 break;
7914             }
7915         }
7916
7917         PerlMem_free(esa);
7918         PerlMem_free(trn);
7919     }
7920
7921     if (lastslash > unixptr) {
7922     int dotdir_seen;
7923
7924       /* skip leading ./ */
7925       dotdir_seen = 0;
7926       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7927         dotdir_seen = 1;
7928         unixptr++;
7929         unixptr++;
7930       }
7931
7932       /* Are we still in a directory? */
7933       if (unixptr <= lastslash) {
7934         *vmsptr++ = '[';
7935         vmslen = 1;
7936         dir_start = 1;
7937
7938         /* if not backing up, then it is relative forward. */
7939         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7940               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7941           *vmsptr++ = '.';
7942           vmslen++;
7943           dir_dot = 1;
7944           }
7945        }
7946        else {
7947          if (dotdir_seen) {
7948            /* Perl wants an empty directory here to tell the difference
7949             * between a DCL command and a filename
7950             */
7951           *vmsptr++ = '[';
7952           *vmsptr++ = ']';
7953           vmslen = 2;
7954         }
7955       }
7956     }
7957     else {
7958       /* Handle two special files . and .. */
7959       if (unixptr[0] == '.') {
7960         if (&unixptr[1] == unixend) {
7961           *vmsptr++ = '[';
7962           *vmsptr++ = ']';
7963           vmslen += 2;
7964           *vmsptr++ = '\0';
7965           return SS$_NORMAL;
7966         }
7967         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7968           *vmsptr++ = '[';
7969           *vmsptr++ = '-';
7970           *vmsptr++ = ']';
7971           vmslen += 3;
7972           *vmsptr++ = '\0';
7973           return SS$_NORMAL;
7974         }
7975       }
7976     }
7977   }
7978   else {        /* Absolute PATH handling */
7979   int sts;
7980   char * nextslash;
7981   int seg_len;
7982     /* Need to find out where root is */
7983
7984     /* In theory, this procedure should never get an absolute POSIX pathname
7985      * that can not be found on the POSIX root.
7986      * In practice, that can not be relied on, and things will show up
7987      * here that are a VMS device name or concealed logical name instead.
7988      * So to make things work, this procedure must be tolerant.
7989      */
7990     esa = (char *)PerlMem_malloc(vmspath_len);
7991     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7992
7993     sts = SS$_NORMAL;
7994     nextslash = strchr(&unixptr[1],'/');
7995     seg_len = 0;
7996     if (nextslash != NULL) {
7997       int cmp;
7998       seg_len = nextslash - &unixptr[1];
7999       my_strlcpy(vmspath, unixptr, seg_len + 2);
8000       cmp = 1;
8001       if (seg_len == 3) {
8002         cmp = strncmp(vmspath, "dev", 4);
8003         if (cmp == 0) {
8004             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
8005             if (sts == SS$_NORMAL)
8006                 return SS$_NORMAL;
8007         }
8008       }
8009       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
8010     }
8011
8012     if ($VMS_STATUS_SUCCESS(sts)) {
8013       /* This is verified to be a real path */
8014
8015       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
8016       if ($VMS_STATUS_SUCCESS(sts)) {
8017         vmslen = my_strlcpy(vmspath, esa, vmspath_len + 1);
8018         vmsptr = vmspath + vmslen;
8019         unixptr++;
8020         if (unixptr < lastslash) {
8021         char * rptr;
8022           vmsptr--;
8023           *vmsptr++ = '.';
8024           dir_start = 1;
8025           dir_dot = 1;
8026           if (vmslen > 7) {
8027           int cmp;
8028             rptr = vmsptr - 7;
8029             cmp = strcmp(rptr,"000000.");
8030             if (cmp == 0) {
8031               vmslen -= 7;
8032               vmsptr -= 7;
8033               vmsptr[1] = '\0';
8034             } /* removing 6 zeros */
8035           } /* vmslen < 7, no 6 zeros possible */
8036         } /* Not in a directory */
8037       } /* Posix root found */
8038       else {
8039         /* No posix root, fall back to default directory */
8040         strcpy(vmspath, "SYS$DISK:[");
8041         vmsptr = &vmspath[10];
8042         vmslen = 10;
8043         if (unixptr > lastslash) {
8044            *vmsptr = ']';
8045            vmsptr++;
8046            vmslen++;
8047         }
8048         else {
8049            dir_start = 1;
8050         }
8051       }
8052     } /* end of verified real path handling */
8053     else {
8054     int add_6zero;
8055     int islnm;
8056
8057       /* Ok, we have a device or a concealed root that is not in POSIX
8058        * or we have garbage.  Make the best of it.
8059        */
8060
8061       /* Posix to VMS destroyed this, so copy it again */
8062       my_strlcpy(vmspath, &unixptr[1], seg_len + 1);
8063       vmslen = strlen(vmspath); /* We know we're truncating. */
8064       vmsptr = &vmsptr[vmslen];
8065       islnm = 0;
8066
8067       /* Now do we need to add the fake 6 zero directory to it? */
8068       add_6zero = 1;
8069       if ((*lastslash == '/') && (nextslash < lastslash)) {
8070         /* No there is another directory */
8071         add_6zero = 0;
8072       }
8073       else {
8074       int trnend;
8075       int cmp;
8076
8077         /* now we have foo:bar or foo:[000000]bar to decide from */
8078         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
8079
8080         if (!islnm && !decc_posix_compliant_pathnames) {
8081
8082             cmp = strncmp("bin", vmspath, 4);
8083             if (cmp == 0) {
8084                 /* bin => SYS$SYSTEM: */
8085                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
8086             }
8087             else {
8088                 /* tmp => SYS$SCRATCH: */
8089                 cmp = strncmp("tmp", vmspath, 4);
8090                 if (cmp == 0) {
8091                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
8092                 }
8093             }
8094         }
8095
8096         trnend = islnm ? islnm - 1 : 0;
8097
8098         /* if this was a logical name, ']' or '>' must be present */
8099         /* if not a logical name, then assume a device and hope. */
8100         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
8101
8102         /* if log name and trailing '.' then rooted - treat as device */
8103         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
8104
8105         /* Fix me, if not a logical name, a device lookup should be
8106          * done to see if the device is file structured.  If the device
8107          * is not file structured, the 6 zeros should not be put on.
8108          *
8109          * As it is, perl is occasionally looking for dev:[000000]tty.
8110          * which looks a little strange.
8111          *
8112          * Not that easy to detect as "/dev" may be file structured with
8113          * special device files.
8114          */
8115
8116         if (!islnm && (add_6zero == 0) && (*nextslash == '/') &&
8117             (&nextslash[1] == unixend)) {
8118           /* No real directory present */
8119           add_6zero = 1;
8120         }
8121       }
8122
8123       /* Put the device delimiter on */
8124       *vmsptr++ = ':';
8125       vmslen++;
8126       unixptr = nextslash;
8127       unixptr++;
8128
8129       /* Start directory if needed */
8130       if (!islnm || add_6zero) {
8131         *vmsptr++ = '[';
8132         vmslen++;
8133         dir_start = 1;
8134       }
8135
8136       /* add fake 000000] if needed */
8137       if (add_6zero) {
8138         *vmsptr++ = '0';
8139         *vmsptr++ = '0';
8140         *vmsptr++ = '0';
8141         *vmsptr++ = '0';
8142         *vmsptr++ = '0';
8143         *vmsptr++ = '0';
8144         *vmsptr++ = ']';
8145         vmslen += 7;
8146         dir_start = 0;
8147       }
8148
8149     } /* non-POSIX translation */
8150     PerlMem_free(esa);
8151   } /* End of relative/absolute path handling */
8152
8153   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
8154     int dash_flag;
8155     int in_cnt;
8156     int out_cnt;
8157
8158     dash_flag = 0;
8159
8160     if (dir_start != 0) {
8161
8162       /* First characters in a directory are handled special */
8163       while ((*unixptr == '/') ||
8164              ((*unixptr == '.') &&
8165               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8166                 (&unixptr[1]==unixend)))) {
8167       int loop_flag;
8168
8169         loop_flag = 0;
8170
8171         /* Skip redundant / in specification */
8172         while ((*unixptr == '/') && (dir_start != 0)) {
8173           loop_flag = 1;
8174           unixptr++;
8175           if (unixptr == lastslash)
8176             break;
8177         }
8178         if (unixptr == lastslash)
8179           break;
8180
8181         /* Skip redundant ./ characters */
8182         while ((*unixptr == '.') &&
8183                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8184           loop_flag = 1;
8185           unixptr++;
8186           if (unixptr == lastslash)
8187             break;
8188           if (*unixptr == '/')
8189             unixptr++;
8190         }
8191         if (unixptr == lastslash)
8192           break;
8193
8194         /* Skip redundant ../ characters */
8195         while ((*unixptr == '.') && (unixptr[1] == '.') &&
8196              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8197           /* Set the backing up flag */
8198           loop_flag = 1;
8199           dir_dot = 0;
8200           dash_flag = 1;
8201           *vmsptr++ = '-';
8202           vmslen++;
8203           unixptr++; /* first . */
8204           unixptr++; /* second . */
8205           if (unixptr == lastslash)
8206             break;
8207           if (*unixptr == '/') /* The slash */
8208             unixptr++;
8209         }
8210         if (unixptr == lastslash)
8211           break;
8212
8213         /* To do: Perl expects /.../ to be translated to [...] on VMS */
8214         /* Not needed when VMS is pretending to be UNIX. */
8215
8216         /* Is this loop stuck because of too many dots? */
8217         if (loop_flag == 0) {
8218           /* Exit the loop and pass the rest through */
8219           break;
8220         }
8221       }
8222
8223       /* Are we done with directories yet? */
8224       if (unixptr >= lastslash) {
8225
8226         /* Watch out for trailing dots */
8227         if (dir_dot != 0) {
8228             vmslen --;
8229             vmsptr--;
8230         }
8231         *vmsptr++ = ']';
8232         vmslen++;
8233         dash_flag = 0;
8234         dir_start = 0;
8235         if (*unixptr == '/')
8236           unixptr++;
8237       }
8238       else {
8239         /* Have we stopped backing up? */
8240         if (dash_flag) {
8241           *vmsptr++ = '.';
8242           vmslen++;
8243           dash_flag = 0;
8244           /* dir_start continues to be = 1 */
8245         }
8246         if (*unixptr == '-') {
8247           *vmsptr++ = '^';
8248           *vmsptr++ = *unixptr++;
8249           vmslen += 2;
8250           dir_start = 0;
8251
8252           /* Now are we done with directories yet? */
8253           if (unixptr >= lastslash) {
8254
8255             /* Watch out for trailing dots */
8256             if (dir_dot != 0) {
8257               vmslen --;
8258               vmsptr--;
8259             }
8260
8261             *vmsptr++ = ']';
8262             vmslen++;
8263             dash_flag = 0;
8264             dir_start = 0;
8265           }
8266         }
8267       }
8268     }
8269
8270     /* All done? */
8271     if (unixptr >= unixend)
8272       break;
8273
8274     /* Normal characters - More EFS work probably needed */
8275     dir_start = 0;
8276     dir_dot = 0;
8277
8278     switch(*unixptr) {
8279     case '/':
8280         /* remove multiple / */
8281         while (unixptr[1] == '/') {
8282            unixptr++;
8283         }
8284         if (unixptr == lastslash) {
8285           /* Watch out for trailing dots */
8286           if (dir_dot != 0) {
8287             vmslen --;
8288             vmsptr--;
8289           }
8290           *vmsptr++ = ']';
8291         }
8292         else {
8293           dir_start = 1;
8294           *vmsptr++ = '.';
8295           dir_dot = 1;
8296
8297           /* To do: Perl expects /.../ to be translated to [...] on VMS */
8298           /* Not needed when VMS is pretending to be UNIX. */
8299
8300         }
8301         dash_flag = 0;
8302         if (unixptr != unixend)
8303           unixptr++;
8304         vmslen++;
8305         break;
8306     case '.':
8307         if ((unixptr < lastdot) || (unixptr < lastslash) ||
8308             (&unixptr[1] == unixend)) {
8309           *vmsptr++ = '^';
8310           *vmsptr++ = '.';
8311           vmslen += 2;
8312           unixptr++;
8313
8314           /* trailing dot ==> '^..' on VMS */
8315           if (unixptr == unixend) {
8316             *vmsptr++ = '.';
8317             vmslen++;
8318             unixptr++;
8319           }
8320           break;
8321         }
8322
8323         *vmsptr++ = *unixptr++;
8324         vmslen ++;
8325         break;
8326     case '"':
8327         if (quoted && (&unixptr[1] == unixend)) {
8328             unixptr++;
8329             break;
8330         }
8331         in_cnt = copy_expand_unix_filename_escape
8332                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8333         vmsptr += out_cnt;
8334         unixptr += in_cnt;
8335         break;
8336     case '~':
8337     case ';':
8338     case '\\':
8339     case '?':
8340     case ' ':
8341     default:
8342         in_cnt = copy_expand_unix_filename_escape
8343                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8344         vmsptr += out_cnt;
8345         unixptr += in_cnt;
8346         break;
8347     }
8348   }
8349
8350   /* Make sure directory is closed */
8351   if (unixptr == lastslash) {
8352     char *vmsptr2;
8353     vmsptr2 = vmsptr - 1;
8354
8355     if (*vmsptr2 != ']') {
8356       *vmsptr2--;
8357
8358       /* directories do not end in a dot bracket */
8359       if (*vmsptr2 == '.') {
8360         vmsptr2--;
8361
8362         /* ^. is allowed */
8363         if (*vmsptr2 != '^') {
8364           vmsptr--; /* back up over the dot */
8365         }
8366       }
8367       *vmsptr++ = ']';
8368     }
8369   }
8370   else {
8371     char *vmsptr2;
8372     /* Add a trailing dot if a file with no extension */
8373     vmsptr2 = vmsptr - 1;
8374     if ((vmslen > 1) &&
8375         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8376         (*vmsptr2 != ')') && (*lastdot != '.') && (*vmsptr2 != ':')) {
8377         *vmsptr++ = '.';
8378         vmslen++;
8379     }
8380   }
8381
8382   *vmsptr = '\0';
8383   return SS$_NORMAL;
8384 }
8385
8386 /* A convenience macro for copying dots in filenames and escaping
8387  * them when they haven't already been escaped, with guards to
8388  * avoid checking before the start of the buffer or advancing
8389  * beyond the end of it (allowing room for the NUL terminator).
8390  */
8391 #define VMSEFS_DOT_WITH_ESCAPE(vmsefsdot,vmsefsbuf,vmsefsbufsiz) STMT_START { \
8392     if ( ((vmsefsdot) > (vmsefsbuf) && *((vmsefsdot) - 1) != '^' \
8393           || ((vmsefsdot) == (vmsefsbuf))) \
8394          && (vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 3 \
8395        ) { \
8396         *((vmsefsdot)++) = '^'; \
8397     } \
8398     if ((vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 2) \
8399         *((vmsefsdot)++) = '.'; \
8400 } STMT_END
8401
8402 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8403 static char *
8404 int_tovmsspec(const char *path, char *rslt, int dir_flag, int * utf8_flag)
8405 {
8406   char *dirend;
8407   char *lastdot;
8408   char *cp1;
8409   const char *cp2;
8410   unsigned long int infront = 0, hasdir = 1;
8411   int rslt_len;
8412   int no_type_seen;
8413   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8414   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8415
8416   if (vms_debug_fileify) {
8417       if (path == NULL)
8418           fprintf(stderr, "int_tovmsspec: path = NULL\n");
8419       else
8420           fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8421   }
8422
8423   if (path == NULL) {
8424       /* If we fail, we should be setting errno */
8425       set_errno(EINVAL);
8426       set_vaxc_errno(SS$_BADPARAM);
8427       return NULL;
8428   }
8429   rslt_len = VMS_MAXRSS-1;
8430
8431   /* '.' and '..' are "[]" and "[-]" for a quick check */
8432   if (path[0] == '.') {
8433     if (path[1] == '\0') {
8434       strcpy(rslt,"[]");
8435       if (utf8_flag != NULL)
8436         *utf8_flag = 0;
8437       return rslt;
8438     }
8439     else {
8440       if (path[1] == '.' && path[2] == '\0') {
8441         strcpy(rslt,"[-]");
8442         if (utf8_flag != NULL)
8443            *utf8_flag = 0;
8444         return rslt;
8445       }
8446     }
8447   }
8448
8449    /* Posix specifications are now a native VMS format */
8450   /*--------------------------------------------------*/
8451 #if __CRTL_VER >= 80200000
8452   if (decc_posix_compliant_pathnames) {
8453     if (strncmp(path,"\"^UP^",5) == 0) {
8454       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8455       return rslt;
8456     }
8457   }
8458 #endif
8459
8460   /* This is really the only way to see if this is already in VMS format */
8461   sts = vms_split_path
8462        (path,
8463         &v_spec,
8464         &v_len,
8465         &r_spec,
8466         &r_len,
8467         &d_spec,
8468         &d_len,
8469         &n_spec,
8470         &n_len,
8471         &e_spec,
8472         &e_len,
8473         &vs_spec,
8474         &vs_len);
8475   if (sts == 0) {
8476     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8477        replacement, because the above parse just took care of most of
8478        what is needed to do vmspath when the specification is already
8479        in VMS format.
8480
8481        And if it is not already, it is easier to do the conversion as
8482        part of this routine than to call this routine and then work on
8483        the result.
8484      */
8485
8486     /* If VMS punctuation was found, it is already VMS format */
8487     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8488       if (utf8_flag != NULL)
8489         *utf8_flag = 0;
8490       my_strlcpy(rslt, path, VMS_MAXRSS);
8491       if (vms_debug_fileify) {
8492           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8493       }
8494       return rslt;
8495     }
8496     /* Now, what to do with trailing "." cases where there is no
8497        extension?  If this is a UNIX specification, and EFS characters
8498        are enabled, then the trailing "." should be converted to a "^.".
8499        But if this was already a VMS specification, then it should be
8500        left alone.
8501
8502        So in the case of ambiguity, leave the specification alone.
8503      */
8504
8505
8506     /* If there is a possibility of UTF8, then if any UTF8 characters
8507         are present, then they must be converted to VTF-7
8508      */
8509     if (utf8_flag != NULL)
8510       *utf8_flag = 0;
8511     my_strlcpy(rslt, path, VMS_MAXRSS);
8512     if (vms_debug_fileify) {
8513         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8514     }
8515     return rslt;
8516   }
8517
8518   dirend = strrchr(path,'/');
8519
8520   if (dirend == NULL) {
8521      /* If we get here with no Unix directory delimiters, then this is an
8522       * ambiguous file specification, such as a Unix glob specification, a
8523       * shell or make macro, or a filespec that would be valid except for
8524       * unescaped extended characters.  The safest thing if it's a macro
8525       * is to pass it through as-is.
8526       */
8527       if (strstr(path, "$(")) {
8528           my_strlcpy(rslt, path, VMS_MAXRSS);
8529           if (vms_debug_fileify) {
8530               fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8531           }
8532           return rslt;
8533       }
8534       hasdir = 0;
8535   }
8536   else if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
8537     if (!*(dirend+2)) dirend +=2;
8538     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8539     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8540   }
8541
8542   cp1 = rslt;
8543   cp2 = path;
8544   lastdot = strrchr(cp2,'.');
8545   if (*cp2 == '/') {
8546     char *trndev;
8547     int islnm, rooted;
8548     STRLEN trnend;
8549
8550     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8551     if (!*(cp2+1)) {
8552       if (decc_disable_posix_root) {
8553         strcpy(rslt,"sys$disk:[000000]");
8554       }
8555       else {
8556         strcpy(rslt,"sys$posix_root:[000000]");
8557       }
8558       if (utf8_flag != NULL)
8559         *utf8_flag = 0;
8560       if (vms_debug_fileify) {
8561           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8562       }
8563       return rslt;
8564     }
8565     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8566     *cp1 = '\0';
8567     trndev = (char *)PerlMem_malloc(VMS_MAXRSS);
8568     if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8569     islnm =  simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8570
8571      /* DECC special handling */
8572     if (!islnm) {
8573       if (strcmp(rslt,"bin") == 0) {
8574         strcpy(rslt,"sys$system");
8575         cp1 = rslt + 10;
8576         *cp1 = 0;
8577         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8578       }
8579       else if (strcmp(rslt,"tmp") == 0) {
8580         strcpy(rslt,"sys$scratch");
8581         cp1 = rslt + 11;
8582         *cp1 = 0;
8583         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8584       }
8585       else if (!decc_disable_posix_root) {
8586         strcpy(rslt, "sys$posix_root");
8587         cp1 = rslt + 14;
8588         *cp1 = 0;
8589         cp2 = path;
8590         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8591         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8592       }
8593       else if (strcmp(rslt,"dev") == 0) {
8594         if (strncmp(cp2,"/null", 5) == 0) {
8595           if ((cp2[5] == 0) || (cp2[5] == '/')) {
8596             strcpy(rslt,"NLA0");
8597             cp1 = rslt + 4;
8598             *cp1 = 0;
8599             cp2 = cp2 + 5;
8600             islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8601           }
8602         }
8603       }
8604     }
8605
8606     trnend = islnm ? strlen(trndev) - 1 : 0;
8607     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8608     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8609     /* If the first element of the path is a logical name, determine
8610      * whether it has to be translated so we can add more directories. */
8611     if (!islnm || rooted) {
8612       *(cp1++) = ':';
8613       *(cp1++) = '[';
8614       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8615       else cp2++;
8616     }
8617     else {
8618       if (cp2 != dirend) {
8619         my_strlcpy(rslt, trndev, VMS_MAXRSS);
8620         cp1 = rslt + trnend;
8621         if (*cp2 != 0) {
8622           *(cp1++) = '.';
8623           cp2++;
8624         }
8625       }
8626       else {
8627         if (decc_disable_posix_root) {
8628           *(cp1++) = ':';
8629           hasdir = 0;
8630         }
8631       }
8632     }
8633     PerlMem_free(trndev);
8634   }
8635   else if (hasdir) {
8636     *(cp1++) = '[';
8637     if (*cp2 == '.') {
8638       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8639         cp2 += 2;         /* skip over "./" - it's redundant */
8640         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8641       }
8642       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8643         *(cp1++) = '-';                                 /* "../" --> "-" */
8644         cp2 += 3;
8645       }
8646       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8647                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8648         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8649         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8650         cp2 += 4;
8651       }
8652       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8653         /* Escape the extra dots in EFS file specifications */
8654         *(cp1++) = '^';
8655       }
8656       if (cp2 > dirend) cp2 = dirend;
8657     }
8658     else *(cp1++) = '.';
8659   }
8660   for (; cp2 < dirend; cp2++) {
8661     if (*cp2 == '/') {
8662       if (*(cp2-1) == '/') continue;
8663       if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.';
8664       infront = 0;
8665     }
8666     else if (!infront && *cp2 == '.') {
8667       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8668       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8669       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8670         if (cp1 > rslt && (*(cp1-1) == '-' || *(cp1-1) == '[')) *(cp1++) = '-'; /* handle "../" */
8671         else if (cp1 > rslt + 1 && *(cp1-2) == '[') *(cp1-1) = '-';
8672         else {
8673           *(cp1++) = '-';
8674         }
8675         cp2 += 2;
8676         if (cp2 == dirend) break;
8677       }
8678       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8679                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8680         if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8681         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8682         if (!*(cp2+3)) {
8683           *(cp1++) = '.';  /* Simulate trailing '/' */
8684           cp2 += 2;  /* for loop will incr this to == dirend */
8685         }
8686         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8687       }
8688       else {
8689         if (decc_efs_charset == 0) {
8690           if (cp1 > rslt && *(cp1-1) == '^')
8691             cp1--;         /* remove the escape, if any */
8692           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8693         }
8694         else {
8695           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8696         }
8697       }
8698     }
8699     else {
8700       if (!infront && cp1 > rslt && *(cp1-1) == '-')  *(cp1++) = '.';
8701       if (*cp2 == '.') {
8702         if (decc_efs_charset == 0) {
8703           if (cp1 > rslt && *(cp1-1) == '^')
8704             cp1--;         /* remove the escape, if any */
8705           *(cp1++) = '_';
8706         }
8707         else {
8708           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8709         }
8710       }
8711       else {
8712         int out_cnt;
8713         cp2 += copy_expand_unix_filename_escape(cp1, cp2, &out_cnt, utf8_flag);
8714         cp2--; /* we're in a loop that will increment this */
8715         cp1 += out_cnt;
8716       }
8717       infront = 1;
8718     }
8719   }
8720   if (cp1 > rslt && *(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8721   if (hasdir) *(cp1++) = ']';
8722   if (*cp2 && *cp2 == '/') cp2++;  /* check in case we ended with trailing '/' */
8723   no_type_seen = 0;
8724   if (cp2 > lastdot)
8725     no_type_seen = 1;
8726   while (*cp2) {
8727     switch(*cp2) {
8728     case '?':
8729         if (decc_efs_charset == 0)
8730           *(cp1++) = '%';
8731         else
8732           *(cp1++) = '?';
8733         cp2++;
8734     case ' ':
8735         if (cp2 >= path && (cp2 == path || *(cp2-1) != '^')) /* not previously escaped */
8736             *(cp1)++ = '^';
8737         *(cp1)++ = '_';
8738         cp2++;
8739         break;
8740     case '.':
8741         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8742             decc_readdir_dropdotnotype) {
8743           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8744           cp2++;
8745
8746           /* trailing dot ==> '^..' on VMS */
8747           if (*cp2 == '\0') {
8748             *(cp1++) = '.';
8749             no_type_seen = 0;
8750           }
8751         }
8752         else {
8753           *(cp1++) = *(cp2++);
8754           no_type_seen = 0;
8755         }
8756         break;
8757     case '$':
8758          /* This could be a macro to be passed through */
8759         *(cp1++) = *(cp2++);
8760         if (*cp2 == '(') {
8761         const char * save_cp2;
8762         char * save_cp1;
8763         int is_macro;
8764
8765             /* paranoid check */
8766             save_cp2 = cp2;
8767             save_cp1 = cp1;
8768             is_macro = 0;
8769
8770             /* Test through */
8771             *(cp1++) = *(cp2++);
8772             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8773                 *(cp1++) = *(cp2++);
8774                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8775                     *(cp1++) = *(cp2++);
8776                 }
8777                 if (*cp2 == ')') {
8778                     *(cp1++) = *(cp2++);
8779                     is_macro = 1;
8780                 }
8781             }
8782             if (is_macro == 0) {
8783                 /* Not really a macro - never mind */
8784                 cp2 = save_cp2;
8785                 cp1 = save_cp1;
8786             }
8787         }
8788         break;
8789     case '\"':
8790     case '~':
8791     case '`':
8792     case '!':
8793     case '#':
8794     case '%':
8795     case '^':
8796         /* Don't escape again if following character is
8797          * already something we escape.
8798          */
8799         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8800             *(cp1++) = *(cp2++);
8801             break;
8802         }
8803         /* But otherwise fall through and escape it. */
8804     case '&':
8805     case '(':
8806     case ')':
8807     case '=':
8808     case '+':
8809     case '\'':
8810     case '@':
8811     case '[':
8812     case ']':
8813     case '{':
8814     case '}':
8815     case ':':
8816     case '\\':
8817     case '|':
8818     case '<':
8819     case '>':
8820         if (cp2 >= path && *(cp2-1) != '^') /* not previously escaped */
8821             *(cp1++) = '^';
8822         *(cp1++) = *(cp2++);
8823         break;
8824     case ';':
8825         /* If it doesn't look like the beginning of a version number,
8826          * or we've been promised there are no version numbers, then
8827          * escape it.
8828          */
8829         if (decc_filename_unix_no_version) {
8830           *(cp1++) = '^';
8831         }
8832         else {
8833           size_t all_nums = strspn(cp2+1, "0123456789");
8834           if (all_nums > 5 || *(cp2 + all_nums + 1) != '\0')
8835             *(cp1++) = '^';
8836         }
8837         *(cp1++) = *(cp2++);
8838         break;
8839     default:
8840         *(cp1++) = *(cp2++);
8841     }
8842   }
8843   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8844   char *lcp1;
8845     lcp1 = cp1;
8846     lcp1--;
8847      /* Fix me for "^]", but that requires making sure that you do
8848       * not back up past the start of the filename
8849       */
8850     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8851       *cp1++ = '.';
8852   }
8853   *cp1 = '\0';
8854
8855   if (utf8_flag != NULL)
8856     *utf8_flag = 0;
8857   if (vms_debug_fileify) {
8858       fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8859   }
8860   return rslt;
8861
8862 }  /* end of int_tovmsspec() */
8863
8864
8865 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8866 static char *
8867 mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag)
8868 {
8869     static char __tovmsspec_retbuf[VMS_MAXRSS];
8870     char * vmsspec, *ret_spec, *ret_buf;
8871
8872     vmsspec = NULL;
8873     ret_buf = buf;
8874     if (ret_buf == NULL) {
8875         if (ts) {
8876             Newx(vmsspec, VMS_MAXRSS, char);
8877             if (vmsspec == NULL)
8878                 _ckvmssts(SS$_INSFMEM);
8879             ret_buf = vmsspec;
8880         } else {
8881             ret_buf = __tovmsspec_retbuf;
8882         }
8883     }
8884
8885     ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
8886
8887     if (ret_spec == NULL) {
8888        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
8889        if (vmsspec)
8890            Safefree(vmsspec);
8891     }
8892
8893     return ret_spec;
8894
8895 }  /* end of mp_do_tovmsspec() */
8896 /*}}}*/
8897 /* External entry points */
8898 char *
8899 Perl_tovmsspec(pTHX_ const char *path, char *buf)
8900 {
8901     return do_tovmsspec(path, buf, 0, NULL);
8902 }
8903
8904 char *
8905 Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8906 {
8907     return do_tovmsspec(path, buf, 1, NULL);
8908 }
8909
8910 char *
8911 Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8912 {
8913     return do_tovmsspec(path, buf, 0, utf8_fl);
8914 }
8915
8916 char *
8917 Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8918 {
8919     return do_tovmsspec(path, buf, 1, utf8_fl);
8920 }
8921
8922 /*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
8923 /* Internal routine for use with out an explicit context present */
8924 static char *
8925 int_tovmspath(const char *path, char *buf, int * utf8_fl)
8926 {
8927     char * ret_spec, *pathified;
8928
8929     if (path == NULL)
8930         return NULL;
8931
8932     pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8933     if (pathified == NULL)
8934         _ckvmssts_noperl(SS$_INSFMEM);
8935
8936     ret_spec = int_pathify_dirspec(path, pathified);
8937
8938     if (ret_spec == NULL) {
8939         PerlMem_free(pathified);
8940         return NULL;
8941     }
8942
8943     ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
8944
8945     PerlMem_free(pathified);
8946     return ret_spec;
8947
8948 }
8949
8950 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8951 static char *
8952 mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl)
8953 {
8954   static char __tovmspath_retbuf[VMS_MAXRSS];
8955   int vmslen;
8956   char *pathified, *vmsified, *cp;
8957
8958   if (path == NULL) return NULL;
8959   pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8960   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8961   if (int_pathify_dirspec(path, pathified) == NULL) {
8962     PerlMem_free(pathified);
8963     return NULL;
8964   }
8965
8966   vmsified = NULL;
8967   if (buf == NULL)
8968      Newx(vmsified, VMS_MAXRSS, char);
8969   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8970     PerlMem_free(pathified);
8971     if (vmsified) Safefree(vmsified);
8972     return NULL;
8973   }
8974   PerlMem_free(pathified);
8975   if (buf) {
8976     return buf;
8977   }
8978   else if (ts) {
8979     vmslen = strlen(vmsified);
8980     Newx(cp,vmslen+1,char);
8981     memcpy(cp,vmsified,vmslen);
8982     cp[vmslen] = '\0';
8983     Safefree(vmsified);
8984     return cp;
8985   }
8986   else {
8987     my_strlcpy(__tovmspath_retbuf, vmsified, sizeof(__tovmspath_retbuf));
8988     Safefree(vmsified);
8989     return __tovmspath_retbuf;
8990   }
8991
8992 }  /* end of do_tovmspath() */
8993 /*}}}*/
8994 /* External entry points */
8995 char *
8996 Perl_tovmspath(pTHX_ const char *path, char *buf)
8997 {
8998     return do_tovmspath(path, buf, 0, NULL);
8999 }
9000
9001 char *
9002 Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
9003 {
9004     return do_tovmspath(path, buf, 1, NULL);
9005 }
9006
9007 char *
9008 Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
9009 {
9010     return do_tovmspath(path, buf, 0, utf8_fl);
9011 }
9012
9013 char *
9014 Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
9015 {
9016     return do_tovmspath(path, buf, 1, utf8_fl);
9017 }
9018
9019
9020 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
9021 static char *
9022 mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl)
9023 {
9024   static char __tounixpath_retbuf[VMS_MAXRSS];
9025   int unixlen;
9026   char *pathified, *unixified, *cp;
9027
9028   if (path == NULL) return NULL;
9029   pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
9030   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
9031   if (int_pathify_dirspec(path, pathified) == NULL) {
9032     PerlMem_free(pathified);
9033     return NULL;
9034   }
9035
9036   unixified = NULL;
9037   if (buf == NULL) {
9038       Newx(unixified, VMS_MAXRSS, char);
9039   }
9040   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
9041     PerlMem_free(pathified);
9042     if (unixified) Safefree(unixified);
9043     return NULL;
9044   }
9045   PerlMem_free(pathified);
9046   if (buf) {
9047     return buf;
9048   }
9049   else if (ts) {
9050     unixlen = strlen(unixified);
9051     Newx(cp,unixlen+1,char);
9052     memcpy(cp,unixified,unixlen);
9053     cp[unixlen] = '\0';
9054     Safefree(unixified);
9055     return cp;
9056   }
9057   else {
9058     my_strlcpy(__tounixpath_retbuf, unixified, sizeof(__tounixpath_retbuf));
9059     Safefree(unixified);
9060     return __tounixpath_retbuf;
9061   }
9062
9063 }  /* end of do_tounixpath() */
9064 /*}}}*/
9065 /* External entry points */
9066 char *
9067 Perl_tounixpath(pTHX_ const char *path, char *buf)
9068 {
9069     return do_tounixpath(path, buf, 0, NULL);
9070 }
9071
9072 char *
9073 Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
9074 {
9075     return do_tounixpath(path, buf, 1, NULL);
9076 }
9077
9078 char *
9079 Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9080 {
9081     return do_tounixpath(path, buf, 0, utf8_fl);
9082 }
9083
9084 char *
9085 Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9086 {
9087     return do_tounixpath(path, buf, 1, utf8_fl);
9088 }
9089
9090 /*
9091  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
9092  *
9093  *****************************************************************************
9094  *                                                                           *
9095  *  Copyright (C) 1989-1994, 2007 by                                         *
9096  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
9097  *                                                                           *
9098  *  Permission is hereby granted for the reproduction of this software       *
9099  *  on condition that this copyright notice is included in source            *
9100  *  distributions of the software.  The code may be modified and             *
9101  *  distributed under the same terms as Perl itself.                         *
9102  *                                                                           *
9103  *  27-Aug-1994 Modified for inclusion in perl5                              *
9104  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
9105  *****************************************************************************
9106  */
9107
9108 /*
9109  * getredirection() is intended to aid in porting C programs
9110  * to VMS (Vax-11 C).  The native VMS environment does not support
9111  * '>' and '<' I/O redirection, or command line wild card expansion,
9112  * or a command line pipe mechanism using the '|' AND background
9113  * command execution '&'.  All of these capabilities are provided to any
9114  * C program which calls this procedure as the first thing in the
9115  * main program.
9116  * The piping mechanism will probably work with almost any 'filter' type
9117  * of program.  With suitable modification, it may useful for other
9118  * portability problems as well.
9119  *
9120  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
9121  */
9122 struct list_item
9123     {
9124     struct list_item *next;
9125     char *value;
9126     };
9127
9128 static void add_item(struct list_item **head,
9129                      struct list_item **tail,
9130                      char *value,
9131                      int *count);
9132
9133 static void mp_expand_wild_cards(pTHX_ char *item,
9134                                 struct list_item **head,
9135                                 struct list_item **tail,
9136                                 int *count);
9137
9138 static int background_process(pTHX_ int argc, char **argv);
9139
9140 static void pipe_and_fork(pTHX_ char **cmargv);
9141
9142 /*{{{ void getredirection(int *ac, char ***av)*/
9143 static void
9144 mp_getredirection(pTHX_ int *ac, char ***av)
9145 /*
9146  * Process vms redirection arg's.  Exit if any error is seen.
9147  * If getredirection() processes an argument, it is erased
9148  * from the vector.  getredirection() returns a new argc and argv value.
9149  * In the event that a background command is requested (by a trailing "&"),
9150  * this routine creates a background subprocess, and simply exits the program.
9151  *
9152  * Warning: do not try to simplify the code for vms.  The code
9153  * presupposes that getredirection() is called before any data is
9154  * read from stdin or written to stdout.
9155  *
9156  * Normal usage is as follows:
9157  *
9158  *      main(argc, argv)
9159  *      int             argc;
9160  *      char            *argv[];
9161  *      {
9162  *              getredirection(&argc, &argv);
9163  *      }
9164  */
9165 {
9166     int                 argc = *ac;     /* Argument Count         */
9167     char                **argv = *av;   /* Argument Vector        */
9168     char                *ap;            /* Argument pointer       */
9169     int                 j;              /* argv[] index           */
9170     int                 item_count = 0; /* Count of Items in List */
9171     struct list_item    *list_head = 0; /* First Item in List       */
9172     struct list_item    *list_tail;     /* Last Item in List        */
9173     char                *in = NULL;     /* Input File Name          */
9174     char                *out = NULL;    /* Output File Name         */
9175     char                *outmode = "w"; /* Mode to Open Output File */
9176     char                *err = NULL;    /* Error File Name          */
9177     char                *errmode = "w"; /* Mode to Open Error File  */
9178     int                 cmargc = 0;     /* Piped Command Arg Count  */
9179     char                **cmargv = NULL;/* Piped Command Arg Vector */
9180
9181     /*
9182      * First handle the case where the last thing on the line ends with
9183      * a '&'.  This indicates the desire for the command to be run in a
9184      * subprocess, so we satisfy that desire.
9185      */
9186     ap = argv[argc-1];
9187     if (0 == strcmp("&", ap))
9188        exit(background_process(aTHX_ --argc, argv));
9189     if (*ap && '&' == ap[strlen(ap)-1])
9190         {
9191         ap[strlen(ap)-1] = '\0';
9192        exit(background_process(aTHX_ argc, argv));
9193         }
9194     /*
9195      * Now we handle the general redirection cases that involve '>', '>>',
9196      * '<', and pipes '|'.
9197      */
9198     for (j = 0; j < argc; ++j)
9199         {
9200         if (0 == strcmp("<", argv[j]))
9201             {
9202             if (j+1 >= argc)
9203                 {
9204                 fprintf(stderr,"No input file after < on command line");
9205                 exit(LIB$_WRONUMARG);
9206                 }
9207             in = argv[++j];
9208             continue;
9209             }
9210         if ('<' == *(ap = argv[j]))
9211             {
9212             in = 1 + ap;
9213             continue;
9214             }
9215         if (0 == strcmp(">", ap))
9216             {
9217             if (j+1 >= argc)
9218                 {
9219                 fprintf(stderr,"No output file after > on command line");
9220                 exit(LIB$_WRONUMARG);
9221                 }
9222             out = argv[++j];
9223             continue;
9224             }
9225         if ('>' == *ap)
9226             {
9227             if ('>' == ap[1])
9228                 {
9229                 outmode = "a";
9230                 if ('\0' == ap[2])
9231                     out = argv[++j];
9232                 else
9233                     out = 2 + ap;
9234                 }
9235             else
9236                 out = 1 + ap;
9237             if (j >= argc)
9238                 {
9239                 fprintf(stderr,"No output file after > or >> on command line");
9240                 exit(LIB$_WRONUMARG);
9241                 }
9242             continue;
9243             }
9244         if (('2' == *ap) && ('>' == ap[1]))
9245             {
9246             if ('>' == ap[2])
9247                 {
9248                 errmode = "a";
9249                 if ('\0' == ap[3])
9250                     err = argv[++j];
9251                 else
9252                     err = 3 + ap;
9253                 }
9254             else
9255                 if ('\0' == ap[2])
9256                     err = argv[++j];
9257                 else
9258                     err = 2 + ap;
9259             if (j >= argc)
9260                 {
9261                 fprintf(stderr,"No output file after 2> or 2>> on command line");
9262                 exit(LIB$_WRONUMARG);
9263                 }
9264             continue;
9265             }
9266         if (0 == strcmp("|", argv[j]))
9267             {
9268             if (j+1 >= argc)
9269                 {
9270                 fprintf(stderr,"No command into which to pipe on command line");
9271                 exit(LIB$_WRONUMARG);
9272                 }
9273             cmargc = argc-(j+1);
9274             cmargv = &argv[j+1];
9275             argc = j;
9276             continue;
9277             }
9278         if ('|' == *(ap = argv[j]))
9279             {
9280             ++argv[j];
9281             cmargc = argc-j;
9282             cmargv = &argv[j];
9283             argc = j;
9284             continue;
9285             }
9286         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9287         }
9288     /*
9289      * Allocate and fill in the new argument vector, Some Unix's terminate
9290      * the list with an extra null pointer.
9291      */
9292     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9293     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9294     *av = argv;
9295     for (j = 0; j < item_count; ++j, list_head = list_head->next)
9296         argv[j] = list_head->value;
9297     *ac = item_count;
9298     if (cmargv != NULL)
9299         {
9300         if (out != NULL)
9301             {
9302             fprintf(stderr,"'|' and '>' may not both be specified on command line");
9303             exit(LIB$_INVARGORD);
9304             }
9305         pipe_and_fork(aTHX_ cmargv);
9306         }
9307
9308     /* Check for input from a pipe (mailbox) */
9309
9310     if (in == NULL && 1 == isapipe(0))
9311         {
9312         char mbxname[L_tmpnam];
9313         long int bufsize;
9314         long int dvi_item = DVI$_DEVBUFSIZ;
9315         $DESCRIPTOR(mbxnam, "");
9316         $DESCRIPTOR(mbxdevnam, "");
9317
9318         /* Input from a pipe, reopen it in binary mode to disable       */
9319         /* carriage control processing.                                 */
9320
9321         fgetname(stdin, mbxname, 1);
9322         mbxnam.dsc$a_pointer = mbxname;
9323         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9324         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9325         mbxdevnam.dsc$a_pointer = mbxname;
9326         mbxdevnam.dsc$w_length = sizeof(mbxname);
9327         dvi_item = DVI$_DEVNAM;
9328         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9329         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9330         set_errno(0);
9331         set_vaxc_errno(1);
9332         freopen(mbxname, "rb", stdin);
9333         if (errno != 0)
9334             {
9335             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9336             exit(vaxc$errno);
9337             }
9338         }
9339     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9340         {
9341         fprintf(stderr,"Can't open input file %s as stdin",in);
9342         exit(vaxc$errno);
9343         }
9344     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9345         {
9346         fprintf(stderr,"Can't open output file %s as stdout",out);
9347         exit(vaxc$errno);
9348         }
9349         if (out != NULL) vmssetuserlnm("SYS$OUTPUT", out);
9350
9351     if (err != NULL) {
9352         if (strcmp(err,"&1") == 0) {
9353             dup2(fileno(stdout), fileno(stderr));
9354             vmssetuserlnm("SYS$ERROR", "SYS$OUTPUT");
9355         } else {
9356         FILE *tmperr;
9357         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9358             {
9359             fprintf(stderr,"Can't open error file %s as stderr",err);
9360             exit(vaxc$errno);
9361             }
9362             fclose(tmperr);
9363            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9364                 {
9365                 exit(vaxc$errno);
9366                 }
9367             vmssetuserlnm("SYS$ERROR", err);
9368         }
9369         }
9370 #ifdef ARGPROC_DEBUG
9371     PerlIO_printf(Perl_debug_log, "Arglist:\n");
9372     for (j = 0; j < *ac;  ++j)
9373         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9374 #endif
9375    /* Clear errors we may have hit expanding wildcards, so they don't
9376       show up in Perl's $! later */
9377    set_errno(0); set_vaxc_errno(1);
9378 }  /* end of getredirection() */
9379 /*}}}*/
9380
9381 static void
9382 add_item(struct list_item **head, struct list_item **tail, char *value, int *count)
9383 {
9384     if (*head == 0)
9385         {
9386         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9387         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9388         *tail = *head;
9389         }
9390     else {
9391         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9392         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9393         *tail = (*tail)->next;
9394         }
9395     (*tail)->value = value;
9396     ++(*count);
9397 }
9398
9399 static void
9400 mp_expand_wild_cards(pTHX_ char *item, struct list_item **head,
9401                      struct list_item **tail, int *count)
9402 {
9403     int expcount = 0;
9404     unsigned long int context = 0;
9405     int isunix = 0;
9406     int item_len = 0;
9407     char *had_version;
9408     char *had_device;
9409     int had_directory;
9410     char *devdir,*cp;
9411     char *vmsspec;
9412     $DESCRIPTOR(filespec, "");
9413     $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9414     $DESCRIPTOR(resultspec, "");
9415     unsigned long int lff_flags = 0;
9416     int sts;
9417     int rms_sts;
9418
9419 #ifdef VMS_LONGNAME_SUPPORT
9420     lff_flags = LIB$M_FIL_LONG_NAMES;
9421 #endif
9422
9423     for (cp = item; *cp; cp++) {
9424         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9425         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9426     }
9427     if (!*cp || isspace(*cp))
9428         {
9429         add_item(head, tail, item, count);
9430         return;
9431         }
9432     else
9433         {
9434      /* "double quoted" wild card expressions pass as is */
9435      /* From DCL that means using e.g.:                  */
9436      /* perl program """perl.*"""                        */
9437      item_len = strlen(item);
9438      if ( '"' == *item && '"' == item[item_len-1] )
9439        {
9440        item++;
9441        item[item_len-2] = '\0';
9442        add_item(head, tail, item, count);
9443        return;
9444        }
9445      }
9446     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9447     resultspec.dsc$b_class = DSC$K_CLASS_D;
9448     resultspec.dsc$a_pointer = NULL;
9449     vmsspec = (char *)PerlMem_malloc(VMS_MAXRSS);
9450     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9451     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9452       filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9453     if (!isunix || !filespec.dsc$a_pointer)
9454       filespec.dsc$a_pointer = item;
9455     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9456     /*
9457      * Only return version specs, if the caller specified a version
9458      */
9459     had_version = strchr(item, ';');
9460     /*
9461      * Only return device and directory specs, if the caller specified either.
9462      */
9463     had_device = strchr(item, ':');
9464     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9465
9466     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9467                                  (&filespec, &resultspec, &context,
9468                                   &defaultspec, 0, &rms_sts, &lff_flags)))
9469         {
9470         char *string;
9471         char *c;
9472
9473         string = (char *)PerlMem_malloc(resultspec.dsc$w_length+1);
9474         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9475         my_strlcpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length+1);
9476         if (NULL == had_version)
9477             *(strrchr(string, ';')) = '\0';
9478         if ((!had_directory) && (had_device == NULL))
9479             {
9480             if (NULL == (devdir = strrchr(string, ']')))
9481                 devdir = strrchr(string, '>');
9482             my_strlcpy(string, devdir + 1, resultspec.dsc$w_length+1);
9483             }
9484         /*
9485          * Be consistent with what the C RTL has already done to the rest of
9486          * the argv items and lowercase all of these names.
9487          */
9488         if (!decc_efs_case_preserve) {
9489             for (c = string; *c; ++c)
9490             if (isupper(*c))
9491                 *c = tolower(*c);
9492         }
9493         if (isunix) trim_unixpath(string,item,1);
9494         add_item(head, tail, string, count);
9495         ++expcount;
9496     }
9497     PerlMem_free(vmsspec);
9498     if (sts != RMS$_NMF)
9499         {
9500         set_vaxc_errno(sts);
9501         switch (sts)
9502             {
9503             case RMS$_FNF: case RMS$_DNF:
9504                 set_errno(ENOENT); break;
9505             case RMS$_DIR:
9506                 set_errno(ENOTDIR); break;
9507             case RMS$_DEV:
9508                 set_errno(ENODEV); break;
9509             case RMS$_FNM: case RMS$_SYN:
9510                 set_errno(EINVAL); break;
9511             case RMS$_PRV:
9512                 set_errno(EACCES); break;
9513             default:
9514                 _ckvmssts_noperl(sts);
9515             }
9516         }
9517     if (expcount == 0)
9518         add_item(head, tail, item, count);
9519     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9520     _ckvmssts_noperl(lib$find_file_end(&context));
9521 }
9522
9523
9524 static void
9525 pipe_and_fork(pTHX_ char **cmargv)
9526 {
9527     PerlIO *fp;
9528     struct dsc$descriptor_s *vmscmd;
9529     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9530     int sts, j, l, ismcr, quote, tquote = 0;
9531
9532     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9533     vms_execfree(vmscmd);
9534
9535     j = l = 0;
9536     p = subcmd;
9537     q = cmargv[0];
9538     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
9539               && toupper(*(q+2)) == 'R' && !*(q+3);
9540
9541     while (q && l < MAX_DCL_LINE_LENGTH) {
9542         if (!*q) {
9543             if (j > 0 && quote) {
9544                 *p++ = '"';
9545                 l++;
9546             }
9547             q = cmargv[++j];
9548             if (q) {
9549                 if (ismcr && j > 1) quote = 1;
9550                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
9551                 *p++ = ' ';
9552                 l++;
9553                 if (quote || tquote) {
9554                     *p++ = '"';
9555                     l++;
9556                 }
9557             }
9558         } else {
9559             if ((quote||tquote) && *q == '"') {
9560                 *p++ = '"';
9561                 l++;
9562             }
9563             *p++ = *q++;
9564             l++;
9565         }
9566     }
9567     *p = '\0';
9568
9569     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9570     if (fp == NULL) {
9571         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9572     }
9573 }
9574
9575 static int
9576 background_process(pTHX_ int argc, char **argv)
9577 {
9578     char command[MAX_DCL_SYMBOL + 1] = "$";
9579     $DESCRIPTOR(value, "");
9580     static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9581     static $DESCRIPTOR(null, "NLA0:");
9582     static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9583     char pidstring[80];
9584     $DESCRIPTOR(pidstr, "");
9585     int pid;
9586     unsigned long int flags = 17, one = 1, retsts;
9587     int len;
9588
9589     len = my_strlcat(command, argv[0], sizeof(command));
9590     while (--argc && (len < MAX_DCL_SYMBOL))
9591         {
9592         my_strlcat(command, " \"", sizeof(command));
9593         my_strlcat(command, *(++argv), sizeof(command));
9594         len = my_strlcat(command, "\"", sizeof(command));
9595         }
9596     value.dsc$a_pointer = command;
9597     value.dsc$w_length = strlen(value.dsc$a_pointer);
9598     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9599     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9600     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9601         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9602     }
9603     else {
9604         _ckvmssts_noperl(retsts);
9605     }
9606 #ifdef ARGPROC_DEBUG
9607     PerlIO_printf(Perl_debug_log, "%s\n", command);
9608 #endif
9609     sprintf(pidstring, "%08X", pid);
9610     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9611     pidstr.dsc$a_pointer = pidstring;
9612     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9613     lib$set_symbol(&pidsymbol, &pidstr);
9614     return(SS$_NORMAL);
9615 }
9616 /*}}}*/
9617 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9618
9619
9620 /* OS-specific initialization at image activation (not thread startup) */
9621 /* Older VAXC header files lack these constants */
9622 #ifndef JPI$_RIGHTS_SIZE
9623 #  define JPI$_RIGHTS_SIZE 817
9624 #endif
9625 #ifndef KGB$M_SUBSYSTEM
9626 #  define KGB$M_SUBSYSTEM 0x8
9627 #endif
9628
9629 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9630
9631 /*{{{void vms_image_init(int *, char ***)*/
9632 void
9633 vms_image_init(int *argcp, char ***argvp)
9634 {
9635   int status;
9636   char eqv[LNM$C_NAMLENGTH+1] = "";
9637   unsigned int len, tabct = 8, tabidx = 0;
9638   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9639   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9640   unsigned short int dummy, rlen;
9641   struct dsc$descriptor_s **tabvec;
9642 #if defined(PERL_IMPLICIT_CONTEXT)
9643   pTHX = NULL;
9644 #endif
9645   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
9646                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
9647                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9648                                  {          0,                0,    0,      0} };
9649
9650 #ifdef KILL_BY_SIGPRC
9651     Perl_csighandler_init();
9652 #endif
9653
9654     /* This was moved from the pre-image init handler because on threaded */
9655     /* Perl it was always returning 0 for the default value. */
9656     status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9657     if (status > 0) {
9658         int s;
9659         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9660         if (s > 0) {
9661             int initial;
9662             initial = decc$feature_get_value(s, 4);
9663             if (initial > 0) {
9664                 /* initial is: 0 if nothing has set the feature */
9665                 /*            -1 if initialized to default */
9666                 /*             1 if set by logical name */
9667                 /*             2 if set by decc$feature_set_value */
9668                 decc_disable_posix_root = decc$feature_get_value(s, 1);
9669
9670                 /* If the value is not valid, force the feature off */
9671                 if (decc_disable_posix_root < 0) {
9672                     decc$feature_set_value(s, 1, 1);
9673                     decc_disable_posix_root = 1;
9674                 }
9675             }
9676             else {
9677                 /* Nothing has asked for it explicitly, so use our own default. */
9678                 decc_disable_posix_root = 1;
9679                 decc$feature_set_value(s, 1, 1);
9680             }
9681         }
9682     }
9683
9684   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9685   _ckvmssts_noperl(iosb[0]);
9686   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9687     if (iprv[i]) {           /* Running image installed with privs? */
9688       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
9689       will_taint = TRUE;
9690       break;
9691     }
9692   }
9693   /* Rights identifiers might trigger tainting as well. */
9694   if (!will_taint && (rlen || rsz)) {
9695     while (rlen < rsz) {
9696       /* We didn't get all the identifiers on the first pass.  Allocate a
9697        * buffer much larger than $GETJPI wants (rsz is size in bytes that
9698        * were needed to hold all identifiers at time of last call; we'll
9699        * allocate that many unsigned long ints), and go back and get 'em.
9700        * If it gave us less than it wanted to despite ample buffer space,
9701        * something's broken.  Is your system missing a system identifier?
9702        */
9703       if (rsz <= jpilist[1].buflen) {
9704          /* Perl_croak accvios when used this early in startup. */
9705          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9706                          rsz, (unsigned long) jpilist[1].buflen,
9707                          "Check your rights database for corruption.\n");
9708          exit(SS$_ABORT);
9709       }
9710       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9711       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9712       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9713       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9714       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9715       _ckvmssts_noperl(iosb[0]);
9716     }
9717     mask = (unsigned long int *)jpilist[1].bufadr;
9718     /* Check attribute flags for each identifier (2nd longword); protected
9719      * subsystem identifiers trigger tainting.
9720      */
9721     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9722       if (mask[i] & KGB$M_SUBSYSTEM) {
9723         will_taint = TRUE;
9724         break;
9725       }
9726     }
9727     if (mask != rlst) PerlMem_free(mask);
9728   }
9729
9730   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9731    * logical, some versions of the CRTL will add a phanthom /000000/
9732    * directory.  This needs to be removed.
9733    */
9734   if (decc_filename_unix_report) {
9735     char * zeros;
9736     int ulen;
9737     ulen = strlen(argvp[0][0]);
9738     if (ulen > 7) {
9739       zeros = strstr(argvp[0][0], "/000000/");
9740       if (zeros != NULL) {
9741         int mlen;
9742         mlen = ulen - (zeros - argvp[0][0]) - 7;
9743         memmove(zeros, &zeros[7], mlen);
9744         ulen = ulen - 7;
9745         argvp[0][0][ulen] = '\0';
9746       }
9747     }
9748     /* It also may have a trailing dot that needs to be removed otherwise
9749      * it will be converted to VMS mode incorrectly.
9750      */
9751     ulen--;
9752     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9753       argvp[0][0][ulen] = '\0';
9754   }
9755
9756   /* We need to use this hack to tell Perl it should run with tainting,
9757    * since its tainting flag may be part of the PL_curinterp struct, which
9758    * hasn't been allocated when vms_image_init() is called.
9759    */
9760   if (will_taint) {
9761     char **newargv, **oldargv;
9762     oldargv = *argvp;
9763     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9764     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9765     newargv[0] = oldargv[0];
9766     newargv[1] = (char *)PerlMem_malloc(3 * sizeof(char));
9767     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9768     strcpy(newargv[1], "-T");
9769     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9770     (*argcp)++;
9771     newargv[*argcp] = NULL;
9772     /* We orphan the old argv, since we don't know where it's come from,
9773      * so we don't know how to free it.
9774      */
9775     *argvp = newargv;
9776   }
9777   else {  /* Did user explicitly request tainting? */
9778     int i;
9779     char *cp, **av = *argvp;
9780     for (i = 1; i < *argcp; i++) {
9781       if (*av[i] != '-') break;
9782       for (cp = av[i]+1; *cp; cp++) {
9783         if (*cp == 'T') { will_taint = 1; break; }
9784         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9785                   strchr("DFIiMmx",*cp)) break;
9786       }
9787       if (will_taint) break;
9788     }
9789   }
9790
9791   for (tabidx = 0;
9792        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9793        tabidx++) {
9794     if (!tabidx) {
9795       tabvec = (struct dsc$descriptor_s **)
9796             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9797       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9798     }
9799     else if (tabidx >= tabct) {
9800       tabct += 8;
9801       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9802       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9803     }
9804     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9805     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9806     tabvec[tabidx]->dsc$w_length  = len;
9807     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9808     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_S;
9809     tabvec[tabidx]->dsc$a_pointer = (char *)PerlMem_malloc(len + 1);
9810     if (tabvec[tabidx]->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9811     my_strlcpy(tabvec[tabidx]->dsc$a_pointer, eqv, len + 1);
9812   }
9813   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9814
9815   getredirection(argcp,argvp);
9816 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9817   {
9818 # include <reentrancy.h>
9819   decc$set_reentrancy(C$C_MULTITHREAD);
9820   }
9821 #endif
9822   return;
9823 }
9824 /*}}}*/
9825
9826
9827 /* trim_unixpath()
9828  * Trim Unix-style prefix off filespec, so it looks like what a shell
9829  * glob expansion would return (i.e. from specified prefix on, not
9830  * full path).  Note that returned filespec is Unix-style, regardless
9831  * of whether input filespec was VMS-style or Unix-style.
9832  *
9833  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9834  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9835  * vector of options; at present, only bit 0 is used, and if set tells
9836  * trim unixpath to try the current default directory as a prefix when
9837  * presented with a possibly ambiguous ... wildcard.
9838  *
9839  * Returns !=0 on success, with trimmed filespec replacing contents of
9840  * fspec, and 0 on failure, with contents of fpsec unchanged.
9841  */
9842 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9843 int
9844 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9845 {
9846   char *unixified, *unixwild, *tplate, *base, *end, *cp1, *cp2;
9847   int tmplen, reslen = 0, dirs = 0;
9848
9849   if (!wildspec || !fspec) return 0;
9850
9851   unixwild = (char *)PerlMem_malloc(VMS_MAXRSS);
9852   if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9853   tplate = unixwild;
9854   if (strpbrk(wildspec,"]>:") != NULL) {
9855     if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
9856         PerlMem_free(unixwild);
9857         return 0;
9858     }
9859   }
9860   else {
9861     my_strlcpy(unixwild, wildspec, VMS_MAXRSS);
9862   }
9863   unixified = (char *)PerlMem_malloc(VMS_MAXRSS);
9864   if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9865   if (strpbrk(fspec,"]>:") != NULL) {
9866     if (int_tounixspec(fspec, unixified, NULL) == NULL) {
9867         PerlMem_free(unixwild);
9868         PerlMem_free(unixified);
9869         return 0;
9870     }
9871     else base = unixified;
9872     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9873      * check to see that final result fits into (isn't longer than) fspec */
9874     reslen = strlen(fspec);
9875   }
9876   else base = fspec;
9877
9878   /* No prefix or absolute path on wildcard, so nothing to remove */
9879   if (!*tplate || *tplate == '/') {
9880     PerlMem_free(unixwild);
9881     if (base == fspec) {
9882         PerlMem_free(unixified);
9883         return 1;
9884     }
9885     tmplen = strlen(unixified);
9886     if (tmplen > reslen) {
9887         PerlMem_free(unixified);
9888         return 0;  /* not enough space */
9889     }
9890     /* Copy unixified resultant, including trailing NUL */
9891     memmove(fspec,unixified,tmplen+1);
9892     PerlMem_free(unixified);
9893     return 1;
9894   }
9895
9896   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
9897   if ((cp1 = strstr(tplate,".../")) == NULL) { /* No ...; just count elts */
9898     for (cp1 = tplate; *cp1; cp1++) if (*cp1 == '/') dirs++;
9899     for (cp1 = end ;cp1 >= base; cp1--)
9900       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9901         { cp1++; break; }
9902     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9903     PerlMem_free(unixified);
9904     PerlMem_free(unixwild);
9905     return 1;
9906   }
9907   else {
9908     char *tpl, *lcres;
9909     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9910     int ells = 1, totells, segdirs, match;
9911     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9912                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9913
9914     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9915     totells = ells;
9916     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9917     tpl = (char *)PerlMem_malloc(VMS_MAXRSS);
9918     if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9919     if (ellipsis == tplate && opts & 1) {
9920       /* Template begins with an ellipsis.  Since we can't tell how many
9921        * directory names at the front of the resultant to keep for an
9922        * arbitrary starting point, we arbitrarily choose the current
9923        * default directory as a starting point.  If it's there as a prefix,
9924        * clip it off.  If not, fall through and act as if the leading
9925        * ellipsis weren't there (i.e. return shortest possible path that
9926        * could match template).
9927        */
9928       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9929           PerlMem_free(tpl);
9930           PerlMem_free(unixified);
9931           PerlMem_free(unixwild);
9932           return 0;
9933       }
9934       if (!decc_efs_case_preserve) {
9935         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9936           if (_tolower(*cp1) != _tolower(*cp2)) break;
9937       }
9938       segdirs = dirs - totells;  /* Min # of dirs we must have left */
9939       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9940       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9941         memmove(fspec,cp2+1,end - cp2);
9942         PerlMem_free(tpl);
9943         PerlMem_free(unixified);
9944         PerlMem_free(unixwild);
9945         return 1;
9946       }
9947     }
9948     /* First off, back up over constant elements at end of path */
9949     if (dirs) {
9950       for (front = end ; front >= base; front--)
9951          if (*front == '/' && !dirs--) { front++; break; }
9952     }
9953     lcres = (char *)PerlMem_malloc(VMS_MAXRSS);
9954     if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9955     for (cp1=tplate,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9956          cp1++,cp2++) {
9957             if (!decc_efs_case_preserve) {
9958                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
9959             }
9960             else {
9961                 *cp2 = *cp1;
9962             }
9963     }
9964     if (cp1 != '\0') {
9965         PerlMem_free(tpl);
9966         PerlMem_free(unixified);
9967         PerlMem_free(unixwild);
9968         PerlMem_free(lcres);
9969         return 0;  /* Path too long. */
9970     }
9971     lcend = cp2;
9972     *cp2 = '\0';  /* Pick up with memcpy later */
9973     lcfront = lcres + (front - base);
9974     /* Now skip over each ellipsis and try to match the path in front of it. */
9975     while (ells--) {
9976       for (cp1 = ellipsis - 2; cp1 >= tplate; cp1--)
9977         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
9978             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
9979       if (cp1 < tplate) break; /* template started with an ellipsis */
9980       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9981         ellipsis = cp1; continue;
9982       }
9983       wilddsc.dsc$a_pointer = tpl;
9984       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9985       nextell = cp1;
9986       for (segdirs = 0, cp2 = tpl;
9987            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9988            cp1++, cp2++) {
9989          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9990          else {
9991             if (!decc_efs_case_preserve) {
9992               *cp2 = _tolower(*cp1);  /* else lowercase for match */
9993             }
9994             else {
9995               *cp2 = *cp1;  /* else preserve case for match */
9996             }
9997          }
9998          if (*cp2 == '/') segdirs++;
9999       }
10000       if (cp1 != ellipsis - 1) {
10001           PerlMem_free(tpl);
10002           PerlMem_free(unixified);
10003           PerlMem_free(unixwild);
10004           PerlMem_free(lcres);
10005           return 0; /* Path too long */
10006       }
10007       /* Back up at least as many dirs as in template before matching */
10008       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
10009         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
10010       for (match = 0; cp1 > lcres;) {
10011         resdsc.dsc$a_pointer = cp1;
10012         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
10013           match++;
10014           if (match == 1) lcfront = cp1;
10015         }
10016         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
10017       }
10018       if (!match) {
10019         PerlMem_free(tpl);
10020         PerlMem_free(unixified);
10021         PerlMem_free(unixwild);
10022         PerlMem_free(lcres);
10023         return 0;  /* Can't find prefix ??? */
10024       }
10025       if (match > 1 && opts & 1) {
10026         /* This ... wildcard could cover more than one set of dirs (i.e.
10027          * a set of similar dir names is repeated).  If the template
10028          * contains more than 1 ..., upstream elements could resolve the
10029          * ambiguity, but it's not worth a full backtracking setup here.
10030          * As a quick heuristic, clip off the current default directory
10031          * if it's present to find the trimmed spec, else use the
10032          * shortest string that this ... could cover.
10033          */
10034         char def[NAM$C_MAXRSS+1], *st;
10035
10036         if (getcwd(def, sizeof def,0) == NULL) {
10037             PerlMem_free(unixified);
10038             PerlMem_free(unixwild);
10039             PerlMem_free(lcres);
10040             PerlMem_free(tpl);
10041             return 0;
10042         }
10043         if (!decc_efs_case_preserve) {
10044           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
10045             if (_tolower(*cp1) != _tolower(*cp2)) break;
10046         }
10047         segdirs = dirs - totells;  /* Min # of dirs we must have left */
10048         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
10049         if (*cp1 == '\0' && *cp2 == '/') {
10050           memmove(fspec,cp2+1,end - cp2);
10051           PerlMem_free(tpl);
10052           PerlMem_free(unixified);
10053           PerlMem_free(unixwild);
10054           PerlMem_free(lcres);
10055           return 1;
10056         }
10057         /* Nope -- stick with lcfront from above and keep going. */
10058       }
10059     }
10060     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
10061     PerlMem_free(tpl);
10062     PerlMem_free(unixified);
10063     PerlMem_free(unixwild);
10064     PerlMem_free(lcres);
10065     return 1;
10066   }
10067
10068 }  /* end of trim_unixpath() */
10069 /*}}}*/
10070
10071
10072 /*
10073  *  VMS readdir() routines.
10074  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
10075  *
10076  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
10077  *  Minor modifications to original routines.
10078  */
10079
10080 /* readdir may have been redefined by reentr.h, so make sure we get
10081  * the local version for what we do here.
10082  */
10083 #ifdef readdir
10084 # undef readdir
10085 #endif
10086 #if !defined(PERL_IMPLICIT_CONTEXT)
10087 # define readdir Perl_readdir
10088 #else
10089 # define readdir(a) Perl_readdir(aTHX_ a)
10090 #endif
10091
10092     /* Number of elements in vms_versions array */
10093 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
10094
10095 /*
10096  *  Open a directory, return a handle for later use.
10097  */
10098 /*{{{ DIR *opendir(char*name) */
10099 DIR *
10100 Perl_opendir(pTHX_ const char *name)
10101 {
10102     DIR *dd;
10103     char *dir;
10104     Stat_t sb;
10105
10106     Newx(dir, VMS_MAXRSS, char);
10107     if (int_tovmspath(name, dir, NULL) == NULL) {
10108       Safefree(dir);
10109       return NULL;
10110     }
10111     /* Check access before stat; otherwise stat does not
10112      * accurately report whether it's a directory.
10113      */
10114     if (!strstr(dir, "::") /* sys$check_access doesn't do remotes */
10115         && !cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
10116       /* cando_by_name has already set errno */
10117       Safefree(dir);
10118       return NULL;
10119     }
10120     if (flex_stat(dir,&sb) == -1) return NULL;
10121     if (!S_ISDIR(sb.st_mode)) {
10122       Safefree(dir);
10123       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
10124       return NULL;
10125     }
10126     /* Get memory for the handle, and the pattern. */
10127     Newx(dd,1,DIR);
10128     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
10129
10130     /* Fill in the fields; mainly playing with the descriptor. */
10131     sprintf(dd->pattern, "%s*.*",dir);
10132     Safefree(dir);
10133     dd->context = 0;
10134     dd->count = 0;
10135     dd->flags = 0;
10136     /* By saying we want the result of readdir() in unix format, we are really
10137      * saying we want all the escapes removed, translating characters that
10138      * must be escaped in a VMS-format name to their unescaped form, which is
10139      * presumably allowed in a Unix-format name.
10140      */
10141     dd->flags = decc_filename_unix_report ? PERL_VMSDIR_M_UNIXSPECS : 0;
10142     dd->pat.dsc$a_pointer = dd->pattern;
10143     dd->pat.dsc$w_length = strlen(dd->pattern);
10144     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
10145     dd->pat.dsc$b_class = DSC$K_CLASS_S;
10146 #if defined(USE_ITHREADS)
10147     Newx(dd->mutex,1,perl_mutex);
10148     MUTEX_INIT( (perl_mutex *) dd->mutex );
10149 #else
10150     dd->mutex = NULL;
10151 #endif
10152
10153     return dd;
10154 }  /* end of opendir() */
10155 /*}}}*/
10156
10157 /*
10158  *  Set the flag to indicate we want versions or not.
10159  */
10160 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10161 void
10162 vmsreaddirversions(DIR *dd, int flag)
10163 {
10164     if (flag)
10165         dd->flags |= PERL_VMSDIR_M_VERSIONS;
10166     else
10167         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10168 }
10169 /*}}}*/
10170
10171 /*
10172  *  Free up an opened directory.
10173  */
10174 /*{{{ void closedir(DIR *dd)*/
10175 void
10176 Perl_closedir(DIR *dd)
10177 {
10178     int sts;
10179
10180     sts = lib$find_file_end(&dd->context);
10181     Safefree(dd->pattern);
10182 #if defined(USE_ITHREADS)
10183     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10184     Safefree(dd->mutex);
10185 #endif
10186     Safefree(dd);
10187 }
10188 /*}}}*/
10189
10190 /*
10191  *  Collect all the version numbers for the current file.
10192  */
10193 static void
10194 collectversions(pTHX_ DIR *dd)
10195 {
10196     struct dsc$descriptor_s     pat;
10197     struct dsc$descriptor_s     res;
10198     struct dirent *e;
10199     char *p, *text, *buff;
10200     int i;
10201     unsigned long context, tmpsts;
10202
10203     /* Convenient shorthand. */
10204     e = &dd->entry;
10205
10206     /* Add the version wildcard, ignoring the "*.*" put on before */
10207     i = strlen(dd->pattern);
10208     Newx(text,i + e->d_namlen + 3,char);
10209     my_strlcpy(text, dd->pattern, i + 1);
10210     sprintf(&text[i - 3], "%s;*", e->d_name);
10211
10212     /* Set up the pattern descriptor. */
10213     pat.dsc$a_pointer = text;
10214     pat.dsc$w_length = i + e->d_namlen - 1;
10215     pat.dsc$b_dtype = DSC$K_DTYPE_T;
10216     pat.dsc$b_class = DSC$K_CLASS_S;
10217
10218     /* Set up result descriptor. */
10219     Newx(buff, VMS_MAXRSS, char);
10220     res.dsc$a_pointer = buff;
10221     res.dsc$w_length = VMS_MAXRSS - 1;
10222     res.dsc$b_dtype = DSC$K_DTYPE_T;
10223     res.dsc$b_class = DSC$K_CLASS_S;
10224
10225     /* Read files, collecting versions. */
10226     for (context = 0, e->vms_verscount = 0;
10227          e->vms_verscount < VERSIZE(e);
10228          e->vms_verscount++) {
10229         unsigned long rsts;
10230         unsigned long flags = 0;
10231
10232 #ifdef VMS_LONGNAME_SUPPORT
10233         flags = LIB$M_FIL_LONG_NAMES;
10234 #endif
10235         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10236         if (tmpsts == RMS$_NMF || context == 0) break;
10237         _ckvmssts(tmpsts);
10238         buff[VMS_MAXRSS - 1] = '\0';
10239         if ((p = strchr(buff, ';')))
10240             e->vms_versions[e->vms_verscount] = atoi(p + 1);
10241         else
10242             e->vms_versions[e->vms_verscount] = -1;
10243     }
10244
10245     _ckvmssts(lib$find_file_end(&context));
10246     Safefree(text);
10247     Safefree(buff);
10248
10249 }  /* end of collectversions() */
10250
10251 /*
10252  *  Read the next entry from the directory.
10253  */
10254 /*{{{ struct dirent *readdir(DIR *dd)*/
10255 struct dirent *
10256 Perl_readdir(pTHX_ DIR *dd)
10257 {
10258     struct dsc$descriptor_s     res;
10259     char *p, *buff;
10260     unsigned long int tmpsts;
10261     unsigned long rsts;
10262     unsigned long flags = 0;
10263     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10264     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10265
10266     /* Set up result descriptor, and get next file. */
10267     Newx(buff, VMS_MAXRSS, char);
10268     res.dsc$a_pointer = buff;
10269     res.dsc$w_length = VMS_MAXRSS - 1;
10270     res.dsc$b_dtype = DSC$K_DTYPE_T;
10271     res.dsc$b_class = DSC$K_CLASS_S;
10272
10273 #ifdef VMS_LONGNAME_SUPPORT
10274     flags = LIB$M_FIL_LONG_NAMES;
10275 #endif
10276
10277     tmpsts = lib$find_file
10278         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10279     if (dd->context == 0)
10280         tmpsts = RMS$_NMF;  /* None left. (should be set, but make sure) */
10281
10282     if (!(tmpsts & 1)) {
10283       switch (tmpsts) {
10284         case RMS$_NMF:
10285           break;  /* no more files considered success */
10286         case RMS$_PRV:
10287           SETERRNO(EACCES, tmpsts); break;
10288         case RMS$_DEV:
10289           SETERRNO(ENODEV, tmpsts); break;
10290         case RMS$_DIR:
10291           SETERRNO(ENOTDIR, tmpsts); break;
10292         case RMS$_FNF: case RMS$_DNF:
10293           SETERRNO(ENOENT, tmpsts); break;
10294         default:
10295           SETERRNO(EVMSERR, tmpsts);
10296       }
10297       Safefree(buff);
10298       return NULL;
10299     }
10300     dd->count++;
10301     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10302     buff[res.dsc$w_length] = '\0';
10303     p = buff + res.dsc$w_length;
10304     while (--p >= buff) if (!isspace(*p)) break;
10305     *p = '\0';
10306     if (!decc_efs_case_preserve) {
10307       for (p = buff; *p; p++) *p = _tolower(*p);
10308     }
10309
10310     /* Skip any directory component and just copy the name. */
10311     sts = vms_split_path
10312        (buff,
10313         &v_spec,
10314         &v_len,
10315         &r_spec,
10316         &r_len,
10317         &d_spec,
10318         &d_len,
10319         &n_spec,
10320         &n_len,
10321         &e_spec,
10322         &e_len,
10323         &vs_spec,
10324         &vs_len);
10325
10326     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10327
10328         /* In Unix report mode, remove the ".dir;1" from the name */
10329         /* if it is a real directory. */
10330         if (decc_filename_unix_report && decc_efs_charset) {
10331             if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
10332                 Stat_t statbuf;
10333                 int ret_sts;
10334
10335                 ret_sts = flex_lstat(buff, &statbuf);
10336                 if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10337                     e_len = 0;
10338                     e_spec[0] = 0;
10339                 }
10340             }
10341         }
10342
10343         /* Drop NULL extensions on UNIX file specification */
10344         if ((e_len == 1) && decc_readdir_dropdotnotype) {
10345             e_len = 0;
10346             e_spec[0] = '\0';
10347         }
10348     }
10349
10350     memcpy(dd->entry.d_name, n_spec, n_len + e_len);
10351     dd->entry.d_name[n_len + e_len] = '\0';
10352     dd->entry.d_namlen = n_len + e_len;
10353
10354     /* Convert the filename to UNIX format if needed */
10355     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10356
10357         /* Translate the encoded characters. */
10358         /* Fixme: Unicode handling could result in embedded 0 characters */
10359         if (strchr(dd->entry.d_name, '^') != NULL) {
10360             char new_name[256];
10361             char * q;
10362             p = dd->entry.d_name;
10363             q = new_name;
10364             while (*p != 0) {
10365                 int inchars_read, outchars_added;
10366                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10367                 p += inchars_read;
10368                 q += outchars_added;
10369                 /* fix-me */
10370                 /* if outchars_added > 1, then this is a wide file specification */
10371                 /* Wide file specifications need to be passed in Perl */
10372                 /* counted strings apparently with a Unicode flag */
10373             }
10374             *q = 0;
10375             dd->entry.d_namlen = my_strlcpy(dd->entry.d_name, new_name, sizeof(dd->entry.d_name));
10376         }
10377     }
10378
10379     dd->entry.vms_verscount = 0;
10380     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10381     Safefree(buff);
10382     return &dd->entry;
10383
10384 }  /* end of readdir() */
10385 /*}}}*/
10386
10387 /*
10388  *  Read the next entry from the directory -- thread-safe version.
10389  */
10390 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10391 int
10392 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10393 {
10394     int retval;
10395
10396     MUTEX_LOCK( (perl_mutex *) dd->mutex );
10397
10398     entry = readdir(dd);
10399     *result = entry;
10400     retval = ( *result == NULL ? errno : 0 );
10401
10402     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10403
10404     return retval;
10405
10406 }  /* end of readdir_r() */
10407 /*}}}*/
10408
10409 /*
10410  *  Return something that can be used in a seekdir later.
10411  */
10412 /*{{{ long telldir(DIR *dd)*/
10413 long
10414 Perl_telldir(DIR *dd)
10415 {
10416     return dd->count;
10417 }
10418 /*}}}*/
10419
10420 /*
10421  *  Return to a spot where we used to be.  Brute force.
10422  */
10423 /*{{{ void seekdir(DIR *dd,long count)*/
10424 void
10425 Perl_seekdir(pTHX_ DIR *dd, long count)
10426 {
10427     int old_flags;
10428
10429     /* If we haven't done anything yet... */
10430     if (dd->count == 0)
10431         return;
10432
10433     /* Remember some state, and clear it. */
10434     old_flags = dd->flags;
10435     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10436     _ckvmssts(lib$find_file_end(&dd->context));
10437     dd->context = 0;
10438
10439     /* The increment is in readdir(). */
10440     for (dd->count = 0; dd->count < count; )
10441         readdir(dd);
10442
10443     dd->flags = old_flags;
10444
10445 }  /* end of seekdir() */
10446 /*}}}*/
10447
10448 /* VMS subprocess management
10449  *
10450  * my_vfork() - just a vfork(), after setting a flag to record that
10451  * the current script is trying a Unix-style fork/exec.
10452  *
10453  * vms_do_aexec() and vms_do_exec() are called in response to the
10454  * perl 'exec' function.  If this follows a vfork call, then they
10455  * call out the regular perl routines in doio.c which do an
10456  * execvp (for those who really want to try this under VMS).
10457  * Otherwise, they do exactly what the perl docs say exec should
10458  * do - terminate the current script and invoke a new command
10459  * (See below for notes on command syntax.)
10460  *
10461  * do_aspawn() and do_spawn() implement the VMS side of the perl
10462  * 'system' function.
10463  *
10464  * Note on command arguments to perl 'exec' and 'system': When handled
10465  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10466  * are concatenated to form a DCL command string.  If the first non-numeric
10467  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10468  * the command string is handed off to DCL directly.  Otherwise,
10469  * the first token of the command is taken as the filespec of an image
10470  * to run.  The filespec is expanded using a default type of '.EXE' and
10471  * the process defaults for device, directory, etc., and if found, the resultant
10472  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10473  * the command string as parameters.  This is perhaps a bit complicated,
10474  * but I hope it will form a happy medium between what VMS folks expect
10475  * from lib$spawn and what Unix folks expect from exec.
10476  */
10477
10478 static int vfork_called;
10479
10480 /*{{{int my_vfork(void)*/
10481 int
10482 my_vfork(void)
10483 {
10484   vfork_called++;
10485   return vfork();
10486 }
10487 /*}}}*/
10488
10489
10490 static void
10491 vms_execfree(struct dsc$descriptor_s *vmscmd)
10492 {
10493   if (vmscmd) {
10494       if (vmscmd->dsc$a_pointer) {
10495           PerlMem_free(vmscmd->dsc$a_pointer);
10496       }
10497       PerlMem_free(vmscmd);
10498   }
10499 }
10500
10501 static char *
10502 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10503 {
10504   char *junk, *tmps = NULL;
10505   size_t cmdlen = 0;
10506   size_t rlen;
10507   SV **idx;
10508   STRLEN n_a;
10509
10510   idx = mark;
10511   if (really) {
10512     tmps = SvPV(really,rlen);
10513     if (*tmps) {
10514       cmdlen += rlen + 1;
10515       idx++;
10516     }
10517   }
10518
10519   for (idx++; idx <= sp; idx++) {
10520     if (*idx) {
10521       junk = SvPVx(*idx,rlen);
10522       cmdlen += rlen ? rlen + 1 : 0;
10523     }
10524   }
10525   Newx(PL_Cmd, cmdlen+1, char);
10526
10527   if (tmps && *tmps) {
10528     my_strlcpy(PL_Cmd, tmps, cmdlen + 1);
10529     mark++;
10530   }
10531   else *PL_Cmd = '\0';
10532   while (++mark <= sp) {
10533     if (*mark) {
10534       char *s = SvPVx(*mark,n_a);
10535       if (!*s) continue;
10536       if (*PL_Cmd) my_strlcat(PL_Cmd, " ", cmdlen+1);
10537       my_strlcat(PL_Cmd, s, cmdlen+1);
10538     }
10539   }
10540   return PL_Cmd;
10541
10542 }  /* end of setup_argstr() */
10543
10544
10545 static unsigned long int
10546 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10547                    struct dsc$descriptor_s **pvmscmd)
10548 {
10549   char * vmsspec;
10550   char * resspec;
10551   char image_name[NAM$C_MAXRSS+1];
10552   char image_argv[NAM$C_MAXRSS+1];
10553   $DESCRIPTOR(defdsc,".EXE");
10554   $DESCRIPTOR(defdsc2,".");
10555   struct dsc$descriptor_s resdsc;
10556   struct dsc$descriptor_s *vmscmd;
10557   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10558   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10559   char *s, *rest, *cp, *wordbreak;
10560   char * cmd;
10561   int cmdlen;
10562   int isdcl;
10563
10564   vmscmd = (struct dsc$descriptor_s *)PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10565   if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10566
10567   /* vmsspec is a DCL command buffer, not just a filename */
10568   vmsspec = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10569   if (vmsspec == NULL)
10570       _ckvmssts_noperl(SS$_INSFMEM);
10571
10572   resspec = (char *)PerlMem_malloc(VMS_MAXRSS);
10573   if (resspec == NULL)
10574       _ckvmssts_noperl(SS$_INSFMEM);
10575
10576   /* Make a copy for modification */
10577   cmdlen = strlen(incmd);
10578   cmd = (char *)PerlMem_malloc(cmdlen+1);
10579   if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10580   my_strlcpy(cmd, incmd, cmdlen + 1);
10581   image_name[0] = 0;
10582   image_argv[0] = 0;
10583
10584   resdsc.dsc$a_pointer = resspec;
10585   resdsc.dsc$b_dtype  = DSC$K_DTYPE_T;
10586   resdsc.dsc$b_class  = DSC$K_CLASS_S;
10587   resdsc.dsc$w_length = VMS_MAXRSS - 1;
10588
10589   vmscmd->dsc$a_pointer = NULL;
10590   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
10591   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
10592   vmscmd->dsc$w_length = 0;
10593   if (pvmscmd) *pvmscmd = vmscmd;
10594
10595   if (suggest_quote) *suggest_quote = 0;
10596
10597   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10598     PerlMem_free(cmd);
10599     PerlMem_free(vmsspec);
10600     PerlMem_free(resspec);
10601     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
10602   }
10603
10604   s = cmd;
10605
10606   while (*s && isspace(*s)) s++;
10607
10608   if (*s == '@' || *s == '$') {
10609     vmsspec[0] = *s;  rest = s + 1;
10610     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10611   }
10612   else { cp = vmsspec; rest = s; }
10613
10614   /* If the first word is quoted, then we need to unquote it and
10615    * escape spaces within it.  We'll expand into the resspec buffer,
10616    * then copy back into the cmd buffer, expanding the latter if
10617    * necessary.
10618    */
10619   if (*rest == '"') {
10620     char *cp2;
10621     char *r = rest;
10622     bool in_quote = 0;
10623     int clen = cmdlen;
10624     int soff = s - cmd;
10625
10626     for (cp2 = resspec;
10627          *rest && cp2 - resspec < (VMS_MAXRSS - 1);
10628          rest++) {
10629
10630       if (*rest == ' ') {    /* Escape ' ' to '^_'. */
10631         *cp2 = '^';
10632         *(++cp2) = '_';
10633         cp2++;
10634         clen++;
10635       }
10636       else if (*rest == '"') {
10637         clen--;
10638         if (in_quote) {     /* Must be closing quote. */
10639           rest++;
10640           break;
10641         }
10642         in_quote = 1;
10643       }
10644       else {
10645         *cp2 = *rest;
10646         cp2++;
10647       }
10648     }
10649     *cp2 = '\0';
10650
10651     /* Expand the command buffer if necessary. */
10652     if (clen > cmdlen) {
10653       cmd = (char *)PerlMem_realloc(cmd, clen);
10654       if (cmd == NULL)
10655         _ckvmssts_noperl(SS$_INSFMEM);
10656       /* Where we are may have changed, so recompute offsets */
10657       r = cmd + (r - s - soff);
10658       rest = cmd + (rest - s - soff);
10659       s = cmd + soff;
10660     }
10661
10662     /* Shift the non-verb portion of the command (if any) up or
10663      * down as necessary.
10664      */
10665     if (*rest)
10666       memmove(rest + clen - cmdlen, rest, s - soff + cmdlen - rest);
10667
10668     /* Copy the unquoted and escaped command verb into place. */
10669     memcpy(r, resspec, cp2 - resspec);
10670     cmd[clen] = '\0';
10671     cmdlen = clen;
10672     rest = r;         /* Rewind for subsequent operations. */
10673   }
10674
10675   if (*rest == '.' || *rest == '/') {
10676     char *cp2;
10677     for (cp2 = resspec;
10678          *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10679          rest++, cp2++) *cp2 = *rest;
10680     *cp2 = '\0';
10681     if (int_tovmsspec(resspec, cp, 0, NULL)) {
10682       s = vmsspec;
10683
10684       /* When a UNIX spec with no file type is translated to VMS, */
10685       /* A trailing '.' is appended under ODS-5 rules.            */
10686       /* Here we do not want that trailing "." as it prevents     */
10687       /* Looking for a implied ".exe" type. */
10688       if (decc_efs_charset) {
10689           int i;
10690           i = strlen(vmsspec);
10691           if (vmsspec[i-1] == '.') {
10692               vmsspec[i-1] = '\0';
10693           }
10694       }
10695
10696       if (*rest) {
10697         for (cp2 = vmsspec + strlen(vmsspec);
10698              *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10699              rest++, cp2++) *cp2 = *rest;
10700         *cp2 = '\0';
10701       }
10702     }
10703   }
10704   /* Intuit whether verb (first word of cmd) is a DCL command:
10705    *   - if first nonspace char is '@', it's a DCL indirection
10706    * otherwise
10707    *   - if verb contains a filespec separator, it's not a DCL command
10708    *   - if it doesn't, caller tells us whether to default to a DCL
10709    *     command, or to a local image unless told it's DCL (by leading '$')
10710    */
10711   if (*s == '@') {
10712       isdcl = 1;
10713       if (suggest_quote) *suggest_quote = 1;
10714   } else {
10715     char *filespec = strpbrk(s,":<[.;");
10716     rest = wordbreak = strpbrk(s," \"\t/");
10717     if (!wordbreak) wordbreak = s + strlen(s);
10718     if (*s == '$') check_img = 0;
10719     if (filespec && (filespec < wordbreak)) isdcl = 0;
10720     else isdcl = !check_img;
10721   }
10722
10723   if (!isdcl) {
10724     int rsts;
10725     imgdsc.dsc$a_pointer = s;
10726     imgdsc.dsc$w_length = wordbreak - s;
10727     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10728     if (!(retsts&1)) {
10729         _ckvmssts_noperl(lib$find_file_end(&cxt));
10730         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10731       if (!(retsts & 1) && *s == '$') {
10732         _ckvmssts_noperl(lib$find_file_end(&cxt));
10733         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10734         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10735         if (!(retsts&1)) {
10736           _ckvmssts_noperl(lib$find_file_end(&cxt));
10737           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10738         }
10739       }
10740     }
10741     _ckvmssts_noperl(lib$find_file_end(&cxt));
10742
10743     if (retsts & 1) {
10744       FILE *fp;
10745       s = resspec;
10746       while (*s && !isspace(*s)) s++;
10747       *s = '\0';
10748
10749       /* check that it's really not DCL with no file extension */
10750       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10751       if (fp) {
10752         char b[256] = {0,0,0,0};
10753         read(fileno(fp), b, 256);
10754         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10755         if (isdcl) {
10756           int shebang_len;
10757
10758           /* Check for script */
10759           shebang_len = 0;
10760           if ((b[0] == '#') && (b[1] == '!'))
10761              shebang_len = 2;
10762 #ifdef ALTERNATE_SHEBANG
10763           else {
10764             shebang_len = strlen(ALTERNATE_SHEBANG);
10765             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10766               char * perlstr;
10767                 perlstr = strstr("perl",b);
10768                 if (perlstr == NULL)
10769                   shebang_len = 0;
10770             }
10771             else
10772               shebang_len = 0;
10773           }
10774 #endif
10775
10776           if (shebang_len > 0) {
10777           int i;
10778           int j;
10779           char tmpspec[NAM$C_MAXRSS + 1];
10780
10781             i = shebang_len;
10782              /* Image is following after white space */
10783             /*--------------------------------------*/
10784             while (isprint(b[i]) && isspace(b[i]))
10785                 i++;
10786
10787             j = 0;
10788             while (isprint(b[i]) && !isspace(b[i])) {
10789                 tmpspec[j++] = b[i++];
10790                 if (j >= NAM$C_MAXRSS)
10791                    break;
10792             }
10793             tmpspec[j] = '\0';
10794
10795              /* There may be some default parameters to the image */
10796             /*---------------------------------------------------*/
10797             j = 0;
10798             while (isprint(b[i])) {
10799                 image_argv[j++] = b[i++];
10800                 if (j >= NAM$C_MAXRSS)
10801                    break;
10802             }
10803             while ((j > 0) && !isprint(image_argv[j-1]))
10804                 j--;
10805             image_argv[j] = 0;
10806
10807             /* It will need to be converted to VMS format and validated */
10808             if (tmpspec[0] != '\0') {
10809               char * iname;
10810
10811                /* Try to find the exact program requested to be run */
10812               /*---------------------------------------------------*/
10813               iname = int_rmsexpand
10814                  (tmpspec, image_name, ".exe",
10815                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10816               if (iname != NULL) {
10817                 if (cando_by_name_int
10818                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10819                   /* MCR prefix needed */
10820                   isdcl = 0;
10821                 }
10822                 else {
10823                    /* Try again with a null type */
10824                   /*----------------------------*/
10825                   iname = int_rmsexpand
10826                     (tmpspec, image_name, ".",
10827                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10828                   if (iname != NULL) {
10829                     if (cando_by_name_int
10830                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10831                       /* MCR prefix needed */
10832                       isdcl = 0;
10833                     }
10834                   }
10835                 }
10836
10837                  /* Did we find the image to run the script? */
10838                 /*------------------------------------------*/
10839                 if (isdcl) {
10840                   char *tchr;
10841
10842                    /* Assume DCL or foreign command exists */
10843                   /*--------------------------------------*/
10844                   tchr = strrchr(tmpspec, '/');
10845                   if (tchr != NULL) {
10846                     tchr++;
10847                   }
10848                   else {
10849                     tchr = tmpspec;
10850                   }
10851                   my_strlcpy(image_name, tchr, sizeof(image_name));
10852                 }
10853               }
10854             }
10855           }
10856         }
10857         fclose(fp);
10858       }
10859       if (check_img && isdcl) {
10860           PerlMem_free(cmd);
10861           PerlMem_free(resspec);
10862           PerlMem_free(vmsspec);
10863           return RMS$_FNF;
10864       }
10865
10866       if (cando_by_name(S_IXUSR,0,resspec)) {
10867         vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10868         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10869         if (!isdcl) {
10870             my_strlcpy(vmscmd->dsc$a_pointer,"$ MCR ", MAX_DCL_LINE_LENGTH);
10871             if (image_name[0] != 0) {
10872                 my_strlcat(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10873                 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10874             }
10875         } else if (image_name[0] != 0) {
10876             my_strlcpy(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10877             my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10878         } else {
10879             my_strlcpy(vmscmd->dsc$a_pointer, "@", MAX_DCL_LINE_LENGTH);
10880         }
10881         if (suggest_quote) *suggest_quote = 1;
10882
10883         /* If there is an image name, use original command */
10884         if (image_name[0] == 0)
10885             my_strlcat(vmscmd->dsc$a_pointer, resspec, MAX_DCL_LINE_LENGTH);
10886         else {
10887             rest = cmd;
10888             while (*rest && isspace(*rest)) rest++;
10889         }
10890
10891         if (image_argv[0] != 0) {
10892           my_strlcat(vmscmd->dsc$a_pointer, image_argv, MAX_DCL_LINE_LENGTH);
10893           my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10894         }
10895         if (rest) {
10896            int rest_len;
10897            int vmscmd_len;
10898
10899            rest_len = strlen(rest);
10900            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10901            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10902               my_strlcat(vmscmd->dsc$a_pointer, rest, MAX_DCL_LINE_LENGTH);
10903            else
10904              retsts = CLI$_BUFOVF;
10905         }
10906         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10907         PerlMem_free(cmd);
10908         PerlMem_free(vmsspec);
10909         PerlMem_free(resspec);
10910         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10911       }
10912       else
10913         retsts = RMS$_PRV;
10914     }
10915   }
10916   /* It's either a DCL command or we couldn't find a suitable image */
10917   vmscmd->dsc$w_length = strlen(cmd);
10918
10919   vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(vmscmd->dsc$w_length + 1);
10920   my_strlcpy(vmscmd->dsc$a_pointer, cmd, vmscmd->dsc$w_length + 1);
10921
10922   PerlMem_free(cmd);
10923   PerlMem_free(resspec);
10924   PerlMem_free(vmsspec);
10925
10926   /* check if it's a symbol (for quoting purposes) */
10927   if (suggest_quote && !*suggest_quote) {
10928     int iss;
10929     char equiv[LNM$C_NAMLENGTH];
10930     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10931     eqvdsc.dsc$a_pointer = equiv;
10932
10933     iss = lib$get_symbol(vmscmd,&eqvdsc);
10934     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10935   }
10936   if (!(retsts & 1)) {
10937     /* just hand off status values likely to be due to user error */
10938     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10939         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10940        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10941     else { _ckvmssts_noperl(retsts); }
10942   }
10943
10944   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10945
10946 }  /* end of setup_cmddsc() */
10947
10948
10949 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10950 bool
10951 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10952 {
10953   bool exec_sts;
10954   char * cmd;
10955
10956   if (sp > mark) {
10957     if (vfork_called) {           /* this follows a vfork - act Unixish */
10958       vfork_called--;
10959       if (vfork_called < 0) {
10960         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10961         vfork_called = 0;
10962       }
10963       else return do_aexec(really,mark,sp);
10964     }
10965                                            /* no vfork - act VMSish */
10966     cmd = setup_argstr(aTHX_ really,mark,sp);
10967     exec_sts = vms_do_exec(cmd);
10968     Safefree(cmd);  /* Clean up from setup_argstr() */
10969     return exec_sts;
10970   }
10971
10972   return FALSE;
10973 }  /* end of vms_do_aexec() */
10974 /*}}}*/
10975
10976 /* {{{bool vms_do_exec(char *cmd) */
10977 bool
10978 Perl_vms_do_exec(pTHX_ const char *cmd)
10979 {
10980   struct dsc$descriptor_s *vmscmd;
10981
10982   if (vfork_called) {             /* this follows a vfork - act Unixish */
10983     vfork_called--;
10984     if (vfork_called < 0) {
10985       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10986       vfork_called = 0;
10987     }
10988     else return do_exec(cmd);
10989   }
10990
10991   {                               /* no vfork - act VMSish */
10992     unsigned long int retsts;
10993
10994     TAINT_ENV();
10995     TAINT_PROPER("exec");
10996     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10997       retsts = lib$do_command(vmscmd);
10998
10999     switch (retsts) {
11000       case RMS$_FNF: case RMS$_DNF:
11001         set_errno(ENOENT); break;
11002       case RMS$_DIR:
11003         set_errno(ENOTDIR); break;
11004       case RMS$_DEV:
11005         set_errno(ENODEV); break;
11006       case RMS$_PRV:
11007         set_errno(EACCES); break;
11008       case RMS$_SYN:
11009         set_errno(EINVAL); break;
11010       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11011         set_errno(E2BIG); break;
11012       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11013         _ckvmssts_noperl(retsts); /* fall through */
11014       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11015         set_errno(EVMSERR);
11016     }
11017     set_vaxc_errno(retsts);
11018     if (ckWARN(WARN_EXEC)) {
11019       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
11020              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
11021     }
11022     vms_execfree(vmscmd);
11023   }
11024
11025   return FALSE;
11026
11027 }  /* end of vms_do_exec() */
11028 /*}}}*/
11029
11030 int do_spawn2(pTHX_ const char *, int);
11031
11032 int
11033 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
11034 {
11035   unsigned long int sts;
11036   char * cmd;
11037   int flags = 0;
11038
11039   if (sp > mark) {
11040
11041     /* We'll copy the (undocumented?) Win32 behavior and allow a
11042      * numeric first argument.  But the only value we'll support
11043      * through do_aspawn is a value of 1, which means spawn without
11044      * waiting for completion -- other values are ignored.
11045      */
11046     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
11047         ++mark;
11048         flags = SvIVx(*mark);
11049     }
11050
11051     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
11052         flags = CLI$M_NOWAIT;
11053     else
11054         flags = 0;
11055
11056     cmd = setup_argstr(aTHX_ really, mark, sp);
11057     sts = do_spawn2(aTHX_ cmd, flags);
11058     /* pp_sys will clean up cmd */
11059     return sts;
11060   }
11061   return SS$_ABORT;
11062 }  /* end of do_aspawn() */
11063 /*}}}*/
11064
11065
11066 /* {{{int do_spawn(char* cmd) */
11067 int
11068 Perl_do_spawn(pTHX_ char* cmd)
11069 {
11070     PERL_ARGS_ASSERT_DO_SPAWN;
11071
11072     return do_spawn2(aTHX_ cmd, 0);
11073 }
11074 /*}}}*/
11075
11076 /* {{{int do_spawn_nowait(char* cmd) */
11077 int
11078 Perl_do_spawn_nowait(pTHX_ char* cmd)
11079 {
11080     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
11081
11082     return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
11083 }
11084 /*}}}*/
11085
11086 /* {{{int do_spawn2(char *cmd) */
11087 int
11088 do_spawn2(pTHX_ const char *cmd, int flags)
11089 {
11090   unsigned long int sts, substs;
11091
11092   /* The caller of this routine expects to Safefree(PL_Cmd) */
11093   Newx(PL_Cmd,10,char);
11094
11095   TAINT_ENV();
11096   TAINT_PROPER("spawn");
11097   if (!cmd || !*cmd) {
11098     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
11099     if (!(sts & 1)) {
11100       switch (sts) {
11101         case RMS$_FNF:  case RMS$_DNF:
11102           set_errno(ENOENT); break;
11103         case RMS$_DIR:
11104           set_errno(ENOTDIR); break;
11105         case RMS$_DEV:
11106           set_errno(ENODEV); break;
11107         case RMS$_PRV:
11108           set_errno(EACCES); break;
11109         case RMS$_SYN:
11110           set_errno(EINVAL); break;
11111         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11112           set_errno(E2BIG); break;
11113         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11114           _ckvmssts_noperl(sts); /* fall through */
11115         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11116           set_errno(EVMSERR);
11117       }
11118       set_vaxc_errno(sts);
11119       if (ckWARN(WARN_EXEC)) {
11120         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
11121                     Strerror(errno));
11122       }
11123     }
11124     sts = substs;
11125   }
11126   else {
11127     char mode[3];
11128     PerlIO * fp;
11129     if (flags & CLI$M_NOWAIT)
11130         strcpy(mode, "n");
11131     else
11132         strcpy(mode, "nW");
11133
11134     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
11135     if (fp != NULL)
11136       my_pclose(fp);
11137     /* sts will be the pid in the nowait case, so leave a
11138      * hint saying not to do any bit shifting to it.
11139      */
11140     if (flags & CLI$M_NOWAIT)
11141         PL_statusvalue = -1;
11142   }
11143   return sts;
11144 }  /* end of do_spawn2() */
11145 /*}}}*/
11146
11147
11148 static unsigned int *sockflags, sockflagsize;
11149
11150 /*
11151  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
11152  * routines found in some versions of the CRTL can't deal with sockets.
11153  * We don't shim the other file open routines since a socket isn't
11154  * likely to be opened by a name.
11155  */
11156 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
11157 FILE *
11158 my_fdopen(int fd, const char *mode)
11159 {
11160   FILE *fp = fdopen(fd, mode);
11161
11162   if (fp) {
11163     unsigned int fdoff = fd / sizeof(unsigned int);
11164     Stat_t sbuf; /* native stat; we don't need flex_stat */
11165     if (!sockflagsize || fdoff > sockflagsize) {
11166       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
11167       else           Newx  (sockflags,fdoff+2,unsigned int);
11168       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11169       sockflagsize = fdoff + 2;
11170     }
11171     if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
11172       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11173   }
11174   return fp;
11175
11176 }
11177 /*}}}*/
11178
11179
11180 /*
11181  * Clear the corresponding bit when the (possibly) socket stream is closed.
11182  * There still a small hole: we miss an implicit close which might occur
11183  * via freopen().  >> Todo
11184  */
11185 /*{{{ int my_fclose(FILE *fp)*/
11186 int
11187 my_fclose(FILE *fp) {
11188   if (fp) {
11189     unsigned int fd = fileno(fp);
11190     unsigned int fdoff = fd / sizeof(unsigned int);
11191
11192     if (sockflagsize && fdoff < sockflagsize)
11193       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11194   }
11195   return fclose(fp);
11196 }
11197 /*}}}*/
11198
11199
11200 /*
11201  * A simple fwrite replacement which outputs itmsz*nitm chars without
11202  * introducing record boundaries every itmsz chars.
11203  * We are using fputs, which depends on a terminating null.  We may
11204  * well be writing binary data, so we need to accommodate not only
11205  * data with nulls sprinkled in the middle but also data with no null
11206  * byte at the end.
11207  */
11208 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
11209 int
11210 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11211 {
11212   char *cp, *end, *cpd;
11213   char *data;
11214   unsigned int fd = fileno(dest);
11215   unsigned int fdoff = fd / sizeof(unsigned int);
11216   int retval;
11217   int bufsize = itmsz * nitm + 1;
11218
11219   if (fdoff < sockflagsize &&
11220       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11221     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11222     return nitm;
11223   }
11224
11225   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11226   memcpy( data, src, itmsz*nitm );
11227   data[itmsz*nitm] = '\0';
11228
11229   end = data + itmsz * nitm;
11230   retval = (int) nitm; /* on success return # items written */
11231
11232   cpd = data;
11233   while (cpd <= end) {
11234     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11235     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11236     if (cp < end)
11237       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11238     cpd = cp + 1;
11239   }
11240
11241   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11242   return retval;
11243
11244 }  /* end of my_fwrite() */
11245 /*}}}*/
11246
11247 /*{{{ int my_flush(FILE *fp)*/
11248 int
11249 Perl_my_flush(pTHX_ FILE *fp)
11250 {
11251     int res;
11252     if ((res = fflush(fp)) == 0 && fp) {
11253 #ifdef VMS_DO_SOCKETS
11254         Stat_t s;
11255         if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11256 #endif
11257             res = fsync(fileno(fp));
11258     }
11259 /*
11260  * If the flush succeeded but set end-of-file, we need to clear
11261  * the error because our caller may check ferror().  BTW, this
11262  * probably means we just flushed an empty file.
11263  */
11264     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11265
11266     return res;
11267 }
11268 /*}}}*/
11269
11270 /* fgetname() is not returning the correct file specifications when
11271  * decc_filename_unix_report mode is active.  So we have to have it
11272  * aways return filenames in VMS mode and convert it ourselves.
11273  */
11274
11275 /*{{{ char * my_fgetname(FILE *fp, buf)*/
11276 char *
11277 Perl_my_fgetname(FILE *fp, char * buf) {
11278     char * retname;
11279     char * vms_name;
11280
11281     retname = fgetname(fp, buf, 1);
11282
11283     /* If we are in VMS mode, then we are done */
11284     if (!decc_filename_unix_report || (retname == NULL)) {
11285        return retname;
11286     }
11287
11288     /* Convert this to Unix format */
11289     vms_name = (char *)PerlMem_malloc(VMS_MAXRSS);
11290     my_strlcpy(vms_name, retname, VMS_MAXRSS);
11291     retname = int_tounixspec(vms_name, buf, NULL);
11292     PerlMem_free(vms_name);
11293
11294     return retname;
11295 }
11296 /*}}}*/
11297
11298 /*
11299  * Here are replacements for the following Unix routines in the VMS environment:
11300  *      getpwuid    Get information for a particular UIC or UID
11301  *      getpwnam    Get information for a named user
11302  *      getpwent    Get information for each user in the rights database
11303  *      setpwent    Reset search to the start of the rights database
11304  *      endpwent    Finish searching for users in the rights database
11305  *
11306  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11307  * (defined in pwd.h), which contains the following fields:-
11308  *      struct passwd {
11309  *              char        *pw_name;    Username (in lower case)
11310  *              char        *pw_passwd;  Hashed password
11311  *              unsigned int pw_uid;     UIC
11312  *              unsigned int pw_gid;     UIC group  number
11313  *              char        *pw_unixdir; Default device/directory (VMS-style)
11314  *              char        *pw_gecos;   Owner name
11315  *              char        *pw_dir;     Default device/directory (Unix-style)
11316  *              char        *pw_shell;   Default CLI name (eg. DCL)
11317  *      };
11318  * If the specified user does not exist, getpwuid and getpwnam return NULL.
11319  *
11320  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11321  * not the UIC member number (eg. what's returned by getuid()),
11322  * getpwuid() can accept either as input (if uid is specified, the caller's
11323  * UIC group is used), though it won't recognise gid=0.
11324  *
11325  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11326  * information about other users in your group or in other groups, respectively.
11327  * If the required privilege is not available, then these routines fill only
11328  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11329  * string).
11330  *
11331  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11332  */
11333
11334 /* sizes of various UAF record fields */
11335 #define UAI$S_USERNAME 12
11336 #define UAI$S_IDENT    31
11337 #define UAI$S_OWNER    31
11338 #define UAI$S_DEFDEV   31
11339 #define UAI$S_DEFDIR   63
11340 #define UAI$S_DEFCLI   31
11341 #define UAI$S_PWD       8
11342
11343 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
11344                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11345                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
11346
11347 static char __empty[]= "";
11348 static struct passwd __passwd_empty=
11349     {(char *) __empty, (char *) __empty, 0, 0,
11350      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11351 static int contxt= 0;
11352 static struct passwd __pwdcache;
11353 static char __pw_namecache[UAI$S_IDENT+1];
11354
11355 /*
11356  * This routine does most of the work extracting the user information.
11357  */
11358 static int
11359 fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11360 {
11361     static struct {
11362         unsigned char length;
11363         char pw_gecos[UAI$S_OWNER+1];
11364     } owner;
11365     static union uicdef uic;
11366     static struct {
11367         unsigned char length;
11368         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11369     } defdev;
11370     static struct {
11371         unsigned char length;
11372         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11373     } defdir;
11374     static struct {
11375         unsigned char length;
11376         char pw_shell[UAI$S_DEFCLI+1];
11377     } defcli;
11378     static char pw_passwd[UAI$S_PWD+1];
11379
11380     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11381     struct dsc$descriptor_s name_desc;
11382     unsigned long int sts;
11383
11384     static struct itmlst_3 itmlst[]= {
11385         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
11386         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
11387         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
11388         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
11389         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
11390         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
11391         {0,                0,           NULL,    NULL}};
11392
11393     name_desc.dsc$w_length=  strlen(name);
11394     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11395     name_desc.dsc$b_class=   DSC$K_CLASS_S;
11396     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11397
11398 /*  Note that sys$getuai returns many fields as counted strings. */
11399     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11400     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11401       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11402     }
11403     else { _ckvmssts(sts); }
11404     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
11405
11406     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
11407     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11408     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11409     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11410     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11411     owner.pw_gecos[lowner]=            '\0';
11412     defdev.pw_dir[ldefdev+ldefdir]= '\0';
11413     defcli.pw_shell[ldefcli]=          '\0';
11414     if (valid_uic(uic)) {
11415         pwd->pw_uid= uic.uic$l_uic;
11416         pwd->pw_gid= uic.uic$v_group;
11417     }
11418     else
11419       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11420     pwd->pw_passwd=  pw_passwd;
11421     pwd->pw_gecos=   owner.pw_gecos;
11422     pwd->pw_dir=     defdev.pw_dir;
11423     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11424     pwd->pw_shell=   defcli.pw_shell;
11425     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11426         int ldir;
11427         ldir= strlen(pwd->pw_unixdir) - 1;
11428         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11429     }
11430     else
11431         my_strlcpy(pwd->pw_unixdir, pwd->pw_dir, sizeof(pwd->pw_unixdir));
11432     if (!decc_efs_case_preserve)
11433         __mystrtolower(pwd->pw_unixdir);
11434     return 1;
11435 }
11436
11437 /*
11438  * Get information for a named user.
11439 */
11440 /*{{{struct passwd *getpwnam(char *name)*/
11441 struct passwd *
11442 Perl_my_getpwnam(pTHX_ const char *name)
11443 {
11444     struct dsc$descriptor_s name_desc;
11445     union uicdef uic;
11446     unsigned long int sts;
11447
11448     __pwdcache = __passwd_empty;
11449     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11450       /* We still may be able to determine pw_uid and pw_gid */
11451       name_desc.dsc$w_length=  strlen(name);
11452       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11453       name_desc.dsc$b_class=   DSC$K_CLASS_S;
11454       name_desc.dsc$a_pointer= (char *) name;
11455       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11456         __pwdcache.pw_uid= uic.uic$l_uic;
11457         __pwdcache.pw_gid= uic.uic$v_group;
11458       }
11459       else {
11460         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11461           set_vaxc_errno(sts);
11462           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11463           return NULL;
11464         }
11465         else { _ckvmssts(sts); }
11466       }
11467     }
11468     my_strlcpy(__pw_namecache, name, sizeof(__pw_namecache));
11469     __pwdcache.pw_name= __pw_namecache;
11470     return &__pwdcache;
11471 }  /* end of my_getpwnam() */
11472 /*}}}*/
11473
11474 /*
11475  * Get information for a particular UIC or UID.
11476  * Called by my_getpwent with uid=-1 to list all users.
11477 */
11478 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11479 struct passwd *
11480 Perl_my_getpwuid(pTHX_ Uid_t uid)
11481 {
11482     const $DESCRIPTOR(name_desc,__pw_namecache);
11483     unsigned short lname;
11484     union uicdef uic;
11485     unsigned long int status;
11486
11487     if (uid == (unsigned int) -1) {
11488       do {
11489         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11490         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11491           set_vaxc_errno(status);
11492           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11493           my_endpwent();
11494           return NULL;
11495         }
11496         else { _ckvmssts(status); }
11497       } while (!valid_uic (uic));
11498     }
11499     else {
11500       uic.uic$l_uic= uid;
11501       if (!uic.uic$v_group)
11502         uic.uic$v_group= PerlProc_getgid();
11503       if (valid_uic(uic))
11504         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11505       else status = SS$_IVIDENT;
11506       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11507           status == RMS$_PRV) {
11508         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11509         return NULL;
11510       }
11511       else { _ckvmssts(status); }
11512     }
11513     __pw_namecache[lname]= '\0';
11514     __mystrtolower(__pw_namecache);
11515
11516     __pwdcache = __passwd_empty;
11517     __pwdcache.pw_name = __pw_namecache;
11518
11519 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11520     The identifier's value is usually the UIC, but it doesn't have to be,
11521     so if we can, we let fillpasswd update this. */
11522     __pwdcache.pw_uid =  uic.uic$l_uic;
11523     __pwdcache.pw_gid =  uic.uic$v_group;
11524
11525     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11526     return &__pwdcache;
11527
11528 }  /* end of my_getpwuid() */
11529 /*}}}*/
11530
11531 /*
11532  * Get information for next user.
11533 */
11534 /*{{{struct passwd *my_getpwent()*/
11535 struct passwd *
11536 Perl_my_getpwent(pTHX)
11537 {
11538     return (my_getpwuid((unsigned int) -1));
11539 }
11540 /*}}}*/
11541
11542 /*
11543  * Finish searching rights database for users.
11544 */
11545 /*{{{void my_endpwent()*/
11546 void
11547 Perl_my_endpwent(pTHX)
11548 {
11549     if (contxt) {
11550       _ckvmssts(sys$finish_rdb(&contxt));
11551       contxt= 0;
11552     }
11553 }
11554 /*}}}*/
11555
11556 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11557  * my_utime(), and flex_stat(), all of which operate on UTC unless
11558  * VMSISH_TIMES is true.
11559  */
11560 /* method used to handle UTC conversions:
11561  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
11562  */
11563 static int gmtime_emulation_type;
11564 /* number of secs to add to UTC POSIX-style time to get local time */
11565 static long int utc_offset_secs;
11566
11567 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11568  * in vmsish.h.  #undef them here so we can call the CRTL routines
11569  * directly.
11570  */
11571 #undef gmtime
11572 #undef localtime
11573 #undef time
11574
11575
11576 static time_t toutc_dst(time_t loc) {
11577   struct tm *rsltmp;
11578
11579   if ((rsltmp = localtime(&loc)) == NULL) return -1u;
11580   loc -= utc_offset_secs;
11581   if (rsltmp->tm_isdst) loc -= 3600;
11582   return loc;
11583 }
11584 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11585        ((gmtime_emulation_type || my_time(NULL)), \
11586        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11587        ((secs) - utc_offset_secs))))
11588
11589 static time_t toloc_dst(time_t utc) {
11590   struct tm *rsltmp;
11591
11592   utc += utc_offset_secs;
11593   if ((rsltmp = localtime(&utc)) == NULL) return -1u;
11594   if (rsltmp->tm_isdst) utc += 3600;
11595   return utc;
11596 }
11597 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11598        ((gmtime_emulation_type || my_time(NULL)), \
11599        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11600        ((secs) + utc_offset_secs))))
11601
11602 /* my_time(), my_localtime(), my_gmtime()
11603  * By default traffic in UTC time values, using CRTL gmtime() or
11604  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11605  * Note: We need to use these functions even when the CRTL has working
11606  * UTC support, since they also handle C<use vmsish qw(times);>
11607  *
11608  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
11609  * Modified by Charles Bailey <bailey@newman.upenn.edu>
11610  */
11611
11612 /*{{{time_t my_time(time_t *timep)*/
11613 time_t
11614 Perl_my_time(pTHX_ time_t *timep)
11615 {
11616   time_t when;
11617   struct tm *tm_p;
11618
11619   if (gmtime_emulation_type == 0) {
11620     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
11621                               /* results of calls to gmtime() and localtime() */
11622                               /* for same &base */
11623
11624     gmtime_emulation_type++;
11625     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11626       char off[LNM$C_NAMLENGTH+1];;
11627
11628       gmtime_emulation_type++;
11629       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11630         gmtime_emulation_type++;
11631         utc_offset_secs = 0;
11632         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11633       }
11634       else { utc_offset_secs = atol(off); }
11635     }
11636     else { /* We've got a working gmtime() */
11637       struct tm gmt, local;
11638
11639       gmt = *tm_p;
11640       tm_p = localtime(&base);
11641       local = *tm_p;
11642       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
11643       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11644       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
11645       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
11646     }
11647   }
11648
11649   when = time(NULL);
11650 # ifdef VMSISH_TIME
11651   if (VMSISH_TIME) when = _toloc(when);
11652 # endif
11653   if (timep != NULL) *timep = when;
11654   return when;
11655
11656 }  /* end of my_time() */
11657 /*}}}*/
11658
11659
11660 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11661 struct tm *
11662 Perl_my_gmtime(pTHX_ const time_t *timep)
11663 {
11664   time_t when;
11665   struct tm *rsltmp;
11666
11667   if (timep == NULL) {
11668     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11669     return NULL;
11670   }
11671   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11672
11673   when = *timep;
11674 # ifdef VMSISH_TIME
11675   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11676 #  endif
11677   return gmtime(&when);
11678 }  /* end of my_gmtime() */
11679 /*}}}*/
11680
11681
11682 /*{{{struct tm *my_localtime(const time_t *timep)*/
11683 struct tm *
11684 Perl_my_localtime(pTHX_ const time_t *timep)
11685 {
11686   time_t when;
11687
11688   if (timep == NULL) {
11689     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11690     return NULL;
11691   }
11692   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11693   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11694
11695   when = *timep;
11696 # ifdef VMSISH_TIME
11697   if (VMSISH_TIME) when = _toutc(when);
11698 # endif
11699   /* CRTL localtime() wants UTC as input, does tz correction itself */
11700   return localtime(&when);
11701 } /*  end of my_localtime() */
11702 /*}}}*/
11703
11704 /* Reset definitions for later calls */
11705 #define gmtime(t)    my_gmtime(t)
11706 #define localtime(t) my_localtime(t)
11707 #define time(t)      my_time(t)
11708
11709
11710 /* my_utime - update modification/access time of a file
11711  *
11712  * Only the UTC translation is home-grown. The rest is handled by the
11713  * CRTL utime(), which will take into account the relevant feature
11714  * logicals and ODS-5 volume characteristics for true access times.
11715  *
11716  */
11717
11718 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11719  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
11720  * in 100 ns intervals.
11721  */
11722 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11723
11724 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11725 int
11726 Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11727 {
11728   struct utimbuf utc_utimes, *utc_utimesp;
11729
11730   if (utimes != NULL) {
11731     utc_utimes.actime = utimes->actime;
11732     utc_utimes.modtime = utimes->modtime;
11733 # ifdef VMSISH_TIME
11734     /* If input was local; convert to UTC for sys svc */
11735     if (VMSISH_TIME) {
11736       utc_utimes.actime = _toutc(utimes->actime);
11737       utc_utimes.modtime = _toutc(utimes->modtime);
11738     }
11739 # endif
11740     utc_utimesp = &utc_utimes;
11741   }
11742   else {
11743     utc_utimesp = NULL;
11744   }
11745
11746   return utime(file, utc_utimesp);
11747
11748 }  /* end of my_utime() */
11749 /*}}}*/
11750
11751 /*
11752  * flex_stat, flex_lstat, flex_fstat
11753  * basic stat, but gets it right when asked to stat
11754  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11755  */
11756
11757 #ifndef _USE_STD_STAT
11758 /* encode_dev packs a VMS device name string into an integer to allow
11759  * simple comparisons. This can be used, for example, to check whether two
11760  * files are located on the same device, by comparing their encoded device
11761  * names. Even a string comparison would not do, because stat() reuses the
11762  * device name buffer for each call; so without encode_dev, it would be
11763  * necessary to save the buffer and use strcmp (this would mean a number of
11764  * changes to the standard Perl code, to say nothing of what a Perl script
11765  * would have to do.
11766  *
11767  * The device lock id, if it exists, should be unique (unless perhaps compared
11768  * with lock ids transferred from other nodes). We have a lock id if the disk is
11769  * mounted cluster-wide, which is when we tend to get long (host-qualified)
11770  * device names. Thus we use the lock id in preference, and only if that isn't
11771  * available, do we try to pack the device name into an integer (flagged by
11772  * the sign bit (LOCKID_MASK) being set).
11773  *
11774  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11775  * name and its encoded form, but it seems very unlikely that we will find
11776  * two files on different disks that share the same encoded device names,
11777  * and even more remote that they will share the same file id (if the test
11778  * is to check for the same file).
11779  *
11780  * A better method might be to use sys$device_scan on the first call, and to
11781  * search for the device, returning an index into the cached array.
11782  * The number returned would be more intelligible.
11783  * This is probably not worth it, and anyway would take quite a bit longer
11784  * on the first call.
11785  */
11786 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
11787 static mydev_t
11788 encode_dev (pTHX_ const char *dev)
11789 {
11790   int i;
11791   unsigned long int f;
11792   mydev_t enc;
11793   char c;
11794   const char *q;
11795
11796   if (!dev || !dev[0]) return 0;
11797
11798 #if LOCKID_MASK
11799   {
11800     struct dsc$descriptor_s dev_desc;
11801     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11802
11803     /* For cluster-mounted disks, the disk lock identifier is unique, so we
11804        can try that first. */
11805     dev_desc.dsc$w_length =  strlen (dev);
11806     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
11807     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
11808     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
11809     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11810     if (!$VMS_STATUS_SUCCESS(status)) {
11811       switch (status) {
11812         case SS$_NOSUCHDEV:
11813           SETERRNO(ENODEV, status);
11814           return 0;
11815         default:
11816           _ckvmssts(status);
11817       }
11818     }
11819     if (lockid) return (lockid & ~LOCKID_MASK);
11820   }
11821 #endif
11822
11823   /* Otherwise we try to encode the device name */
11824   enc = 0;
11825   f = 1;
11826   i = 0;
11827   for (q = dev + strlen(dev); q--; q >= dev) {
11828     if (*q == ':')
11829         break;
11830     if (isdigit (*q))
11831       c= (*q) - '0';
11832     else if (isalpha (toupper (*q)))
11833       c= toupper (*q) - 'A' + (char)10;
11834     else
11835       continue; /* Skip '$'s */
11836     i++;
11837     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
11838     if (i>1) f *= 36;
11839     enc += f * (unsigned long int) c;
11840   }
11841   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
11842
11843 }  /* end of encode_dev() */
11844 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11845         device_no = encode_dev(aTHX_ devname)
11846 #else
11847 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11848         device_no = new_dev_no
11849 #endif
11850
11851 static int
11852 is_null_device(const char *name)
11853 {
11854   if (decc_bug_devnull != 0) {
11855     if (strncmp("/dev/null", name, 9) == 0)
11856       return 1;
11857   }
11858     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11859        The underscore prefix, controller letter, and unit number are
11860        independently optional; for our purposes, the colon punctuation
11861        is not.  The colon can be trailed by optional directory and/or
11862        filename, but two consecutive colons indicates a nodename rather
11863        than a device.  [pr]  */
11864   if (*name == '_') ++name;
11865   if (tolower(*name++) != 'n') return 0;
11866   if (tolower(*name++) != 'l') return 0;
11867   if (tolower(*name) == 'a') ++name;
11868   if (*name == '0') ++name;
11869   return (*name++ == ':') && (*name != ':');
11870 }
11871
11872 static int
11873 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
11874
11875 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11876
11877 static I32
11878 Perl_cando_by_name_int(pTHX_ I32 bit, bool effective, const char *fname, int opts)
11879 {
11880   char usrname[L_cuserid];
11881   struct dsc$descriptor_s usrdsc =
11882          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11883   char *vmsname = NULL, *fileified = NULL;
11884   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11885   unsigned short int retlen, trnlnm_iter_count;
11886   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11887   union prvdef curprv;
11888   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11889          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11890          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11891   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11892          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11893          {0,0,0,0}};
11894   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11895          {0,0,0,0}};
11896   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11897   Stat_t st;
11898   static int profile_context = -1;
11899
11900   if (!fname || !*fname) return FALSE;
11901
11902   /* Make sure we expand logical names, since sys$check_access doesn't */
11903   fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
11904   if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11905   if (!strpbrk(fname,"/]>:")) {
11906       my_strlcpy(fileified, fname, VMS_MAXRSS);
11907       trnlnm_iter_count = 0;
11908       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11909         trnlnm_iter_count++;
11910         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11911       }
11912       fname = fileified;
11913   }
11914
11915   vmsname = (char *)PerlMem_malloc(VMS_MAXRSS);
11916   if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11917   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11918     /* Don't know if already in VMS format, so make sure */
11919     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11920       PerlMem_free(fileified);
11921       PerlMem_free(vmsname);
11922       return FALSE;
11923     }
11924   }
11925   else {
11926     my_strlcpy(vmsname, fname, VMS_MAXRSS);
11927   }
11928
11929   /* sys$check_access needs a file spec, not a directory spec.
11930    * flex_stat now will handle a null thread context during startup.
11931    */
11932
11933   retlen = namdsc.dsc$w_length = strlen(vmsname);
11934   if (vmsname[retlen-1] == ']'
11935       || vmsname[retlen-1] == '>'
11936       || vmsname[retlen-1] == ':'
11937       || (!flex_stat_int(vmsname, &st, 1) &&
11938           S_ISDIR(st.st_mode))) {
11939
11940       if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
11941         PerlMem_free(fileified);
11942         PerlMem_free(vmsname);
11943         return FALSE;
11944       }
11945       fname = fileified;
11946   }
11947   else {
11948       fname = vmsname;
11949   }
11950
11951   retlen = namdsc.dsc$w_length = strlen(fname);
11952   namdsc.dsc$a_pointer = (char *)fname;
11953
11954   switch (bit) {
11955     case S_IXUSR: case S_IXGRP: case S_IXOTH:
11956       access = ARM$M_EXECUTE;
11957       flags = CHP$M_READ;
11958       break;
11959     case S_IRUSR: case S_IRGRP: case S_IROTH:
11960       access = ARM$M_READ;
11961       flags = CHP$M_READ | CHP$M_USEREADALL;
11962       break;
11963     case S_IWUSR: case S_IWGRP: case S_IWOTH:
11964       access = ARM$M_WRITE;
11965       flags = CHP$M_READ | CHP$M_WRITE;
11966       break;
11967     case S_IDUSR: case S_IDGRP: case S_IDOTH:
11968       access = ARM$M_DELETE;
11969       flags = CHP$M_READ | CHP$M_WRITE;
11970       break;
11971     default:
11972       if (fileified != NULL)
11973         PerlMem_free(fileified);
11974       if (vmsname != NULL)
11975         PerlMem_free(vmsname);
11976       return FALSE;
11977   }
11978
11979   /* Before we call $check_access, create a user profile with the current
11980    * process privs since otherwise it just uses the default privs from the
11981    * UAF and might give false positives or negatives.  This only works on
11982    * VMS versions v6.0 and later since that's when sys$create_user_profile
11983    * became available.
11984    */
11985
11986   /* get current process privs and username */
11987   _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11988   _ckvmssts_noperl(iosb[0]);
11989
11990   /* find out the space required for the profile */
11991   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11992                                     &usrprodsc.dsc$w_length,&profile_context));
11993
11994   /* allocate space for the profile and get it filled in */
11995   usrprodsc.dsc$a_pointer = (char *)PerlMem_malloc(usrprodsc.dsc$w_length);
11996   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11997   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11998                                     &usrprodsc.dsc$w_length,&profile_context));
11999
12000   /* use the profile to check access to the file; free profile & analyze results */
12001   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
12002   PerlMem_free(usrprodsc.dsc$a_pointer);
12003   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
12004
12005   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
12006       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
12007       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
12008     set_vaxc_errno(retsts);
12009     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12010     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12011     else set_errno(ENOENT);
12012     if (fileified != NULL)
12013       PerlMem_free(fileified);
12014     if (vmsname != NULL)
12015       PerlMem_free(vmsname);
12016     return FALSE;
12017   }
12018   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12019     if (fileified != NULL)
12020       PerlMem_free(fileified);
12021     if (vmsname != NULL)
12022       PerlMem_free(vmsname);
12023     return TRUE;
12024   }
12025   _ckvmssts_noperl(retsts);
12026
12027   if (fileified != NULL)
12028     PerlMem_free(fileified);
12029   if (vmsname != NULL)
12030     PerlMem_free(vmsname);
12031   return FALSE;  /* Should never get here */
12032
12033 }
12034
12035 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
12036 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12037  * subset of the applicable information.
12038  */
12039 bool
12040 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12041 {
12042   return cando_by_name_int
12043         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12044 }  /* end of cando() */
12045 /*}}}*/
12046
12047
12048 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12049 I32
12050 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12051 {
12052    return cando_by_name_int(bit, effective, fname, 0);
12053
12054 }  /* end of cando_by_name() */
12055 /*}}}*/
12056
12057
12058 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12059 int
12060 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12061 {
12062   dSAVE_ERRNO; /* fstat may set this even on success */
12063   if (!fstat(fd, &statbufp->crtl_stat)) {
12064     char *cptr;
12065     char *vms_filename;
12066     vms_filename = (char *)PerlMem_malloc(VMS_MAXRSS);
12067     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12068
12069     /* Save name for cando by name in VMS format */
12070     cptr = getname(fd, vms_filename, 1);
12071
12072     /* This should not happen, but just in case */
12073     if (cptr == NULL) {
12074         statbufp->st_devnam[0] = 0;
12075     }
12076     else {
12077         /* Make sure that the saved name fits in 255 characters */
12078         cptr = int_rmsexpand_vms
12079                        (vms_filename,
12080                         statbufp->st_devnam,
12081                         0);
12082         if (cptr == NULL)
12083             statbufp->st_devnam[0] = 0;
12084     }
12085     PerlMem_free(vms_filename);
12086
12087     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12088     VMS_DEVICE_ENCODE
12089         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12090
12091 #   ifdef VMSISH_TIME
12092     if (VMSISH_TIME) {
12093       statbufp->st_mtime = _toloc(statbufp->st_mtime);
12094       statbufp->st_atime = _toloc(statbufp->st_atime);
12095       statbufp->st_ctime = _toloc(statbufp->st_ctime);
12096     }
12097 #   endif
12098     RESTORE_ERRNO;
12099     return 0;
12100   }
12101   return -1;
12102
12103 }  /* end of flex_fstat() */
12104 /*}}}*/
12105
12106 static int
12107 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12108 {
12109     char *temp_fspec = NULL;
12110     char *fileified = NULL;
12111     const char *save_spec;
12112     char *ret_spec;
12113     int retval = -1;
12114     char efs_hack = 0;
12115     char already_fileified = 0;
12116     dSAVEDERRNO;
12117
12118     if (!fspec) {
12119         errno = EINVAL;
12120         return retval;
12121     }
12122
12123     if (decc_bug_devnull != 0) {
12124       if (is_null_device(fspec)) { /* Fake a stat() for the null device */
12125         memset(statbufp,0,sizeof *statbufp);
12126         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12127         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12128         statbufp->st_uid = 0x00010001;
12129         statbufp->st_gid = 0x0001;
12130         time((time_t *)&statbufp->st_mtime);
12131         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12132         return 0;
12133       }
12134     }
12135
12136     SAVE_ERRNO;
12137
12138 #if __CRTL_VER >= 80200000
12139   /*
12140    * If we are in POSIX filespec mode, accept the filename as is.
12141    */
12142   if (decc_posix_compliant_pathnames == 0) {
12143 #endif
12144
12145     /* Try for a simple stat first.  If fspec contains a filename without
12146      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12147      * and sea:[wine.dark]water. exist, the CRTL prefers the directory here.
12148      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12149      * not sea:[wine.dark]., if the latter exists.  If the intended target is
12150      * the file with null type, specify this by calling flex_stat() with
12151      * a '.' at the end of fspec.
12152      */
12153
12154     if (lstat_flag == 0)
12155         retval = stat(fspec, &statbufp->crtl_stat);
12156     else
12157         retval = lstat(fspec, &statbufp->crtl_stat);
12158
12159     if (!retval) {
12160         save_spec = fspec;
12161     }
12162     else {
12163         /* In the odd case where we have write but not read access
12164          * to a directory, stat('foo.DIR') works but stat('foo') doesn't.
12165          */
12166         fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
12167         if (fileified == NULL)
12168               _ckvmssts_noperl(SS$_INSFMEM);
12169
12170         ret_spec = int_fileify_dirspec(fspec, fileified, NULL);
12171         if (ret_spec != NULL) {
12172             if (lstat_flag == 0)
12173                 retval = stat(fileified, &statbufp->crtl_stat);
12174             else
12175                 retval = lstat(fileified, &statbufp->crtl_stat);
12176             save_spec = fileified;
12177             already_fileified = 1;
12178         }
12179     }
12180
12181     if (retval && vms_bug_stat_filename) {
12182
12183         temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
12184         if (temp_fspec == NULL)
12185             _ckvmssts_noperl(SS$_INSFMEM);
12186
12187         /* We should try again as a vmsified file specification. */
12188
12189         ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12190         if (ret_spec != NULL) {
12191             if (lstat_flag == 0)
12192                 retval = stat(temp_fspec, &statbufp->crtl_stat);
12193             else
12194                 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12195             save_spec = temp_fspec;
12196         }
12197     }
12198
12199     if (retval) {
12200         /* Last chance - allow multiple dots without EFS CHARSET */
12201         /* The CRTL stat() falls down hard on multi-dot filenames in unix
12202          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12203          * enable it if it isn't already.
12204          */
12205         if (!decc_efs_charset && (decc_efs_charset_index > 0))
12206             decc$feature_set_value(decc_efs_charset_index, 1, 1);
12207         if (lstat_flag == 0)
12208             retval = stat(fspec, &statbufp->crtl_stat);
12209         else
12210             retval = lstat(fspec, &statbufp->crtl_stat);
12211         save_spec = fspec;
12212         if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
12213             decc$feature_set_value(decc_efs_charset_index, 1, 0);
12214             efs_hack = 1;
12215         }
12216     }
12217
12218 #if __CRTL_VER >= 80200000
12219   } else {
12220     if (lstat_flag == 0)
12221       retval = stat(temp_fspec, &statbufp->crtl_stat);
12222     else
12223       retval = lstat(temp_fspec, &statbufp->crtl_stat);
12224       save_spec = temp_fspec;
12225   }
12226 #endif
12227
12228   /* As you were... */
12229   if (!decc_efs_charset)
12230     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12231
12232     if (!retval) {
12233       char *cptr;
12234       int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12235
12236       /* If this is an lstat, do not follow the link */
12237       if (lstat_flag)
12238         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12239
12240       /* If we used the efs_hack above, we must also use it here for */
12241       /* perl_cando to work */
12242       if (efs_hack && (decc_efs_charset_index > 0)) {
12243           decc$feature_set_value(decc_efs_charset_index, 1, 1);
12244       }
12245
12246       /* If we've got a directory, save a fileified, expanded version of it
12247        * in st_devnam.  If not a directory, just an expanded version.
12248        */
12249       if (S_ISDIR(statbufp->st_mode) && !already_fileified) {
12250           fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
12251           if (fileified == NULL)
12252               _ckvmssts_noperl(SS$_INSFMEM);
12253
12254           cptr = do_fileify_dirspec(save_spec, fileified, 0, NULL);
12255           if (cptr != NULL)
12256               save_spec = fileified;
12257       }
12258
12259       cptr = int_rmsexpand(save_spec,
12260                            statbufp->st_devnam,
12261                            NULL,
12262                            rmsex_flags,
12263                            0,
12264                            0);
12265
12266       if (efs_hack && (decc_efs_charset_index > 0)) {
12267           decc$feature_set_value(decc_efs_charset, 1, 0);
12268       }
12269
12270       /* Fix me: If this is NULL then stat found a file, and we could */
12271       /* not convert the specification to VMS - Should never happen */
12272       if (cptr == NULL)
12273         statbufp->st_devnam[0] = 0;
12274
12275       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12276       VMS_DEVICE_ENCODE
12277         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12278 #     ifdef VMSISH_TIME
12279       if (VMSISH_TIME) {
12280         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12281         statbufp->st_atime = _toloc(statbufp->st_atime);
12282         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12283       }
12284 #     endif
12285     }
12286     /* If we were successful, leave errno where we found it */
12287     if (retval == 0) RESTORE_ERRNO;
12288     if (temp_fspec)
12289         PerlMem_free(temp_fspec);
12290     if (fileified)
12291         PerlMem_free(fileified);
12292     return retval;
12293
12294 }  /* end of flex_stat_int() */
12295
12296
12297 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12298 int
12299 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12300 {
12301    return flex_stat_int(fspec, statbufp, 0);
12302 }
12303 /*}}}*/
12304
12305 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12306 int
12307 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12308 {
12309    return flex_stat_int(fspec, statbufp, 1);
12310 }
12311 /*}}}*/
12312
12313
12314 /*  rmscopy - copy a file using VMS RMS routines
12315  *
12316  *  Copies contents and attributes of spec_in to spec_out, except owner
12317  *  and protection information.  Name and type of spec_in are used as
12318  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
12319  *  should try to propagate timestamps from the input file to the output file.
12320  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
12321  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
12322  *  propagated to the output file at creation iff the output file specification
12323  *  did not contain an explicit name or type, and the revision date is always
12324  *  updated at the end of the copy operation.  If it is greater than 0, then
12325  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12326  *  other than the revision date should be propagated, and bit 1 indicates
12327  *  that the revision date should be propagated.
12328  *
12329  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12330  *
12331  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12332  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
12333  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
12334  * as part of the Perl standard distribution under the terms of the
12335  * GNU General Public License or the Perl Artistic License.  Copies
12336  * of each may be found in the Perl standard distribution.
12337  */ /* FIXME */
12338 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12339 int
12340 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12341 {
12342     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12343          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12344     unsigned long int sts;
12345     int dna_len;
12346     struct FAB fab_in, fab_out;
12347     struct RAB rab_in, rab_out;
12348     rms_setup_nam(nam);
12349     rms_setup_nam(nam_out);
12350     struct XABDAT xabdat;
12351     struct XABFHC xabfhc;
12352     struct XABRDT xabrdt;
12353     struct XABSUM xabsum;
12354
12355     vmsin = (char *)PerlMem_malloc(VMS_MAXRSS);
12356     if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12357     vmsout = (char *)PerlMem_malloc(VMS_MAXRSS);
12358     if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12359     if (!spec_in  || !*spec_in  || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
12360         !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
12361       PerlMem_free(vmsin);
12362       PerlMem_free(vmsout);
12363       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12364       return 0;
12365     }
12366
12367     esa = (char *)PerlMem_malloc(VMS_MAXRSS);
12368     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12369     esal = NULL;
12370 #if defined(NAML$C_MAXRSS)
12371     esal = (char *)PerlMem_malloc(VMS_MAXRSS);
12372     if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12373 #endif
12374     fab_in = cc$rms_fab;
12375     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12376     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12377     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12378     fab_in.fab$l_fop = FAB$M_SQO;
12379     rms_bind_fab_nam(fab_in, nam);
12380     fab_in.fab$l_xab = (void *) &xabdat;
12381
12382     rsa = (char *)PerlMem_malloc(VMS_MAXRSS);
12383     if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12384     rsal = NULL;
12385 #if defined(NAML$C_MAXRSS)
12386     rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
12387     if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12388 #endif
12389     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12390     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12391     rms_nam_esl(nam) = 0;
12392     rms_nam_rsl(nam) = 0;
12393     rms_nam_esll(nam) = 0;
12394     rms_nam_rsll(nam) = 0;
12395 #ifdef NAM$M_NO_SHORT_UPCASE
12396     if (decc_efs_case_preserve)
12397         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12398 #endif
12399
12400     xabdat = cc$rms_xabdat;        /* To get creation date */
12401     xabdat.xab$l_nxt = (void *) &xabfhc;
12402
12403     xabfhc = cc$rms_xabfhc;        /* To get record length */
12404     xabfhc.xab$l_nxt = (void *) &xabsum;
12405
12406     xabsum = cc$rms_xabsum;        /* To get key and area information */
12407
12408     if (!((sts = sys$open(&fab_in)) & 1)) {
12409       PerlMem_free(vmsin);
12410       PerlMem_free(vmsout);
12411       PerlMem_free(esa);
12412       if (esal != NULL)
12413         PerlMem_free(esal);
12414       PerlMem_free(rsa);
12415       if (rsal != NULL)
12416         PerlMem_free(rsal);
12417       set_vaxc_errno(sts);
12418       switch (sts) {
12419         case RMS$_FNF: case RMS$_DNF:
12420           set_errno(ENOENT); break;
12421         case RMS$_DIR:
12422           set_errno(ENOTDIR); break;
12423         case RMS$_DEV:
12424           set_errno(ENODEV); break;
12425         case RMS$_SYN:
12426           set_errno(EINVAL); break;
12427         case RMS$_PRV:
12428           set_errno(EACCES); break;
12429         default:
12430           set_errno(EVMSERR);
12431       }
12432       return 0;
12433     }
12434
12435     nam_out = nam;
12436     fab_out = fab_in;
12437     fab_out.fab$w_ifi = 0;
12438     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12439     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12440     fab_out.fab$l_fop = FAB$M_SQO;
12441     rms_bind_fab_nam(fab_out, nam_out);
12442     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12443     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12444     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12445     esa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
12446     if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12447     rsa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
12448     if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12449     esal_out = NULL;
12450     rsal_out = NULL;
12451 #if defined(NAML$C_MAXRSS)
12452     esal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
12453     if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12454     rsal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
12455     if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12456 #endif
12457     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12458     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12459
12460     if (preserve_dates == 0) {  /* Act like DCL COPY */
12461       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12462       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
12463       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12464         PerlMem_free(vmsin);
12465         PerlMem_free(vmsout);
12466         PerlMem_free(esa);
12467         if (esal != NULL)
12468             PerlMem_free(esal);
12469         PerlMem_free(rsa);
12470         if (rsal != NULL)
12471             PerlMem_free(rsal);
12472         PerlMem_free(esa_out);
12473         if (esal_out != NULL)
12474             PerlMem_free(esal_out);
12475         PerlMem_free(rsa_out);
12476         if (rsal_out != NULL)
12477             PerlMem_free(rsal_out);
12478         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12479         set_vaxc_errno(sts);
12480         return 0;
12481       }
12482       fab_out.fab$l_xab = (void *) &xabdat;
12483       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12484         preserve_dates = 1;
12485     }
12486     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
12487       preserve_dates =0;      /* bitmask from this point forward   */
12488
12489     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12490     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12491       PerlMem_free(vmsin);
12492       PerlMem_free(vmsout);
12493       PerlMem_free(esa);
12494       if (esal != NULL)
12495           PerlMem_free(esal);
12496       PerlMem_free(rsa);
12497       if (rsal != NULL)
12498           PerlMem_free(rsal);
12499       PerlMem_free(esa_out);
12500       if (esal_out != NULL)
12501           PerlMem_free(esal_out);
12502       PerlMem_free(rsa_out);
12503       if (rsal_out != NULL)
12504           PerlMem_free(rsal_out);
12505       set_vaxc_errno(sts);
12506       switch (sts) {
12507         case RMS$_DNF:
12508           set_errno(ENOENT); break;
12509         case RMS$_DIR:
12510           set_errno(ENOTDIR); break;
12511         case RMS$_DEV:
12512           set_errno(ENODEV); break;
12513         case RMS$_SYN:
12514           set_errno(EINVAL); break;
12515         case RMS$_PRV:
12516           set_errno(EACCES); break;
12517         default:
12518           set_errno(EVMSERR);
12519       }
12520       return 0;
12521     }
12522     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
12523     if (preserve_dates & 2) {
12524       /* sys$close() will process xabrdt, not xabdat */
12525       xabrdt = cc$rms_xabrdt;
12526       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12527       fab_out.fab$l_xab = (void *) &xabrdt;
12528     }
12529
12530     ubf = (char *)PerlMem_malloc(32256);
12531     if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12532     rab_in = cc$rms_rab;
12533     rab_in.rab$l_fab = &fab_in;
12534     rab_in.rab$l_rop = RAB$M_BIO;
12535     rab_in.rab$l_ubf = ubf;
12536     rab_in.rab$w_usz = 32256;
12537     if (!((sts = sys$connect(&rab_in)) & 1)) {
12538       sys$close(&fab_in); sys$close(&fab_out);
12539       PerlMem_free(vmsin);
12540       PerlMem_free(vmsout);
12541       PerlMem_free(ubf);
12542       PerlMem_free(esa);
12543       if (esal != NULL)
12544           PerlMem_free(esal);
12545       PerlMem_free(rsa);
12546       if (rsal != NULL)
12547           PerlMem_free(rsal);
12548       PerlMem_free(esa_out);
12549       if (esal_out != NULL)
12550           PerlMem_free(esal_out);
12551       PerlMem_free(rsa_out);
12552       if (rsal_out != NULL)
12553           PerlMem_free(rsal_out);
12554       set_errno(EVMSERR); set_vaxc_errno(sts);
12555       return 0;
12556     }
12557
12558     rab_out = cc$rms_rab;
12559     rab_out.rab$l_fab = &fab_out;
12560     rab_out.rab$l_rbf = ubf;
12561     if (!((sts = sys$connect(&rab_out)) & 1)) {
12562       sys$close(&fab_in); sys$close(&fab_out);
12563       PerlMem_free(vmsin);
12564       PerlMem_free(vmsout);
12565       PerlMem_free(ubf);
12566       PerlMem_free(esa);
12567       if (esal != NULL)
12568           PerlMem_free(esal);
12569       PerlMem_free(rsa);
12570       if (rsal != NULL)
12571           PerlMem_free(rsal);
12572       PerlMem_free(esa_out);
12573       if (esal_out != NULL)
12574           PerlMem_free(esal_out);
12575       PerlMem_free(rsa_out);
12576       if (rsal_out != NULL)
12577           PerlMem_free(rsal_out);
12578       set_errno(EVMSERR); set_vaxc_errno(sts);
12579       return 0;
12580     }
12581
12582     while ((sts = sys$read(&rab_in))) {  /* always true  */
12583       if (sts == RMS$_EOF) break;
12584       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12585       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12586         sys$close(&fab_in); sys$close(&fab_out);
12587         PerlMem_free(vmsin);
12588         PerlMem_free(vmsout);
12589         PerlMem_free(ubf);
12590         PerlMem_free(esa);
12591         if (esal != NULL)
12592             PerlMem_free(esal);
12593         PerlMem_free(rsa);
12594         if (rsal != NULL)
12595             PerlMem_free(rsal);
12596         PerlMem_free(esa_out);
12597         if (esal_out != NULL)
12598             PerlMem_free(esal_out);
12599         PerlMem_free(rsa_out);
12600         if (rsal_out != NULL)
12601             PerlMem_free(rsal_out);
12602         set_errno(EVMSERR); set_vaxc_errno(sts);
12603         return 0;
12604       }
12605     }
12606
12607
12608     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
12609     sys$close(&fab_in);  sys$close(&fab_out);
12610     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12611
12612     PerlMem_free(vmsin);
12613     PerlMem_free(vmsout);
12614     PerlMem_free(ubf);
12615     PerlMem_free(esa);
12616     if (esal != NULL)
12617         PerlMem_free(esal);
12618     PerlMem_free(rsa);
12619     if (rsal != NULL)
12620         PerlMem_free(rsal);
12621     PerlMem_free(esa_out);
12622     if (esal_out != NULL)
12623         PerlMem_free(esal_out);
12624     PerlMem_free(rsa_out);
12625     if (rsal_out != NULL)
12626         PerlMem_free(rsal_out);
12627
12628     if (!(sts & 1)) {
12629       set_errno(EVMSERR); set_vaxc_errno(sts);
12630       return 0;
12631     }
12632
12633     return 1;
12634
12635 }  /* end of rmscopy() */
12636 /*}}}*/
12637
12638
12639 /***  The following glue provides 'hooks' to make some of the routines
12640  * from this file available from Perl.  These routines are sufficiently
12641  * basic, and are required sufficiently early in the build process,
12642  * that's it's nice to have them available to miniperl as well as the
12643  * full Perl, so they're set up here instead of in an extension.  The
12644  * Perl code which handles importation of these names into a given
12645  * package lives in [.VMS]Filespec.pm in @INC.
12646  */
12647
12648 void
12649 rmsexpand_fromperl(pTHX_ CV *cv)
12650 {
12651   dXSARGS;
12652   char *fspec, *defspec = NULL, *rslt;
12653   STRLEN n_a;
12654   int fs_utf8, dfs_utf8;
12655
12656   fs_utf8 = 0;
12657   dfs_utf8 = 0;
12658   if (!items || items > 2)
12659     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12660   fspec = SvPV(ST(0),n_a);
12661   fs_utf8 = SvUTF8(ST(0));
12662   if (!fspec || !*fspec) XSRETURN_UNDEF;
12663   if (items == 2) {
12664     defspec = SvPV(ST(1),n_a);
12665     dfs_utf8 = SvUTF8(ST(1));
12666   }
12667   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12668   ST(0) = sv_newmortal();
12669   if (rslt != NULL) {
12670     sv_usepvn(ST(0),rslt,strlen(rslt));
12671     if (fs_utf8) {
12672         SvUTF8_on(ST(0));
12673     }
12674   }
12675   XSRETURN(1);
12676 }
12677
12678 void
12679 vmsify_fromperl(pTHX_ CV *cv)
12680 {
12681   dXSARGS;
12682   char *vmsified;
12683   STRLEN n_a;
12684   int utf8_fl;
12685
12686   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12687   utf8_fl = SvUTF8(ST(0));
12688   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12689   ST(0) = sv_newmortal();
12690   if (vmsified != NULL) {
12691     sv_usepvn(ST(0),vmsified,strlen(vmsified));
12692     if (utf8_fl) {
12693         SvUTF8_on(ST(0));
12694     }
12695   }
12696   XSRETURN(1);
12697 }
12698
12699 void
12700 unixify_fromperl(pTHX_ CV *cv)
12701 {
12702   dXSARGS;
12703   char *unixified;
12704   STRLEN n_a;
12705   int utf8_fl;
12706
12707   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12708   utf8_fl = SvUTF8(ST(0));
12709   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12710   ST(0) = sv_newmortal();
12711   if (unixified != NULL) {
12712     sv_usepvn(ST(0),unixified,strlen(unixified));
12713     if (utf8_fl) {
12714         SvUTF8_on(ST(0));
12715     }
12716   }
12717   XSRETURN(1);
12718 }
12719
12720 void
12721 fileify_fromperl(pTHX_ CV *cv)
12722 {
12723   dXSARGS;
12724   char *fileified;
12725   STRLEN n_a;
12726   int utf8_fl;
12727
12728   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12729   utf8_fl = SvUTF8(ST(0));
12730   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12731   ST(0) = sv_newmortal();
12732   if (fileified != NULL) {
12733     sv_usepvn(ST(0),fileified,strlen(fileified));
12734     if (utf8_fl) {
12735         SvUTF8_on(ST(0));
12736     }
12737   }
12738   XSRETURN(1);
12739 }
12740
12741 void
12742 pathify_fromperl(pTHX_ CV *cv)
12743 {
12744   dXSARGS;
12745   char *pathified;
12746   STRLEN n_a;
12747   int utf8_fl;
12748
12749   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12750   utf8_fl = SvUTF8(ST(0));
12751   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12752   ST(0) = sv_newmortal();
12753   if (pathified != NULL) {
12754     sv_usepvn(ST(0),pathified,strlen(pathified));
12755     if (utf8_fl) {
12756         SvUTF8_on(ST(0));
12757     }
12758   }
12759   XSRETURN(1);
12760 }
12761
12762 void
12763 vmspath_fromperl(pTHX_ CV *cv)
12764 {
12765   dXSARGS;
12766   char *vmspath;
12767   STRLEN n_a;
12768   int utf8_fl;
12769
12770   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12771   utf8_fl = SvUTF8(ST(0));
12772   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12773   ST(0) = sv_newmortal();
12774   if (vmspath != NULL) {
12775     sv_usepvn(ST(0),vmspath,strlen(vmspath));
12776     if (utf8_fl) {
12777         SvUTF8_on(ST(0));
12778     }
12779   }
12780   XSRETURN(1);
12781 }
12782
12783 void
12784 unixpath_fromperl(pTHX_ CV *cv)
12785 {
12786   dXSARGS;
12787   char *unixpath;
12788   STRLEN n_a;
12789   int utf8_fl;
12790
12791   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12792   utf8_fl = SvUTF8(ST(0));
12793   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12794   ST(0) = sv_newmortal();
12795   if (unixpath != NULL) {
12796     sv_usepvn(ST(0),unixpath,strlen(unixpath));
12797     if (utf8_fl) {
12798         SvUTF8_on(ST(0));
12799     }
12800   }
12801   XSRETURN(1);
12802 }
12803
12804 void
12805 candelete_fromperl(pTHX_ CV *cv)
12806 {
12807   dXSARGS;
12808   char *fspec, *fsp;
12809   SV *mysv;
12810   IO *io;
12811   STRLEN n_a;
12812
12813   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12814
12815   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12816   Newx(fspec, VMS_MAXRSS, char);
12817   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12818   if (isGV_with_GP(mysv)) {
12819     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12820       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12821       ST(0) = &PL_sv_no;
12822       Safefree(fspec);
12823       XSRETURN(1);
12824     }
12825     fsp = fspec;
12826   }
12827   else {
12828     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12829       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12830       ST(0) = &PL_sv_no;
12831       Safefree(fspec);
12832       XSRETURN(1);
12833     }
12834   }
12835
12836   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12837   Safefree(fspec);
12838   XSRETURN(1);
12839 }
12840
12841 void
12842 rmscopy_fromperl(pTHX_ CV *cv)
12843 {
12844   dXSARGS;
12845   char *inspec, *outspec, *inp, *outp;
12846   int date_flag;
12847   SV *mysv;
12848   IO *io;
12849   STRLEN n_a;
12850
12851   if (items < 2 || items > 3)
12852     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12853
12854   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12855   Newx(inspec, VMS_MAXRSS, char);
12856   if (isGV_with_GP(mysv)) {
12857     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12858       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12859       ST(0) = sv_2mortal(newSViv(0));
12860       Safefree(inspec);
12861       XSRETURN(1);
12862     }
12863     inp = inspec;
12864   }
12865   else {
12866     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12867       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12868       ST(0) = sv_2mortal(newSViv(0));
12869       Safefree(inspec);
12870       XSRETURN(1);
12871     }
12872   }
12873   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12874   Newx(outspec, VMS_MAXRSS, char);
12875   if (isGV_with_GP(mysv)) {
12876     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12877       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12878       ST(0) = sv_2mortal(newSViv(0));
12879       Safefree(inspec);
12880       Safefree(outspec);
12881       XSRETURN(1);
12882     }
12883     outp = outspec;
12884   }
12885   else {
12886     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12887       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12888       ST(0) = sv_2mortal(newSViv(0));
12889       Safefree(inspec);
12890       Safefree(outspec);
12891       XSRETURN(1);
12892     }
12893   }
12894   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12895
12896   ST(0) = sv_2mortal(newSViv(rmscopy(inp,outp,date_flag)));
12897   Safefree(inspec);
12898   Safefree(outspec);
12899   XSRETURN(1);
12900 }
12901
12902 /* The mod2fname is limited to shorter filenames by design, so it should
12903  * not be modified to support longer EFS pathnames
12904  */
12905 void
12906 mod2fname(pTHX_ CV *cv)
12907 {
12908   dXSARGS;
12909   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12910        workbuff[NAM$C_MAXRSS*1 + 1];
12911   SSize_t counter, num_entries;
12912   /* ODS-5 ups this, but we want to be consistent, so... */
12913   int max_name_len = 39;
12914   AV *in_array = (AV *)SvRV(ST(0));
12915
12916   num_entries = av_tindex(in_array);
12917
12918   /* All the names start with PL_. */
12919   strcpy(ultimate_name, "PL_");
12920
12921   /* Clean up our working buffer */
12922   Zero(work_name, sizeof(work_name), char);
12923
12924   /* Run through the entries and build up a working name */
12925   for(counter = 0; counter <= num_entries; counter++) {
12926     /* If it's not the first name then tack on a __ */
12927     if (counter) {
12928       my_strlcat(work_name, "__", sizeof(work_name));
12929     }
12930     my_strlcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)), sizeof(work_name));
12931   }
12932
12933   /* Check to see if we actually have to bother...*/
12934   if (strlen(work_name) + 3 <= max_name_len) {
12935     my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
12936   } else {
12937     /* It's too darned big, so we need to go strip. We use the same */
12938     /* algorithm as xsubpp does. First, strip out doubled __ */
12939     char *source, *dest, last;
12940     dest = workbuff;
12941     last = 0;
12942     for (source = work_name; *source; source++) {
12943       if (last == *source && last == '_') {
12944         continue;
12945       }
12946       *dest++ = *source;
12947       last = *source;
12948     }
12949     /* Go put it back */
12950     my_strlcpy(work_name, workbuff, sizeof(work_name));
12951     /* Is it still too big? */
12952     if (strlen(work_name) + 3 > max_name_len) {
12953       /* Strip duplicate letters */
12954       last = 0;
12955       dest = workbuff;
12956       for (source = work_name; *source; source++) {
12957         if (last == toupper(*source)) {
12958         continue;
12959         }
12960         *dest++ = *source;
12961         last = toupper(*source);
12962       }
12963       my_strlcpy(work_name, workbuff, sizeof(work_name));
12964     }
12965
12966     /* Is it *still* too big? */
12967     if (strlen(work_name) + 3 > max_name_len) {
12968       /* Too bad, we truncate */
12969       work_name[max_name_len - 2] = 0;
12970     }
12971     my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
12972   }
12973
12974   /* Okay, return it */
12975   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
12976   XSRETURN(1);
12977 }
12978
12979 void
12980 hushexit_fromperl(pTHX_ CV *cv)
12981 {
12982     dXSARGS;
12983
12984     if (items > 0) {
12985         VMSISH_HUSHED = SvTRUE(ST(0));
12986     }
12987     ST(0) = boolSV(VMSISH_HUSHED);
12988     XSRETURN(1);
12989 }
12990
12991
12992 PerlIO *
12993 Perl_vms_start_glob(pTHX_ SV *tmpglob, IO *io)
12994 {
12995     PerlIO *fp;
12996     struct vs_str_st *rslt;
12997     char *vmsspec;
12998     char *rstr;
12999     char *begin, *cp;
13000     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13001     PerlIO *tmpfp;
13002     STRLEN i;
13003     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13004     struct dsc$descriptor_vs rsdsc;
13005     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13006     unsigned long hasver = 0, isunix = 0;
13007     unsigned long int lff_flags = 0;
13008     int rms_sts;
13009     int vms_old_glob = 1;
13010
13011     if (!SvOK(tmpglob)) {
13012         SETERRNO(ENOENT,RMS$_FNF);
13013         return NULL;
13014     }
13015
13016     vms_old_glob = !decc_filename_unix_report;
13017
13018 #ifdef VMS_LONGNAME_SUPPORT
13019     lff_flags = LIB$M_FIL_LONG_NAMES;
13020 #endif
13021     /* The Newx macro will not allow me to assign a smaller array
13022      * to the rslt pointer, so we will assign it to the begin char pointer
13023      * and then copy the value into the rslt pointer.
13024      */
13025     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13026     rslt = (struct vs_str_st *)begin;
13027     rslt->length = 0;
13028     rstr = &rslt->str[0];
13029     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13030     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13031     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13032     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13033
13034     Newx(vmsspec, VMS_MAXRSS, char);
13035
13036         /* We could find out if there's an explicit dev/dir or version
13037            by peeking into lib$find_file's internal context at
13038            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13039            but that's unsupported, so I don't want to do it now and
13040            have it bite someone in the future. */
13041         /* Fix-me: vms_split_path() is the only way to do this, the
13042            existing method will fail with many legal EFS or UNIX specifications
13043          */
13044
13045     cp = SvPV(tmpglob,i);
13046
13047     for (; i; i--) {
13048         if (cp[i] == ';') hasver = 1;
13049         if (cp[i] == '.') {
13050             if (sts) hasver = 1;
13051             else sts = 1;
13052         }
13053         if (cp[i] == '/') {
13054             hasdir = isunix = 1;
13055             break;
13056         }
13057         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13058             hasdir = 1;
13059             break;
13060         }
13061     }
13062
13063     /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13064     if ((hasdir == 0) && decc_filename_unix_report) {
13065         isunix = 1;
13066     }
13067
13068     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13069         char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13070         int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13071         int wildstar = 0;
13072         int wildquery = 0;
13073         int found = 0;
13074         Stat_t st;
13075         int stat_sts;
13076         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13077         if (!stat_sts && S_ISDIR(st.st_mode)) {
13078             char * vms_dir;
13079             const char * fname;
13080             STRLEN fname_len;
13081
13082             /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13083             /* path delimiter of ':>]', if so, then the old behavior has */
13084             /* obviously been specifically requested */
13085
13086             fname = SvPVX_const(tmpglob);
13087             fname_len = strlen(fname);
13088             vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13089             if (vms_old_glob || (vms_dir != NULL)) {
13090                 wilddsc.dsc$a_pointer = tovmspath_utf8(
13091                                             SvPVX(tmpglob),vmsspec,NULL);
13092                 ok = (wilddsc.dsc$a_pointer != NULL);
13093                 /* maybe passed 'foo' rather than '[.foo]', thus not
13094                    detected above */
13095                 hasdir = 1;
13096             } else {
13097                 /* Operate just on the directory, the special stat/fstat for */
13098                 /* leaves the fileified  specification in the st_devnam */
13099                 /* member. */
13100                 wilddsc.dsc$a_pointer = st.st_devnam;
13101                 ok = 1;
13102             }
13103         }
13104         else {
13105             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13106             ok = (wilddsc.dsc$a_pointer != NULL);
13107         }
13108         if (ok)
13109             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13110
13111         /* If not extended character set, replace ? with % */
13112         /* With extended character set, ? is a wildcard single character */
13113         for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13114             if (*cp == '?') {
13115                 wildquery = 1;
13116                 if (!decc_efs_charset)
13117                     *cp = '%';
13118             } else if (*cp == '%') {
13119                 wildquery = 1;
13120             } else if (*cp == '*') {
13121                 wildstar = 1;
13122             }
13123         }
13124
13125         if (ok) {
13126             wv_sts = vms_split_path(
13127                 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13128                 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13129                 &wvs_spec, &wvs_len);
13130         } else {
13131             wn_spec = NULL;
13132             wn_len = 0;
13133             we_spec = NULL;
13134             we_len = 0;
13135         }
13136
13137         sts = SS$_NORMAL;
13138         while (ok && $VMS_STATUS_SUCCESS(sts)) {
13139          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13140          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13141          int valid_find;
13142
13143             valid_find = 0;
13144             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13145                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
13146             if (!$VMS_STATUS_SUCCESS(sts))
13147                 break;
13148
13149             /* with varying string, 1st word of buffer contains result length */
13150             rstr[rslt->length] = '\0';
13151
13152              /* Find where all the components are */
13153              v_sts = vms_split_path
13154                        (rstr,
13155                         &v_spec,
13156                         &v_len,
13157                         &r_spec,
13158                         &r_len,
13159                         &d_spec,
13160                         &d_len,
13161                         &n_spec,
13162                         &n_len,
13163                         &e_spec,
13164                         &e_len,
13165                         &vs_spec,
13166                         &vs_len);
13167
13168             /* If no version on input, truncate the version on output */
13169             if (!hasver && (vs_len > 0)) {
13170                 *vs_spec = '\0';
13171                 vs_len = 0;
13172             }
13173
13174             if (isunix) {
13175
13176                 /* In Unix report mode, remove the ".dir;1" from the name */
13177                 /* if it is a real directory */
13178                 if (decc_filename_unix_report && decc_efs_charset) {
13179                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13180                         Stat_t statbuf;
13181                         int ret_sts;
13182
13183                         ret_sts = flex_lstat(rstr, &statbuf);
13184                         if ((ret_sts == 0) &&
13185                             S_ISDIR(statbuf.st_mode)) {
13186                             e_len = 0;
13187                             e_spec[0] = 0;
13188                         }
13189                     }
13190                 }
13191
13192                 /* No version & a null extension on UNIX handling */
13193                 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13194                     e_len = 0;
13195                     *e_spec = '\0';
13196                 }
13197             }
13198
13199             if (!decc_efs_case_preserve) {
13200                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13201             }
13202
13203             /* Find File treats a Null extension as return all extensions */
13204             /* This is contrary to Perl expectations */
13205
13206             if (wildstar || wildquery || vms_old_glob) {
13207                 /* really need to see if the returned file name matched */
13208                 /* but for now will assume that it matches */
13209                 valid_find = 1;
13210             } else {
13211                 /* Exact Match requested */
13212                 /* How are directories handled? - like a file */
13213                 if ((e_len == we_len) && (n_len == wn_len)) {
13214                     int t1;
13215                     t1 = e_len;
13216                     if (t1 > 0)
13217                         t1 = strncmp(e_spec, we_spec, e_len);
13218                     if (t1 == 0) {
13219                        t1 = n_len;
13220                        if (t1 > 0)
13221                            t1 = strncmp(n_spec, we_spec, n_len);
13222                        if (t1 == 0)
13223                            valid_find = 1;
13224                     }
13225                 }
13226             }
13227
13228             if (valid_find) {
13229                 found++;
13230
13231                 if (hasdir) {
13232                     if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13233                     begin = rstr;
13234                 }
13235                 else {
13236                     /* Start with the name */
13237                     begin = n_spec;
13238                 }
13239                 strcat(begin,"\n");
13240                 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13241             }
13242         }
13243         if (cxt) (void)lib$find_file_end(&cxt);
13244
13245         if (!found) {
13246             /* Be POSIXish: return the input pattern when no matches */
13247             my_strlcpy(rstr, SvPVX(tmpglob), VMS_MAXRSS);
13248             strcat(rstr,"\n");
13249             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13250         }
13251
13252         if (ok && sts != RMS$_NMF &&
13253             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13254         if (!ok) {
13255             if (!(sts & 1)) {
13256                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13257             }
13258             PerlIO_close(tmpfp);
13259             fp = NULL;
13260         }
13261         else {
13262             PerlIO_rewind(tmpfp);
13263             IoTYPE(io) = IoTYPE_RDONLY;
13264             IoIFP(io) = fp = tmpfp;
13265             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
13266         }
13267     }
13268     Safefree(vmsspec);
13269     Safefree(rslt);
13270     return fp;
13271 }
13272
13273
13274 static char *
13275 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13276                    int *utf8_fl);
13277
13278 void
13279 unixrealpath_fromperl(pTHX_ CV *cv)
13280 {
13281     dXSARGS;
13282     char *fspec, *rslt_spec, *rslt;
13283     STRLEN n_a;
13284
13285     if (!items || items != 1)
13286         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
13287
13288     fspec = SvPV(ST(0),n_a);
13289     if (!fspec || !*fspec) XSRETURN_UNDEF;
13290
13291     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13292     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13293
13294     ST(0) = sv_newmortal();
13295     if (rslt != NULL)
13296         sv_usepvn(ST(0),rslt,strlen(rslt));
13297     else
13298         Safefree(rslt_spec);
13299         XSRETURN(1);
13300 }
13301
13302 static char *
13303 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13304                    int *utf8_fl);
13305
13306 void
13307 vmsrealpath_fromperl(pTHX_ CV *cv)
13308 {
13309     dXSARGS;
13310     char *fspec, *rslt_spec, *rslt;
13311     STRLEN n_a;
13312
13313     if (!items || items != 1)
13314         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
13315
13316     fspec = SvPV(ST(0),n_a);
13317     if (!fspec || !*fspec) XSRETURN_UNDEF;
13318
13319     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13320     rslt = do_vms_realname(fspec, rslt_spec, NULL);
13321
13322     ST(0) = sv_newmortal();
13323     if (rslt != NULL)
13324         sv_usepvn(ST(0),rslt,strlen(rslt));
13325     else
13326         Safefree(rslt_spec);
13327         XSRETURN(1);
13328 }
13329
13330 #ifdef HAS_SYMLINK
13331 /*
13332  * A thin wrapper around decc$symlink to make sure we follow the
13333  * standard and do not create a symlink with a zero-length name,
13334  * and convert the target to Unix format, as the CRTL can't handle
13335  * targets in VMS format.
13336  */
13337 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
13338 int
13339 Perl_my_symlink(pTHX_ const char *contents, const char *link_name)
13340 {
13341     int sts;
13342     char * utarget;
13343
13344     if (!link_name || !*link_name) {
13345       SETERRNO(ENOENT, SS$_NOSUCHFILE);
13346       return -1;
13347     }
13348
13349     utarget = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
13350     /* An untranslatable filename should be passed through. */
13351     (void) int_tounixspec(contents, utarget, NULL);
13352     sts = symlink(utarget, link_name);
13353     PerlMem_free(utarget);
13354     return sts;
13355 }
13356 /*}}}*/
13357
13358 #endif /* HAS_SYMLINK */
13359
13360 int do_vms_case_tolerant(void);
13361
13362 void
13363 case_tolerant_process_fromperl(pTHX_ CV *cv)
13364 {
13365   dXSARGS;
13366   ST(0) = boolSV(do_vms_case_tolerant());
13367   XSRETURN(1);
13368 }
13369
13370 #ifdef USE_ITHREADS
13371
13372 void
13373 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13374                           struct interp_intern *dst)
13375 {
13376     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13377
13378     memcpy(dst,src,sizeof(struct interp_intern));
13379 }
13380
13381 #endif
13382
13383 void
13384 Perl_sys_intern_clear(pTHX)
13385 {
13386 }
13387
13388 void
13389 Perl_sys_intern_init(pTHX)
13390 {
13391     unsigned int ix = RAND_MAX;
13392     double x;
13393
13394     VMSISH_HUSHED = 0;
13395
13396     MY_POSIX_EXIT = vms_posix_exit;
13397
13398     x = (float)ix;
13399     MY_INV_RAND_MAX = 1./x;
13400 }
13401
13402 void
13403 init_os_extras(void)
13404 {
13405   dTHX;
13406   char* file = __FILE__;
13407   if (decc_disable_to_vms_logname_translation) {
13408     no_translate_barewords = TRUE;
13409   } else {
13410     no_translate_barewords = FALSE;
13411   }
13412
13413   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13414   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13415   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13416   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13417   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13418   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13419   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13420   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13421   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13422   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13423   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13424   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13425   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13426   newXSproto("VMS::Filespec::case_tolerant_process",
13427       case_tolerant_process_fromperl,file,"");
13428
13429   store_pipelocs(aTHX);         /* will redo any earlier attempts */
13430
13431   return;
13432 }
13433
13434 #if __CRTL_VER == 80200000
13435 /* This missed getting in to the DECC SDK for 8.2 */
13436 char *realpath(const char *file_name, char * resolved_name, ...);
13437 #endif
13438
13439 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13440 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13441  * The perl fallback routine to provide realpath() is not as efficient
13442  * on OpenVMS.
13443  */
13444
13445 #ifdef __cplusplus
13446 extern "C" {
13447 #endif
13448
13449 /* Hack, use old stat() as fastest way of getting ino_t and device */
13450 int decc$stat(const char *name, void * statbuf);
13451 #if __CRTL_VER >= 80200000
13452 int decc$lstat(const char *name, void * statbuf);
13453 #else
13454 #define decc$lstat decc$stat
13455 #endif
13456
13457 #ifdef __cplusplus
13458 }
13459 #endif
13460
13461
13462 /* Realpath is fragile.  In 8.3 it does not work if the feature
13463  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13464  * links are implemented in RMS, not the CRTL. It also can fail if the
13465  * user does not have read/execute access to some of the directories.
13466  * So in order for Do What I Mean mode to work, if realpath() fails,
13467  * fall back to looking up the filename by the device name and FID.
13468  */
13469
13470 int vms_fid_to_name(char * outname, int outlen,
13471                     const char * name, int lstat_flag, mode_t * mode)
13472 {
13473 #pragma message save
13474 #pragma message disable MISALGNDSTRCT
13475 #pragma message disable MISALGNDMEM
13476 #pragma member_alignment save
13477 #pragma nomember_alignment
13478     struct statbuf_t {
13479         char       * st_dev;
13480         unsigned short st_ino[3];
13481         unsigned short old_st_mode;
13482         unsigned long  padl[30];  /* plenty of room */
13483     } statbuf;
13484 #pragma message restore
13485 #pragma member_alignment restore
13486
13487     int sts;
13488     struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13489     struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13490     char *fileified;
13491     char *temp_fspec;
13492     char *ret_spec;
13493
13494     /* Need to follow the mostly the same rules as flex_stat_int, or we may get
13495      * unexpected answers
13496      */
13497
13498     fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
13499     if (fileified == NULL)
13500         _ckvmssts_noperl(SS$_INSFMEM);
13501
13502     temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
13503     if (temp_fspec == NULL)
13504         _ckvmssts_noperl(SS$_INSFMEM);
13505
13506     sts = -1;
13507     /* First need to try as a directory */
13508     ret_spec = int_tovmspath(name, temp_fspec, NULL);
13509     if (ret_spec != NULL) {
13510         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
13511         if (ret_spec != NULL) {
13512             if (lstat_flag == 0)
13513                 sts = decc$stat(fileified, &statbuf);
13514             else
13515                 sts = decc$lstat(fileified, &statbuf);
13516         }
13517     }
13518
13519     /* Then as a VMS file spec */
13520     if (sts != 0) {
13521         ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
13522         if (ret_spec != NULL) {
13523             if (lstat_flag == 0) {
13524                 sts = decc$stat(temp_fspec, &statbuf);
13525             } else {
13526                 sts = decc$lstat(temp_fspec, &statbuf);
13527             }
13528         }
13529     }
13530
13531     if (sts) {
13532         /* Next try - allow multiple dots with out EFS CHARSET */
13533         /* The CRTL stat() falls down hard on multi-dot filenames in unix
13534          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
13535          * enable it if it isn't already.
13536          */
13537         if (!decc_efs_charset && (decc_efs_charset_index > 0))
13538             decc$feature_set_value(decc_efs_charset_index, 1, 1);
13539         ret_spec = int_tovmspath(name, temp_fspec, NULL);
13540         if (lstat_flag == 0) {
13541             sts = decc$stat(name, &statbuf);
13542         } else {
13543             sts = decc$lstat(name, &statbuf);
13544         }
13545         if (!decc_efs_charset && (decc_efs_charset_index > 0))
13546             decc$feature_set_value(decc_efs_charset_index, 1, 0);
13547     }
13548
13549
13550     /* and then because the Perl Unix to VMS conversion is not perfect */
13551     /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
13552     /* characters from filenames so we need to try it as-is */
13553     if (sts) {
13554         if (lstat_flag == 0) {
13555             sts = decc$stat(name, &statbuf);
13556         } else {
13557             sts = decc$lstat(name, &statbuf);
13558         }
13559     }
13560
13561     if (sts == 0) {
13562         int vms_sts;
13563
13564         dvidsc.dsc$a_pointer=statbuf.st_dev;
13565         dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13566
13567         specdsc.dsc$a_pointer = outname;
13568         specdsc.dsc$w_length = outlen-1;
13569
13570         vms_sts = lib$fid_to_name
13571             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13572         if ($VMS_STATUS_SUCCESS(vms_sts)) {
13573             outname[specdsc.dsc$w_length] = 0;
13574
13575             /* Return the mode */
13576             if (mode) {
13577                 *mode = statbuf.old_st_mode;
13578             }
13579         }
13580     }
13581     PerlMem_free(temp_fspec);
13582     PerlMem_free(fileified);
13583     return sts;
13584 }
13585
13586
13587
13588 static char *
13589 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13590                    int *utf8_fl)
13591 {
13592     char * rslt = NULL;
13593
13594 #ifdef HAS_SYMLINK
13595     if (decc_posix_compliant_pathnames > 0 ) {
13596         /* realpath currently only works if posix compliant pathnames are
13597          * enabled.  It may start working when they are not, but in that
13598          * case we still want the fallback behavior for backwards compatibility
13599          */
13600         rslt = realpath(filespec, outbuf);
13601     }
13602 #endif
13603
13604     if (rslt == NULL) {
13605         char * vms_spec;
13606         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13607         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13608         mode_t my_mode;
13609
13610         /* Fall back to fid_to_name */
13611
13612         Newx(vms_spec, VMS_MAXRSS + 1, char);
13613
13614         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
13615         if (sts == 0) {
13616
13617
13618             /* Now need to trim the version off */
13619             sts = vms_split_path
13620                   (vms_spec,
13621                    &v_spec,
13622                    &v_len,
13623                    &r_spec,
13624                    &r_len,
13625                    &d_spec,
13626                    &d_len,
13627                    &n_spec,
13628                    &n_len,
13629                    &e_spec,
13630                    &e_len,
13631                    &vs_spec,
13632                    &vs_len);
13633
13634
13635                 if (sts == 0) {
13636                     int haslower = 0;
13637                     const char *cp;
13638
13639                     /* Trim off the version */
13640                     int file_len = v_len + r_len + d_len + n_len + e_len;
13641                     vms_spec[file_len] = 0;
13642
13643                     /* Trim off the .DIR if this is a directory */
13644                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13645                         if (S_ISDIR(my_mode)) {
13646                             e_len = 0;
13647                             e_spec[0] = 0;
13648                         }
13649                     }
13650
13651                     /* Drop NULL extensions on UNIX file specification */
13652                     if ((e_len == 1) && decc_readdir_dropdotnotype) {
13653                         e_len = 0;
13654                         e_spec[0] = '\0';
13655                     }
13656
13657                     /* The result is expected to be in UNIX format */
13658                     rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
13659
13660                     /* Downcase if input had any lower case letters and
13661                      * case preservation is not in effect.
13662                      */
13663                     if (!decc_efs_case_preserve) {
13664                         for (cp = filespec; *cp; cp++)
13665                             if (islower(*cp)) { haslower = 1; break; }
13666
13667                         if (haslower) __mystrtolower(rslt);
13668                     }
13669                 }
13670         } else {
13671
13672             /* Now for some hacks to deal with backwards and forward */
13673             /* compatibility */
13674             if (!decc_efs_charset) {
13675
13676                 /* 1. ODS-2 mode wants to do a syntax only translation */
13677                 rslt = int_rmsexpand(filespec, outbuf,
13678                                     NULL, 0, NULL, utf8_fl);
13679
13680             } else {
13681                 if (decc_filename_unix_report) {
13682                     char * dir_name;
13683                     char * vms_dir_name;
13684                     char * file_name;
13685
13686                     /* 2. ODS-5 / UNIX report mode should return a failure */
13687                     /*    if the parent directory also does not exist */
13688                     /*    Otherwise, get the real path for the parent */
13689                     /*    and add the child to it. */
13690
13691                     /* basename / dirname only available for VMS 7.0+ */
13692                     /* So we may need to implement them as common routines */
13693
13694                     Newx(dir_name, VMS_MAXRSS + 1, char);
13695                     Newx(vms_dir_name, VMS_MAXRSS + 1, char);
13696                     dir_name[0] = '\0';
13697                     file_name = NULL;
13698
13699                     /* First try a VMS parse */
13700                     sts = vms_split_path
13701                           (filespec,
13702                            &v_spec,
13703                            &v_len,
13704                            &r_spec,
13705                            &r_len,
13706                            &d_spec,
13707                            &d_len,
13708                            &n_spec,
13709                            &n_len,
13710                            &e_spec,
13711                            &e_len,
13712                            &vs_spec,
13713                            &vs_len);
13714
13715                     if (sts == 0) {
13716                         /* This is VMS */
13717
13718                         int dir_len = v_len + r_len + d_len + n_len;
13719                         if (dir_len > 0) {
13720                            memcpy(dir_name, filespec, dir_len);
13721                            dir_name[dir_len] = '\0';
13722                            file_name = (char *)&filespec[dir_len + 1];
13723                         }
13724                     } else {
13725                         /* This must be UNIX */
13726                         char * tchar;
13727
13728                         tchar = strrchr(filespec, '/');
13729
13730                         if (tchar != NULL) {
13731                             int dir_len = tchar - filespec;
13732                             memcpy(dir_name, filespec, dir_len);
13733                             dir_name[dir_len] = '\0';
13734                             file_name = (char *) &filespec[dir_len + 1];
13735                         }
13736                     }
13737
13738                     /* Dir name is defaulted */
13739                     if (dir_name[0] == 0) {
13740                         dir_name[0] = '.';
13741                         dir_name[1] = '\0';
13742                     }
13743
13744                     /* Need realpath for the directory */
13745                     sts = vms_fid_to_name(vms_dir_name,
13746                                           VMS_MAXRSS + 1,
13747                                           dir_name, 0, NULL);
13748
13749                     if (sts == 0) {
13750                         /* Now need to pathify it. */
13751                         char *tdir = int_pathify_dirspec(vms_dir_name,
13752                                                          outbuf);
13753
13754                         /* And now add the original filespec to it */
13755                         if (file_name != NULL) {
13756                             my_strlcat(outbuf, file_name, VMS_MAXRSS);
13757                         }
13758                         return outbuf;
13759                     }
13760                     Safefree(vms_dir_name);
13761                     Safefree(dir_name);
13762                 }
13763             }
13764         }
13765         Safefree(vms_spec);
13766     }
13767     return rslt;
13768 }
13769
13770 static char *
13771 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13772                    int *utf8_fl)
13773 {
13774     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13775     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13776
13777     /* Fall back to fid_to_name */
13778
13779     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
13780     if (sts != 0) {
13781         return NULL;
13782     }
13783     else {
13784
13785
13786         /* Now need to trim the version off */
13787         sts = vms_split_path
13788                   (outbuf,
13789                    &v_spec,
13790                    &v_len,
13791                    &r_spec,
13792                    &r_len,
13793                    &d_spec,
13794                    &d_len,
13795                    &n_spec,
13796                    &n_len,
13797                    &e_spec,
13798                    &e_len,
13799                    &vs_spec,
13800                    &vs_len);
13801
13802
13803         if (sts == 0) {
13804             int haslower = 0;
13805             const char *cp;
13806
13807             /* Trim off the version */
13808             int file_len = v_len + r_len + d_len + n_len + e_len;
13809             outbuf[file_len] = 0;
13810
13811             /* Downcase if input had any lower case letters and
13812              * case preservation is not in effect.
13813              */
13814             if (!decc_efs_case_preserve) {
13815                 for (cp = filespec; *cp; cp++)
13816                     if (islower(*cp)) { haslower = 1; break; }
13817
13818                 if (haslower) __mystrtolower(outbuf);
13819             }
13820         }
13821     }
13822     return outbuf;
13823 }
13824
13825
13826 /*}}}*/
13827 /* External entry points */
13828 char *
13829 Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13830 {
13831     return do_vms_realpath(filespec, outbuf, utf8_fl);
13832 }
13833
13834 char *
13835 Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13836 {
13837     return do_vms_realname(filespec, outbuf, utf8_fl);
13838 }
13839
13840 /* case_tolerant */
13841
13842 /*{{{int do_vms_case_tolerant(void)*/
13843 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13844  * controlled by a process setting.
13845  */
13846 int
13847 do_vms_case_tolerant(void)
13848 {
13849     return vms_process_case_tolerant;
13850 }
13851 /*}}}*/
13852 /* External entry points */
13853 int
13854 Perl_vms_case_tolerant(void)
13855 {
13856     return do_vms_case_tolerant();
13857 }
13858
13859  /* Start of DECC RTL Feature handling */
13860
13861 static int
13862 set_feature_default(const char *name, int value)
13863 {
13864     int status;
13865     int index;
13866     char val_str[10];
13867
13868     /* If the feature has been explicitly disabled in the environment,
13869      * then don't enable it here.
13870      */
13871     if (value > 0) {
13872         status = simple_trnlnm(name, val_str, sizeof(val_str));
13873         if (status) {
13874             val_str[0] = _toupper(val_str[0]);
13875             if (val_str[0] == 'D' || val_str[0] == '0' || val_str[0] == 'F')
13876                 return 0;
13877         }
13878     }
13879
13880     index = decc$feature_get_index(name);
13881
13882     status = decc$feature_set_value(index, 1, value);
13883     if (index == -1 || (status == -1)) {
13884       return -1;
13885     }
13886
13887     status = decc$feature_get_value(index, 1);
13888     if (status != value) {
13889       return -1;
13890     }
13891
13892     /* Various things may check for an environment setting
13893      * rather than the feature directly, so set that too.
13894      */
13895     vmssetuserlnm(name, value ? "ENABLE" : "DISABLE");
13896
13897     return 0;
13898 }
13899
13900
13901 /* C RTL Feature settings */
13902
13903 #if defined(__DECC) || defined(__DECCXX)
13904
13905 #ifdef __cplusplus
13906 extern "C" {
13907 #endif
13908
13909 extern void
13910 vmsperl_set_features(void)
13911 {
13912     int status;
13913     int s;
13914     char val_str[10];
13915 #if defined(JPI$_CASE_LOOKUP_PERM)
13916     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13917     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13918     unsigned long case_perm;
13919     unsigned long case_image;
13920 #endif
13921
13922     /* Allow an exception to bring Perl into the VMS debugger */
13923     vms_debug_on_exception = 0;
13924     status = simple_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
13925     if (status) {
13926        val_str[0] = _toupper(val_str[0]);
13927        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13928          vms_debug_on_exception = 1;
13929        else
13930          vms_debug_on_exception = 0;
13931     }
13932
13933     /* Debug unix/vms file translation routines */
13934     vms_debug_fileify = 0;
13935     status = simple_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
13936     if (status) {
13937         val_str[0] = _toupper(val_str[0]);
13938         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13939             vms_debug_fileify = 1;
13940         else
13941             vms_debug_fileify = 0;
13942     }
13943
13944
13945     /* Historically PERL has been doing vmsify / stat differently than */
13946     /* the CRTL.  In particular, under some conditions the CRTL will   */
13947     /* remove some illegal characters like spaces from filenames       */
13948     /* resulting in some differences.  The stat()/lstat() wrapper has  */
13949     /* been reporting such file names as invalid and fails to stat them */
13950     /* fixing this bug so that stat()/lstat() accept these like the     */
13951     /* CRTL does will result in several tests failing.                  */
13952     /* This should really be fixed, but for now, set up a feature to    */
13953     /* enable it so that the impact can be studied.                     */
13954     vms_bug_stat_filename = 0;
13955     status = simple_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
13956     if (status) {
13957         val_str[0] = _toupper(val_str[0]);
13958         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13959             vms_bug_stat_filename = 1;
13960         else
13961             vms_bug_stat_filename = 0;
13962     }
13963
13964
13965     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
13966     vms_vtf7_filenames = 0;
13967     status = simple_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
13968     if (status) {
13969        val_str[0] = _toupper(val_str[0]);
13970        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13971          vms_vtf7_filenames = 1;
13972        else
13973          vms_vtf7_filenames = 0;
13974     }
13975
13976     /* unlink all versions on unlink() or rename() */
13977     vms_unlink_all_versions = 0;
13978     status = simple_trnlnm("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13979     if (status) {
13980        val_str[0] = _toupper(val_str[0]);
13981        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13982          vms_unlink_all_versions = 1;
13983        else
13984          vms_unlink_all_versions = 0;
13985     }
13986
13987     /* Detect running under GNV Bash or other UNIX like shell */
13988     gnv_unix_shell = 0;
13989     status = simple_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
13990     if (status) {
13991          gnv_unix_shell = 1;
13992          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
13993          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
13994          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
13995          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
13996          vms_unlink_all_versions = 1;
13997          vms_posix_exit = 1;
13998          /* Reverse default ordering of PERL_ENV_TABLES. */
13999          defenv[0] = &crtlenvdsc;
14000          defenv[1] = &fildevdsc;
14001     }
14002     /* Some reasonable defaults that are not CRTL defaults */
14003     set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
14004     set_feature_default("DECC$ARGV_PARSE_STYLE", 1);     /* Requires extended parse. */
14005     set_feature_default("DECC$EFS_CHARSET", 1);
14006
14007     /* hacks to see if known bugs are still present for testing */
14008
14009     /* PCP mode requires creating /dev/null special device file */
14010     decc_bug_devnull = 0;
14011     status = simple_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14012     if (status) {
14013        val_str[0] = _toupper(val_str[0]);
14014        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14015           decc_bug_devnull = 1;
14016        else
14017           decc_bug_devnull = 0;
14018     }
14019
14020     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14021     if (s >= 0) {
14022         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14023         if (decc_disable_to_vms_logname_translation < 0)
14024             decc_disable_to_vms_logname_translation = 0;
14025     }
14026
14027     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14028     if (s >= 0) {
14029         decc_efs_case_preserve = decc$feature_get_value(s, 1);
14030         if (decc_efs_case_preserve < 0)
14031             decc_efs_case_preserve = 0;
14032     }
14033
14034     s = decc$feature_get_index("DECC$EFS_CHARSET");
14035     decc_efs_charset_index = s;
14036     if (s >= 0) {
14037         decc_efs_charset = decc$feature_get_value(s, 1);
14038         if (decc_efs_charset < 0)
14039             decc_efs_charset = 0;
14040     }
14041
14042     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14043     if (s >= 0) {
14044         decc_filename_unix_report = decc$feature_get_value(s, 1);
14045         if (decc_filename_unix_report > 0) {
14046             decc_filename_unix_report = 1;
14047             vms_posix_exit = 1;
14048         }
14049         else
14050             decc_filename_unix_report = 0;
14051     }
14052
14053     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14054     if (s >= 0) {
14055         decc_filename_unix_only = decc$feature_get_value(s, 1);
14056         if (decc_filename_unix_only > 0) {
14057             decc_filename_unix_only = 1;
14058         }
14059         else {
14060             decc_filename_unix_only = 0;
14061         }
14062     }
14063
14064     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14065     if (s >= 0) {
14066         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14067         if (decc_filename_unix_no_version < 0)
14068             decc_filename_unix_no_version = 0;
14069     }
14070
14071     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14072     if (s >= 0) {
14073         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14074         if (decc_readdir_dropdotnotype < 0)
14075             decc_readdir_dropdotnotype = 0;
14076     }
14077
14078 #if __CRTL_VER >= 80200000
14079     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14080     if (s >= 0) {
14081         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14082         if (decc_posix_compliant_pathnames < 0)
14083             decc_posix_compliant_pathnames = 0;
14084         if (decc_posix_compliant_pathnames > 4)
14085             decc_posix_compliant_pathnames = 0;
14086     }
14087
14088 #endif
14089
14090 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND)
14091
14092      /* Report true case tolerance */
14093     /*----------------------------*/
14094     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14095     if (!$VMS_STATUS_SUCCESS(status))
14096         case_perm = PPROP$K_CASE_BLIND;
14097     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14098     if (!$VMS_STATUS_SUCCESS(status))
14099         case_image = PPROP$K_CASE_BLIND;
14100     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14101         (case_image == PPROP$K_CASE_SENSITIVE))
14102         vms_process_case_tolerant = 0;
14103
14104 #endif
14105
14106     /* USE POSIX/DCL Exit codes - Recommended, but needs to default to  */
14107     /* for strict backward compatibility */
14108     status = simple_trnlnm("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14109     if (status) {
14110        val_str[0] = _toupper(val_str[0]);
14111        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14112          vms_posix_exit = 1;
14113        else
14114          vms_posix_exit = 0;
14115     }
14116 }
14117
14118 /* Use 32-bit pointers because that's what the image activator
14119  * assumes for the LIB$INITIALZE psect.
14120  */
14121 #if __INITIAL_POINTER_SIZE
14122 #pragma pointer_size save
14123 #pragma pointer_size 32
14124 #endif
14125
14126 /* Create a reference to the LIB$INITIALIZE function. */
14127 extern void LIB$INITIALIZE(void);
14128 extern void (*vmsperl_unused_global_1)(void) = LIB$INITIALIZE;
14129
14130 /* Create an array of pointers to the init functions in the special
14131  * LIB$INITIALIZE section. In our case, the array only has one entry.
14132  */
14133 #pragma extern_model save
14134 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic,gbl,nowrt,noshr,long
14135 extern void (* const vmsperl_unused_global_2[])() =
14136 {
14137    vmsperl_set_features,
14138 };
14139 #pragma extern_model restore
14140
14141 #if __INITIAL_POINTER_SIZE
14142 #pragma pointer_size restore
14143 #endif
14144
14145 #ifdef __cplusplus
14146 }
14147 #endif
14148
14149 #endif /* defined(__DECC) || defined(__DECCXX) */
14150 /*  End of vms.c */