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     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 868     int midx;
 869     unsigned char acmode;
 870     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 871                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 872     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 873                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 874                                  {0, 0, 0, 0}};
 875     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 876 #if defined(PERL_IMPLICIT_CONTEXT)
 877     pTHX = NULL;
 878     if (PL_curinterp) {
 879       aTHX = PERL_GET_INTERP;
 880     } else {
 881       aTHX = NULL;
 882     }
 883 #endif
 884
 885     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 886       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 887     }
 888     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 889       *cp2 = _toupper(*cp1);
 890       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 891         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 892         return 0;
 893       }
 894     }
 895     lnmdsc.dsc$w_length = cp1 - lnm;
 896     lnmdsc.dsc$a_pointer = uplnm;
 897     uplnm[lnmdsc.dsc$w_length] = '\0';
 898     secure = flags & PERL__TRNENV_SECURE;
 899     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 900     if (!tabvec || !*tabvec) tabvec = env_tables;
 901
 902     for (curtab = 0; tabvec[curtab]; curtab++) {
 903       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 904         if (!ivenv && !secure) {
 905           char *eq;
 906           int i;
 907           if (!environ) {
 908             ivenv = 1;
 909 #if defined(PERL_IMPLICIT_CONTEXT)
 910             if (aTHX == NULL) {
 911                 fprintf(stderr,
 912                     "Can't read CRTL environ\n");
 913             } else
 914 #endif
 915                 Perl_warn(aTHX_ "Can't read CRTL environ\n");
 916             continue;
 917           }
 918           retsts = SS$_NOLOGNAM;
 919           for (i = 0; environ[i]; i++) {
 920             if ((eq = strchr(environ[i],'=')) &&
 921                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 922                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 923               eq++;
 924               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 925               if (!eqvlen) continue;
 926               retsts = SS$_NORMAL;
 927               break;
 928             }
 929           }
 930           if (retsts != SS$_NOLOGNAM) break;
 931         }
 932       }
 933       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 934                !str$case_blind_compare(&tmpdsc,&clisym)) {
 935         if (!ivsym && !secure) {
 936           unsigned short int deflen = LNM$C_NAMLENGTH;
 937           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 938           /* dynamic dsc to accommodate possible long value */
 939           _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
 940           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 941           if (retsts & 1) {
 942             if (eqvlen > MAX_DCL_SYMBOL) {
 943               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 944               eqvlen = MAX_DCL_SYMBOL;
 945               /* Special hack--we might be called before the interpreter's */
 946               /* fully initialized, in which case either thr or PL_curcop */
 947               /* might be bogus. We have to check, since ckWARN needs them */
 948               /* both to be valid if running threaded */
 949 #if defined(PERL_IMPLICIT_CONTEXT)
 950               if (aTHX == NULL) {
 951                   fprintf(stderr,
 952                      "Value of CLI symbol \"%s\" too long",lnm);
 953               } else
 954 #endif
 955                 if (ckWARN(WARN_MISC)) {
 956                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 957                 }
 958             }
 959             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 960           }
 961           _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
 962           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 963           if (retsts == LIB$_NOSUCHSYM) continue;
 964           break;
 965         }
 966       }
 967       else if (!ivlnm) {
 968         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
 969           midx = my_maxidx(lnm);
 970           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
 971             lnmlst[1].bufadr = cp2;
 972             eqvlen = 0;
 973             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 974             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
 975             if (retsts == SS$_NOLOGNAM) break;
 976             eqvlen = S_remove_ppf_prefix(uplnm, eqv, eqvlen);
 977             cp2 += eqvlen;
 978             *cp2 = '\0';
 979           }
 980           if ((retsts == SS$_IVLOGNAM) ||
 981               (retsts == SS$_NOLOGNAM)) { continue; }
 982           eqvlen = strlen(eqv);
 983         }
 984         else {
 985           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 986           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 987           if (retsts == SS$_NOLOGNAM) continue;
 988           eqvlen = S_remove_ppf_prefix(uplnm, eqv, eqvlen);
 989           eqv[eqvlen] = '\0';
 990         }
 991         break;
 992       }
 993     }
 994     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
 995     else if (retsts == LIB$_NOSUCHSYM ||
 996              retsts == SS$_NOLOGNAM) {
 997      /* Unsuccessful lookup is normal -- no need to set errno */
 998      return 0;
 999     }
1000     else if (retsts == LIB$_INVSYMNAM ||
1001              retsts == SS$_IVLOGNAM   ||
1002              retsts == SS$_IVLOGTAB) {
1003       set_errno(EINVAL);  set_vaxc_errno(retsts);
1004     }
1005     else _ckvmssts_noperl(retsts);
1006     return 0;
1007 }  /* end of vmstrnenv */
1008 /*}}}*/
1009
1010 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1011 /* Define as a function so we can access statics. */
1012 int
1013 Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1014 {
1015     int flags = 0;
1016
1017 #if defined(PERL_IMPLICIT_CONTEXT)
1018     if (aTHX != NULL)
1019 #endif
1020 #ifdef SECURE_INTERNAL_GETENV
1021         flags = (PL_curinterp ? TAINTING_get : will_taint) ?
1022                  PERL__TRNENV_SECURE : 0;
1023 #endif
1024
1025     return vmstrnenv(lnm, eqv, idx, fildev, flags);
1026 }
1027 /*}}}*/
1028
1029 /* my_getenv
1030  * Note: Uses Perl temp to store result so char * can be returned to
1031  * caller; this pointer will be invalidated at next Perl statement
1032  * transition.
1033  * We define this as a function rather than a macro in terms of my_getenv_len()
1034  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1035  * allocate SVs).
1036  */
1037 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1038 char *
1039 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1040 {
1041     const char *cp1;
1042     static char *__my_getenv_eqv = NULL;
1043     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1044     unsigned long int idx = 0;
1045     int success, secure;
1046     int midx, flags;
1047     SV *tmpsv;
1048
1049     midx = my_maxidx(lnm) + 1;
1050
1051     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1052       /* Set up a temporary buffer for the return value; Perl will
1053        * clean it up at the next statement transition */
1054       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1055       if (!tmpsv) return NULL;
1056       eqv = SvPVX(tmpsv);
1057     }
1058     else {
1059       /* Assume no interpreter ==> single thread */
1060       if (__my_getenv_eqv != NULL) {
1061         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1062       }
1063       else {
1064         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1065       }
1066       eqv = __my_getenv_eqv;
1067     }
1068
1069     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1070     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1071       int len;
1072       getcwd(eqv,LNM$C_NAMLENGTH);
1073
1074       len = strlen(eqv);
1075
1076       /* Get rid of "000000/ in rooted filespecs */
1077       if (len > 7) {
1078         char * zeros;
1079         zeros = strstr(eqv, "/000000/");
1080         if (zeros != NULL) {
1081           int mlen;
1082           mlen = len - (zeros - eqv) - 7;
1083           memmove(zeros, &zeros[7], mlen);
1084           len = len - 7;
1085           eqv[len] = '\0';
1086         }
1087       }
1088       return eqv;
1089     }
1090     else {
1091       /* Impose security constraints only if tainting */
1092       if (sys) {
1093         /* Impose security constraints only if tainting */
1094         secure = PL_curinterp ? TAINTING_get : will_taint;
1095       }
1096       else {
1097         secure = 0;
1098       }
1099
1100       flags =
1101 #ifdef SECURE_INTERNAL_GETENV
1102               secure ? PERL__TRNENV_SECURE : 0
1103 #else
1104               0
1105 #endif
1106       ;
1107
1108       /* For the getenv interface we combine all the equivalence names
1109        * of a search list logical into one value to acquire a maximum
1110        * value length of 255*128 (assuming %ENV is using logicals).
1111        */
1112       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1113
1114       /* If the name contains a semicolon-delimited index, parse it
1115        * off and make sure we only retrieve the equivalence name for
1116        * that index.  */
1117       if ((cp2 = strchr(lnm,';')) != NULL) {
1118         my_strlcpy(uplnm, lnm, cp2 - lnm + 1);
1119         idx = strtoul(cp2+1,NULL,0);
1120         lnm = uplnm;
1121         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1122       }
1123
1124       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1125
1126       return success ? eqv : NULL;
1127     }
1128
1129 }  /* end of my_getenv() */
1130 /*}}}*/
1131
1132
1133 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1134 char *
1135 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1136 {
1137     const char *cp1;
1138     char *buf, *cp2;
1139     unsigned long idx = 0;
1140     int midx, flags;
1141     static char *__my_getenv_len_eqv = NULL;
1142     int secure;
1143     SV *tmpsv;
1144
1145     midx = my_maxidx(lnm) + 1;
1146
1147     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1148       /* Set up a temporary buffer for the return value; Perl will
1149        * clean it up at the next statement transition */
1150       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1151       if (!tmpsv) return NULL;
1152       buf = SvPVX(tmpsv);
1153     }
1154     else {
1155       /* Assume no interpreter ==> single thread */
1156       if (__my_getenv_len_eqv != NULL) {
1157         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1158       }
1159       else {
1160         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1161       }
1162       buf = __my_getenv_len_eqv;
1163     }
1164
1165     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1166     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1167     char * zeros;
1168
1169       getcwd(buf,LNM$C_NAMLENGTH);
1170       *len = strlen(buf);
1171
1172       /* Get rid of "000000/ in rooted filespecs */
1173       if (*len > 7) {
1174       zeros = strstr(buf, "/000000/");
1175       if (zeros != NULL) {
1176         int mlen;
1177         mlen = *len - (zeros - buf) - 7;
1178         memmove(zeros, &zeros[7], mlen);
1179         *len = *len - 7;
1180         buf[*len] = '\0';
1181         }
1182       }
1183       return buf;
1184     }
1185     else {
1186       if (sys) {
1187         /* Impose security constraints only if tainting */
1188         secure = PL_curinterp ? TAINTING_get : will_taint;
1189       }
1190       else {
1191         secure = 0;
1192       }
1193
1194       flags =
1195 #ifdef SECURE_INTERNAL_GETENV
1196               secure ? PERL__TRNENV_SECURE : 0
1197 #else
1198               0
1199 #endif
1200       ;
1201
1202       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1203
1204       if ((cp2 = strchr(lnm,';')) != NULL) {
1205         my_strlcpy(buf, lnm, cp2 - lnm + 1);
1206         idx = strtoul(cp2+1,NULL,0);
1207         lnm = buf;
1208         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1209       }
1210
1211       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1212
1213       /* Get rid of "000000/ in rooted filespecs */
1214       if (*len > 7) {
1215         char * zeros;
1216         zeros = strstr(buf, "/000000/");
1217         if (zeros != NULL) {
1218           int mlen;
1219           mlen = *len - (zeros - buf) - 7;
1220           memmove(zeros, &zeros[7], mlen);
1221           *len = *len - 7;
1222           buf[*len] = '\0';
1223         }
1224       }
1225
1226       return *len ? buf : NULL;
1227     }
1228
1229 }  /* end of my_getenv_len() */
1230 /*}}}*/
1231
1232 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
1233
1234 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1235
1236 /*{{{ void prime_env_iter() */
1237 void
1238 prime_env_iter(void)
1239 /* Fill the %ENV associative array with all logical names we can
1240  * find, in preparation for iterating over it.
1241  */
1242 {
1243   static int primed = 0;
1244   HV *seenhv = NULL, *envhv;
1245   SV *sv = NULL;
1246   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1247   unsigned short int chan;
1248 #ifndef CLI$M_TRUSTED
1249 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1250 #endif
1251   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1252   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0;
1253   long int i;
1254   bool have_sym = FALSE, have_lnm = FALSE;
1255   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1256   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1257   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1258   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1259   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1260 #if defined(PERL_IMPLICIT_CONTEXT)
1261   pTHX;
1262 #endif
1263 #if defined(USE_ITHREADS)
1264   static perl_mutex primenv_mutex;
1265   MUTEX_INIT(&primenv_mutex);
1266 #endif
1267
1268 #if defined(PERL_IMPLICIT_CONTEXT)
1269     /* We jump through these hoops because we can be called at */
1270     /* platform-specific initialization time, which is before anything is */
1271     /* set up--we can't even do a plain dTHX since that relies on the */
1272     /* interpreter structure to be initialized */
1273     if (PL_curinterp) {
1274       aTHX = PERL_GET_INTERP;
1275     } else {
1276       /* we never get here because the NULL pointer will cause the */
1277       /* several of the routines called by this routine to access violate */
1278
1279       /* This routine is only called by hv.c/hv_iterinit which has a */
1280       /* context, so the real fix may be to pass it through instead of */
1281       /* the hoops above */
1282       aTHX = NULL;
1283     }
1284 #endif
1285
1286   if (primed || !PL_envgv) return;
1287   MUTEX_LOCK(&primenv_mutex);
1288   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1289   envhv = GvHVn(PL_envgv);
1290   /* Perform a dummy fetch as an lval to insure that the hash table is
1291    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1292   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1293
1294   for (i = 0; env_tables[i]; i++) {
1295      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1296          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1297      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1298   }
1299   if (have_sym || have_lnm) {
1300     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1301     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1302     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1303     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1304   }
1305
1306   for (i--; i >= 0; i--) {
1307     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1308       char *start;
1309       int j;
1310       for (j = 0; environ[j]; j++) {
1311         if (!(start = strchr(environ[j],'='))) {
1312           if (ckWARN(WARN_INTERNAL))
1313             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1314         }
1315         else {
1316           start++;
1317           sv = newSVpv(start,0);
1318           SvTAINTED_on(sv);
1319           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1320         }
1321       }
1322       continue;
1323     }
1324     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1325              !str$case_blind_compare(&tmpdsc,&clisym)) {
1326       my_strlcpy(cmd, "Show Symbol/Global *", sizeof(cmd));
1327       cmddsc.dsc$w_length = 20;
1328       if (env_tables[i]->dsc$w_length == 12 &&
1329           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1330           !str$case_blind_compare(&tmpdsc,&local)) my_strlcpy(cmd+12, "Local  *", sizeof(cmd)-12);
1331       flags = defflags | CLI$M_NOLOGNAM;
1332     }
1333     else {
1334       my_strlcpy(cmd, "Show Logical *", sizeof(cmd));
1335       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1336         my_strlcat(cmd," /Table=", sizeof(cmd));
1337         cmddsc.dsc$w_length = my_strlcat(cmd, env_tables[i]->dsc$a_pointer, sizeof(cmd));
1338       }
1339       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1340       flags = defflags | CLI$M_NOCLISYM;
1341     }
1342
1343     /* Create a new subprocess to execute each command, to exclude the
1344      * remote possibility that someone could subvert a mbx or file used
1345      * to write multiple commands to a single subprocess.
1346      */
1347     do {
1348       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1349                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1350       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1351       defflags &= ~CLI$M_TRUSTED;
1352     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1353     _ckvmssts(retsts);
1354     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1355     if (seenhv) SvREFCNT_dec(seenhv);
1356     seenhv = newHV();
1357     while (1) {
1358       char *cp1, *cp2, *key;
1359       unsigned long int sts, iosb[2], retlen, keylen;
1360       U32 hash;
1361
1362       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1363       if (sts & 1) sts = iosb[0] & 0xffff;
1364       if (sts == SS$_ENDOFFILE) {
1365         int wakect = 0;
1366         while (substs == 0) { sys$hiber(); wakect++;}
1367         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1368         _ckvmssts(substs);
1369         break;
1370       }
1371       _ckvmssts(sts);
1372       retlen = iosb[0] >> 16;
1373       if (!retlen) continue;  /* blank line */
1374       buf[retlen] = '\0';
1375       if (iosb[1] != subpid) {
1376         if (iosb[1]) {
1377           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1378         }
1379         continue;
1380       }
1381       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1382         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1383
1384       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1385       if (*cp1 == '(' || /* Logical name table name */
1386           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1387       if (*cp1 == '"') cp1++;
1388       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1389       key = cp1;  keylen = cp2 - cp1;
1390       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1391       while (*cp2 && *cp2 != '=') cp2++;
1392       while (*cp2 && *cp2 == '=') cp2++;
1393       while (*cp2 && *cp2 == ' ') cp2++;
1394       if (*cp2 == '"') {  /* String translation; may embed "" */
1395         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1396         cp2++;  cp1--; /* Skip "" surrounding translation */
1397       }
1398       else {  /* Numeric translation */
1399         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1400         cp1--;  /* stop on last non-space char */
1401       }
1402       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1403         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1404         continue;
1405       }
1406       PERL_HASH(hash,key,keylen);
1407
1408       if (cp1 == cp2 && *cp2 == '.') {
1409         /* A single dot usually means an unprintable character, such as a null
1410          * to indicate a zero-length value.  Get the actual value to make sure.
1411          */
1412         char lnm[LNM$C_NAMLENGTH+1];
1413         char eqv[MAX_DCL_SYMBOL+1];
1414         int trnlen;
1415         strncpy(lnm, key, keylen);
1416         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1417         sv = newSVpvn(eqv, strlen(eqv));
1418       }
1419       else {
1420         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1421       }
1422
1423       SvTAINTED_on(sv);
1424       hv_store(envhv,key,keylen,sv,hash);
1425       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1426     }
1427     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1428       /* get the PPFs for this process, not the subprocess */
1429       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1430       char eqv[LNM$C_NAMLENGTH+1];
1431       int trnlen, i;
1432       for (i = 0; ppfs[i]; i++) {
1433         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1434         sv = newSVpv(eqv,trnlen);
1435         SvTAINTED_on(sv);
1436         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1437       }
1438     }
1439   }
1440   primed = 1;
1441   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1442   if (buf) Safefree(buf);
1443   if (seenhv) SvREFCNT_dec(seenhv);
1444   MUTEX_UNLOCK(&primenv_mutex);
1445   return;
1446
1447 }  /* end of prime_env_iter */
1448 /*}}}*/
1449
1450
1451 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1452 /* Define or delete an element in the same "environment" as
1453  * vmstrnenv().  If an element is to be deleted, it's removed from
1454  * the first place it's found.  If it's to be set, it's set in the
1455  * place designated by the first element of the table vector.
1456  * Like setenv() returns 0 for success, non-zero on error.
1457  */
1458 int
1459 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1460 {
1461     const char *cp1;
1462     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1463     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1464     int nseg = 0, j;
1465     unsigned long int retsts, usermode = PSL$C_USER;
1466     struct itmlst_3 *ile, *ilist;
1467     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1468                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1469                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1470     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1471     $DESCRIPTOR(local,"_LOCAL");
1472
1473     if (!lnm) {
1474         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1475         return SS$_IVLOGNAM;
1476     }
1477
1478     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1479       *cp2 = _toupper(*cp1);
1480       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1481         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1482         return SS$_IVLOGNAM;
1483       }
1484     }
1485     lnmdsc.dsc$w_length = cp1 - lnm;
1486     if (!tabvec || !*tabvec) tabvec = env_tables;
1487
1488     if (!eqv) {  /* we're deleting n element */
1489       for (curtab = 0; tabvec[curtab]; curtab++) {
1490         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1491         int i;
1492           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1493             if ((cp1 = strchr(environ[i],'=')) &&
1494                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1495                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1496 #ifdef HAS_SETENV
1497               return setenv(lnm,"",1) ? vaxc$errno : 0;
1498             }
1499           }
1500           ivenv = 1; retsts = SS$_NOLOGNAM;
1501 #else
1502               if (ckWARN(WARN_INTERNAL))
1503                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1504               ivenv = 1; retsts = SS$_NOSUCHPGM;
1505               break;
1506             }
1507           }
1508 #endif
1509         }
1510         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1511                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1512           unsigned int symtype;
1513           if (tabvec[curtab]->dsc$w_length == 12 &&
1514               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1515               !str$case_blind_compare(&tmpdsc,&local))
1516             symtype = LIB$K_CLI_LOCAL_SYM;
1517           else symtype = LIB$K_CLI_GLOBAL_SYM;
1518           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1519           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1520           if (retsts == LIB$_NOSUCHSYM) continue;
1521           break;
1522         }
1523         else if (!ivlnm) {
1524           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1525           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1526           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1527           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1528           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1529         }
1530       }
1531     }
1532     else {  /* we're defining a value */
1533       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1534 #ifdef HAS_SETENV
1535         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1536 #else
1537         if (ckWARN(WARN_INTERNAL))
1538           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1539         retsts = SS$_NOSUCHPGM;
1540 #endif
1541       }
1542       else {
1543         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1544         eqvdsc.dsc$w_length  = strlen(eqv);
1545         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1546             !str$case_blind_compare(&tmpdsc,&clisym)) {
1547           unsigned int symtype;
1548           if (tabvec[0]->dsc$w_length == 12 &&
1549               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1550                !str$case_blind_compare(&tmpdsc,&local))
1551             symtype = LIB$K_CLI_LOCAL_SYM;
1552           else symtype = LIB$K_CLI_GLOBAL_SYM;
1553           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1554         }
1555         else {
1556           if (!*eqv) eqvdsc.dsc$w_length = 1;
1557           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1558
1559             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1560             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1561               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1562                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1563               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1564               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1565             }
1566
1567             Newx(ilist,nseg+1,struct itmlst_3);
1568             ile = ilist;
1569             if (!ile) {
1570               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1571               return SS$_INSFMEM;
1572             }
1573             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1574
1575             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1576               ile->itmcode = LNM$_STRING;
1577               ile->bufadr = c;
1578               if ((j+1) == nseg) {
1579                 ile->buflen = strlen(c);
1580                 /* in case we are truncating one that's too long */
1581                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1582               }
1583               else {
1584                 ile->buflen = LNM$C_NAMLENGTH;
1585               }
1586             }
1587
1588             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1589             Safefree (ilist);
1590           }
1591           else {
1592             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1593           }
1594         }
1595       }
1596     }
1597     if (!(retsts & 1)) {
1598       switch (retsts) {
1599         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1600         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1601           set_errno(EVMSERR); break;
1602         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1603         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1604           set_errno(EINVAL); break;
1605         case SS$_NOPRIV:
1606           set_errno(EACCES); break;
1607         default:
1608           _ckvmssts(retsts);
1609           set_errno(EVMSERR);
1610        }
1611        set_vaxc_errno(retsts);
1612        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1613     }
1614     else {
1615       /* We reset error values on success because Perl does an hv_fetch()
1616        * before each hv_store(), and if the thing we're setting didn't
1617        * previously exist, we've got a leftover error message.  (Of course,
1618        * this fails in the face of
1619        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1620        * in that the error reported in $! isn't spurious,
1621        * but it's right more often than not.)
1622        */
1623       set_errno(0); set_vaxc_errno(retsts);
1624       return 0;
1625     }
1626
1627 }  /* end of vmssetenv() */
1628 /*}}}*/
1629
1630 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1631 /* This has to be a function since there's a prototype for it in proto.h */
1632 void
1633 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1634 {
1635     if (lnm && *lnm) {
1636       int len = strlen(lnm);
1637       if  (len == 7) {
1638         char uplnm[8];
1639         int i;
1640         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1641         if (!strcmp(uplnm,"DEFAULT")) {
1642           if (eqv && *eqv) my_chdir(eqv);
1643           return;
1644         }
1645     }
1646   }
1647   (void) vmssetenv(lnm,eqv,NULL);
1648 }
1649 /*}}}*/
1650
1651 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1652 /*  vmssetuserlnm
1653  *  sets a user-mode logical in the process logical name table
1654  *  used for redirection of sys$error
1655  */
1656 void
1657 Perl_vmssetuserlnm(const char *name, const char *eqv)
1658 {
1659     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1660     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1661     unsigned long int iss, attr = LNM$M_CONFINE;
1662     unsigned char acmode = PSL$C_USER;
1663     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1664                                  {0, 0, 0, 0}};
1665     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1666     d_name.dsc$w_length = strlen(name);
1667
1668     lnmlst[0].buflen = strlen(eqv);
1669     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1670
1671     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1672     if (!(iss&1)) lib$signal(iss);
1673 }
1674 /*}}}*/
1675
1676
1677 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1678 /* my_crypt - VMS password hashing
1679  * my_crypt() provides an interface compatible with the Unix crypt()
1680  * C library function, and uses sys$hash_password() to perform VMS
1681  * password hashing.  The quadword hashed password value is returned
1682  * as a NUL-terminated 8 character string.  my_crypt() does not change
1683  * the case of its string arguments; in order to match the behavior
1684  * of LOGINOUT et al., alphabetic characters in both arguments must
1685  *  be upcased by the caller.
1686  *
1687  * - fix me to call ACM services when available
1688  */
1689 char *
1690 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1691 {
1692 #   ifndef UAI$C_PREFERRED_ALGORITHM
1693 #     define UAI$C_PREFERRED_ALGORITHM 127
1694 #   endif
1695     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1696     unsigned short int salt = 0;
1697     unsigned long int sts;
1698     struct const_dsc {
1699         unsigned short int dsc$w_length;
1700         unsigned char      dsc$b_type;
1701         unsigned char      dsc$b_class;
1702         const char *       dsc$a_pointer;
1703     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1704        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1705     struct itmlst_3 uailst[3] = {
1706         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1707         { sizeof salt, UAI$_SALT,    &salt, 0},
1708         { 0,           0,            NULL,  NULL}};
1709     static char hash[9];
1710
1711     usrdsc.dsc$w_length = strlen(usrname);
1712     usrdsc.dsc$a_pointer = usrname;
1713     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1714       switch (sts) {
1715         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1716           set_errno(EACCES);
1717           break;
1718         case RMS$_RNF:
1719           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1720           break;
1721         default:
1722           set_errno(EVMSERR);
1723       }
1724       set_vaxc_errno(sts);
1725       if (sts != RMS$_RNF) return NULL;
1726     }
1727
1728     txtdsc.dsc$w_length = strlen(textpasswd);
1729     txtdsc.dsc$a_pointer = textpasswd;
1730     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1731       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1732     }
1733
1734     return (char *) hash;
1735
1736 }  /* end of my_crypt() */
1737 /*}}}*/
1738
1739
1740 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1741 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1742 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1743
1744 /* 8.3, remove() is now broken on symbolic links */
1745 static int rms_erase(const char * vmsname);
1746
1747
1748 /* mp_do_kill_file
1749  * A little hack to get around a bug in some implementation of remove()
1750  * that do not know how to delete a directory
1751  *
1752  * Delete any file to which user has control access, regardless of whether
1753  * delete access is explicitly allowed.
1754  * Limitations: User must have write access to parent directory.
1755  *              Does not block signals or ASTs; if interrupted in midstream
1756  *              may leave file with an altered ACL.
1757  * HANDLE WITH CARE!
1758  */
1759 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1760 static int
1761 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1762 {
1763     char *vmsname;
1764     char *rslt;
1765     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1766     unsigned long int cxt = 0, aclsts, fndsts;
1767     int rmsts = -1;
1768     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1769     struct myacedef {
1770       unsigned char myace$b_length;
1771       unsigned char myace$b_type;
1772       unsigned short int myace$w_flags;
1773       unsigned long int myace$l_access;
1774       unsigned long int myace$l_ident;
1775     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1776                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1777       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1778      struct itmlst_3
1779        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1780                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1781        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1782        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1783        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1784        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1785
1786     /* Expand the input spec using RMS, since the CRTL remove() and
1787      * system services won't do this by themselves, so we may miss
1788      * a file "hiding" behind a logical name or search list. */
1789     vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
1790     if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1791
1792     rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
1793     if (rslt == NULL) {
1794         PerlMem_free(vmsname);
1795         return -1;
1796       }
1797
1798     /* Erase the file */
1799     rmsts = rms_erase(vmsname);
1800
1801     /* Did it succeed */
1802     if ($VMS_STATUS_SUCCESS(rmsts)) {
1803         PerlMem_free(vmsname);
1804         return 0;
1805       }
1806
1807     /* If not, can changing protections help? */
1808     if (rmsts != RMS$_PRV) {
1809       set_vaxc_errno(rmsts);
1810       PerlMem_free(vmsname);
1811       return -1;
1812     }
1813
1814     /* No, so we get our own UIC to use as a rights identifier,
1815      * and the insert an ACE at the head of the ACL which allows us
1816      * to delete the file.
1817      */
1818     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1819     fildsc.dsc$w_length = strlen(vmsname);
1820     fildsc.dsc$a_pointer = vmsname;
1821     cxt = 0;
1822     newace.myace$l_ident = oldace.myace$l_ident;
1823     rmsts = -1;
1824     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1825       switch (aclsts) {
1826         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1827           set_errno(ENOENT); break;
1828         case RMS$_DIR:
1829           set_errno(ENOTDIR); break;
1830         case RMS$_DEV:
1831           set_errno(ENODEV); break;
1832         case RMS$_SYN: case SS$_INVFILFOROP:
1833           set_errno(EINVAL); break;
1834         case RMS$_PRV:
1835           set_errno(EACCES); break;
1836         default:
1837           _ckvmssts_noperl(aclsts);
1838       }
1839       set_vaxc_errno(aclsts);
1840       PerlMem_free(vmsname);
1841       return -1;
1842     }
1843     /* Grab any existing ACEs with this identifier in case we fail */
1844     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1845     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1846                     || fndsts == SS$_NOMOREACE ) {
1847       /* Add the new ACE . . . */
1848       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1849         goto yourroom;
1850
1851       rmsts = rms_erase(vmsname);
1852       if ($VMS_STATUS_SUCCESS(rmsts)) {
1853         rmsts = 0;
1854         }
1855         else {
1856         rmsts = -1;
1857         /* We blew it - dir with files in it, no write priv for
1858          * parent directory, etc.  Put things back the way they were. */
1859         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1860           goto yourroom;
1861         if (fndsts & 1) {
1862           addlst[0].bufadr = &oldace;
1863           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1864             goto yourroom;
1865         }
1866       }
1867     }
1868
1869     yourroom:
1870     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1871     /* We just deleted it, so of course it's not there.  Some versions of
1872      * VMS seem to return success on the unlock operation anyhow (after all
1873      * the unlock is successful), but others don't.
1874      */
1875     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1876     if (aclsts & 1) aclsts = fndsts;
1877     if (!(aclsts & 1)) {
1878       set_errno(EVMSERR);
1879       set_vaxc_errno(aclsts);
1880     }
1881
1882     PerlMem_free(vmsname);
1883     return rmsts;
1884
1885 }  /* end of kill_file() */
1886 /*}}}*/
1887
1888
1889 /*{{{int do_rmdir(char *name)*/
1890 int
1891 Perl_do_rmdir(pTHX_ const char *name)
1892 {
1893     char * dirfile;
1894     int retval;
1895     Stat_t st;
1896
1897     /* lstat returns a VMS fileified specification of the name */
1898     /* that is looked up, and also lets verifies that this is a directory */
1899
1900     retval = flex_lstat(name, &st);
1901     if (retval != 0) {
1902         char * ret_spec;
1903
1904         /* Due to a historical feature, flex_stat/lstat can not see some */
1905         /* Unix format file names that the rest of the CRTL can see */
1906         /* Fixing that feature will cause some perl tests to fail */
1907         /* So try this one more time. */
1908
1909         retval = lstat(name, &st.crtl_stat);
1910         if (retval != 0)
1911             return -1;
1912
1913         /* force it to a file spec for the kill file to work. */
1914         ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
1915         if (ret_spec == NULL) {
1916             errno = EIO;
1917             return -1;
1918         }
1919     }
1920
1921     if (!S_ISDIR(st.st_mode)) {
1922         errno = ENOTDIR;
1923         retval = -1;
1924     }
1925     else {
1926         dirfile = st.st_devnam;
1927
1928         /* It may be possible for flex_stat to find a file and vmsify() to */
1929         /* fail with ODS-2 specifications.  mp_do_kill_file can not deal */
1930         /* with that case, so fail it */
1931         if (dirfile[0] == 0) {
1932             errno = EIO;
1933             return -1;
1934         }
1935
1936         retval = mp_do_kill_file(aTHX_ dirfile, 1);
1937     }
1938
1939     return retval;
1940
1941 }  /* end of do_rmdir */
1942 /*}}}*/
1943
1944 /* kill_file
1945  * Delete any file to which user has control access, regardless of whether
1946  * delete access is explicitly allowed.
1947  * Limitations: User must have write access to parent directory.
1948  *              Does not block signals or ASTs; if interrupted in midstream
1949  *              may leave file with an altered ACL.
1950  * HANDLE WITH CARE!
1951  */
1952 /*{{{int kill_file(char *name)*/
1953 int
1954 Perl_kill_file(pTHX_ const char *name)
1955 {
1956     char * vmsfile;
1957     Stat_t st;
1958     int rmsts;
1959
1960     /* Convert the filename to VMS format and see if it is a directory */
1961     /* flex_lstat returns a vmsified file specification */
1962     rmsts = flex_lstat(name, &st);
1963     if (rmsts != 0) {
1964
1965         /* Due to a historical feature, flex_stat/lstat can not see some */
1966         /* Unix format file names that the rest of the CRTL can see when */
1967         /* ODS-2 file specifications are in use. */
1968         /* Fixing that feature will cause some perl tests to fail */
1969         /* [.lib.ExtUtils.t]Manifest.t is one of them */
1970         st.st_mode = 0;
1971         vmsfile = (char *) name; /* cast ok */
1972
1973     } else {
1974         vmsfile = st.st_devnam;
1975         if (vmsfile[0] == 0) {
1976             /* It may be possible for flex_stat to find a file and vmsify() */
1977             /* to fail with ODS-2 specifications.  mp_do_kill_file can not */
1978             /* deal with that case, so fail it */
1979             errno = EIO;
1980             return -1;
1981         }
1982     }
1983
1984     /* Remove() is allowed to delete directories, according to the X/Open
1985      * specifications.
1986      * This may need special handling to work with the ACL hacks.
1987      */
1988     if (S_ISDIR(st.st_mode)) {
1989         rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
1990         return rmsts;
1991     }
1992
1993     rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
1994
1995     /* Need to delete all versions ? */
1996     if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
1997         int i = 0;
1998
1999         /* Just use lstat() here as do not need st_dev */
2000         /* and we know that the file is in VMS format or that */
2001         /* because of a historical bug, flex_stat can not see the file */
2002         while (lstat(vmsfile, (stat_t *)&st) == 0) {
2003             rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2004             if (rmsts != 0)
2005                 break;
2006             i++;
2007
2008             /* Make sure that we do not loop forever */
2009             if (i > 32767) {
2010                 errno = EIO;
2011                 rmsts = -1;
2012                 break;
2013             }
2014         }
2015     }
2016
2017     return rmsts;
2018
2019 }  /* end of kill_file() */
2020 /*}}}*/
2021
2022
2023 /*{{{int my_mkdir(char *,Mode_t)*/
2024 int
2025 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2026 {
2027   STRLEN dirlen = strlen(dir);
2028
2029   /* zero length string sometimes gives ACCVIO */
2030   if (dirlen == 0) return -1;
2031
2032   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2033    * null file name/type.  However, it's commonplace under Unix,
2034    * so we'll allow it for a gain in portability.
2035    */
2036   if (dir[dirlen-1] == '/') {
2037     char *newdir = savepvn(dir,dirlen-1);
2038     int ret = mkdir(newdir,mode);
2039     Safefree(newdir);
2040     return ret;
2041   }
2042   else return mkdir(dir,mode);
2043 }  /* end of my_mkdir */
2044 /*}}}*/
2045
2046 /*{{{int my_chdir(char *)*/
2047 int
2048 Perl_my_chdir(pTHX_ const char *dir)
2049 {
2050   STRLEN dirlen = strlen(dir);
2051   const char *dir1 = dir;
2052
2053   /* POSIX says we should set ENOENT for zero length string. */
2054   if (dirlen == 0) {
2055     SETERRNO(ENOENT, RMS$_DNF);
2056     return -1;
2057   }
2058
2059   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2060    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2061    * so that existing scripts do not need to be changed.
2062    */
2063   while ((dirlen > 0) && (*dir1 == ' ')) {
2064     dir1++;
2065     dirlen--;
2066   }
2067
2068   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2069    * that implies
2070    * null file name/type.  However, it's commonplace under Unix,
2071    * so we'll allow it for a gain in portability.
2072    *
2073    *  '/' is valid when SYS$POSIX_ROOT or POSIX compliant pathnames are active.
2074    */
2075   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2076       char *newdir;
2077       int ret;
2078       newdir = (char *)PerlMem_malloc(dirlen);
2079       if (newdir ==NULL)
2080           _ckvmssts_noperl(SS$_INSFMEM);
2081       memcpy(newdir, dir1, dirlen-1);
2082       newdir[dirlen-1] = '\0';
2083       ret = chdir(newdir);
2084       PerlMem_free(newdir);
2085       return ret;
2086   }
2087   else return chdir(dir1);
2088 }  /* end of my_chdir */
2089 /*}}}*/
2090
2091
2092 /*{{{int my_chmod(char *, mode_t)*/
2093 int
2094 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2095 {
2096   Stat_t st;
2097   int ret = -1;
2098   char * changefile;
2099   STRLEN speclen = strlen(file_spec);
2100
2101   /* zero length string sometimes gives ACCVIO */
2102   if (speclen == 0) return -1;
2103
2104   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2105    * that implies null file name/type.  However, it's commonplace under Unix,
2106    * so we'll allow it for a gain in portability.
2107    *
2108    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2109    * in VMS file.dir notation.
2110    */
2111   changefile = (char *) file_spec; /* cast ok */
2112   ret = flex_lstat(file_spec, &st);
2113   if (ret != 0) {
2114
2115         /* Due to a historical feature, flex_stat/lstat can not see some */
2116         /* Unix format file names that the rest of the CRTL can see when */
2117         /* ODS-2 file specifications are in use. */
2118         /* Fixing that feature will cause some perl tests to fail */
2119         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2120         st.st_mode = 0;
2121
2122   } else {
2123       /* It may be possible to get here with nothing in st_devname */
2124       /* chmod still may work though */
2125       if (st.st_devnam[0] != 0) {
2126           changefile = st.st_devnam;
2127       }
2128   }
2129   ret = chmod(changefile, mode);
2130   return ret;
2131 }  /* end of my_chmod */
2132 /*}}}*/
2133
2134
2135 /*{{{FILE *my_tmpfile()*/
2136 FILE *
2137 my_tmpfile(void)
2138 {
2139   FILE *fp;
2140   char *cp;
2141
2142   if ((fp = tmpfile())) return fp;
2143
2144   cp = (char *)PerlMem_malloc(L_tmpnam+24);
2145   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2146
2147   if (decc_filename_unix_only == 0)
2148     strcpy(cp,"Sys$Scratch:");
2149   else
2150     strcpy(cp,"/tmp/");
2151   tmpnam(cp+strlen(cp));
2152   strcat(cp,".Perltmp");
2153   fp = fopen(cp,"w+","fop=dlt");
2154   PerlMem_free(cp);
2155   return fp;
2156 }
2157 /*}}}*/
2158
2159
2160 /*
2161  * The C RTL's sigaction fails to check for invalid signal numbers so we
2162  * help it out a bit.  The docs are correct, but the actual routine doesn't
2163  * do what the docs say it will.
2164  */
2165 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2166 int
2167 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2168                    struct sigaction* oact)
2169 {
2170   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2171         SETERRNO(EINVAL, SS$_INVARG);
2172         return -1;
2173   }
2174   return sigaction(sig, act, oact);
2175 }
2176 /*}}}*/
2177
2178 #include <errnodef.h>
2179
2180 /* We implement our own kill() using the undocumented system service
2181    sys$sigprc for one of two reasons:
2182
2183    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2184    target process to do a sys$exit, which usually can't be handled
2185    gracefully...certainly not by Perl and the %SIG{} mechanism.
2186
2187    2.) If the kill() in the CRTL can't be called from a signal
2188    handler without disappearing into the ether, i.e., the signal
2189    it purportedly sends is never trapped. Still true as of VMS 7.3.
2190
2191    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2192    in the target process rather than calling sys$exit.
2193
2194    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2195    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2196    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2197    with condition codes C$_SIG0+nsig*8, catching the exception on the
2198    target process and resignaling with appropriate arguments.
2199
2200    But we don't have that VMS 7.0+ exception handler, so if you
2201    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2202
2203    Also note that SIGTERM is listed in the docs as being "unimplemented",
2204    yet always seems to be signaled with a VMS condition code of 4 (and
2205    correctly handled for that code).  So we hardwire it in.
2206
2207    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2208    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2209    than signalling with an unrecognized (and unhandled by CRTL) code.
2210 */
2211
2212 #define _MY_SIG_MAX 28
2213
2214 static unsigned int
2215 Perl_sig_to_vmscondition_int(int sig)
2216 {
2217     static unsigned int sig_code[_MY_SIG_MAX+1] =
2218     {
2219         0,                  /*  0 ZERO     */
2220         SS$_HANGUP,         /*  1 SIGHUP   */
2221         SS$_CONTROLC,       /*  2 SIGINT   */
2222         SS$_CONTROLY,       /*  3 SIGQUIT  */
2223         SS$_RADRMOD,        /*  4 SIGILL   */
2224         SS$_BREAK,          /*  5 SIGTRAP  */
2225         SS$_OPCCUS,         /*  6 SIGABRT  */
2226         SS$_COMPAT,         /*  7 SIGEMT   */
2227         SS$_HPARITH,        /*  8 SIGFPE AXP */
2228         SS$_ABORT,          /*  9 SIGKILL  */
2229         SS$_ACCVIO,         /* 10 SIGBUS   */
2230         SS$_ACCVIO,         /* 11 SIGSEGV  */
2231         SS$_BADPARAM,       /* 12 SIGSYS   */
2232         SS$_NOMBX,          /* 13 SIGPIPE  */
2233         SS$_ASTFLT,         /* 14 SIGALRM  */
2234         4,                  /* 15 SIGTERM  */
2235         0,                  /* 16 SIGUSR1  */
2236         0,                  /* 17 SIGUSR2  */
2237         0,                  /* 18 */
2238         0,                  /* 19 */
2239         0,                  /* 20 SIGCHLD  */
2240         0,                  /* 21 SIGCONT  */
2241         0,                  /* 22 SIGSTOP  */
2242         0,                  /* 23 SIGTSTP  */
2243         0,                  /* 24 SIGTTIN  */
2244         0,                  /* 25 SIGTTOU  */
2245         0,                  /* 26 */
2246         0,                  /* 27 */
2247         0                   /* 28 SIGWINCH  */
2248     };
2249
2250     static int initted = 0;
2251     if (!initted) {
2252         initted = 1;
2253         sig_code[16] = C$_SIGUSR1;
2254         sig_code[17] = C$_SIGUSR2;
2255         sig_code[20] = C$_SIGCHLD;
2256         sig_code[28] = C$_SIGWINCH;
2257     }
2258
2259     if (sig < _SIG_MIN) return 0;
2260     if (sig > _MY_SIG_MAX) return 0;
2261     return sig_code[sig];
2262 }
2263
2264 unsigned int
2265 Perl_sig_to_vmscondition(int sig)
2266 {
2267 #ifdef SS$_DEBUG
2268     if (vms_debug_on_exception != 0)
2269         lib$signal(SS$_DEBUG);
2270 #endif
2271     return Perl_sig_to_vmscondition_int(sig);
2272 }
2273
2274
2275 #ifdef KILL_BY_SIGPRC
2276 #define sys$sigprc SYS$SIGPRC
2277 #ifdef __cplusplus
2278 extern "C" {
2279 #endif
2280 int sys$sigprc(unsigned int *pidadr,
2281                struct dsc$descriptor_s *prcname,
2282                unsigned int code);
2283 #ifdef __cplusplus
2284 }
2285 #endif
2286
2287 int
2288 Perl_my_kill(int pid, int sig)
2289 {
2290     int iss;
2291     unsigned int code;
2292
2293      /* sig 0 means validate the PID */
2294     /*------------------------------*/
2295     if (sig == 0) {
2296         const unsigned long int jpicode = JPI$_PID;
2297         pid_t ret_pid;
2298         int status;
2299         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2300         if ($VMS_STATUS_SUCCESS(status))
2301            return 0;
2302         switch (status) {
2303         case SS$_NOSUCHNODE:
2304         case SS$_UNREACHABLE:
2305         case SS$_NONEXPR:
2306            errno = ESRCH;
2307            break;
2308         case SS$_NOPRIV:
2309            errno = EPERM;
2310            break;
2311         default:
2312            errno = EVMSERR;
2313         }
2314         vaxc$errno=status;
2315         return -1;
2316     }
2317
2318     code = Perl_sig_to_vmscondition_int(sig);
2319
2320     if (!code) {
2321         SETERRNO(EINVAL, SS$_BADPARAM);
2322         return -1;
2323     }
2324
2325     /* Per official UNIX specification: If pid = 0, or negative then
2326      * signals are to be sent to multiple processes.
2327      *  pid = 0 - all processes in group except ones that the system exempts
2328      *  pid = -1 - all processes except ones that the system exempts
2329      *  pid = -n - all processes in group (abs(n)) except ...
2330      *
2331      * Handle these via killpg, which is redundant for the -n case, since OP_KILL
2332      * in doio.c already does that. killpg currently does not support the -1 case.
2333      */
2334
2335     if (pid <= 0) {
2336         return killpg(-pid, sig);
2337     }
2338
2339     iss = sys$sigprc((unsigned int *)&pid,0,code);
2340     if (iss&1) return 0;
2341
2342     switch (iss) {
2343       case SS$_NOPRIV:
2344         set_errno(EPERM);  break;
2345       case SS$_NONEXPR:
2346       case SS$_NOSUCHNODE:
2347       case SS$_UNREACHABLE:
2348         set_errno(ESRCH);  break;
2349       case SS$_INSFMEM:
2350         set_errno(ENOMEM); break;
2351       default:
2352         _ckvmssts_noperl(iss);
2353         set_errno(EVMSERR);
2354     }
2355     set_vaxc_errno(iss);
2356
2357     return -1;
2358 }
2359 #endif
2360
2361 int
2362 Perl_my_killpg(pid_t master_pid, int signum)
2363 {
2364     int pid, status, i;
2365     unsigned long int jpi_context;
2366     unsigned short int iosb[4];
2367     struct itmlst_3  il3[3];
2368
2369     /* All processes on the system?  Seems dangerous, but it looks
2370      * like we could implement this pretty easily with a wildcard
2371      * input to sys$process_scan.
2372      */
2373     if (master_pid == -1) {
2374         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2375         return -1;
2376     }
2377
2378     /* All processes in the current process group; find the master
2379      * pid for the current process.
2380      */
2381     if (master_pid == 0) {
2382         i = 0;
2383         il3[i].buflen   = sizeof( int );
2384         il3[i].itmcode   = JPI$_MASTER_PID;
2385         il3[i].bufadr   = &master_pid;
2386         il3[i++].retlen = NULL;
2387
2388         il3[i].buflen   = 0;
2389         il3[i].itmcode   = 0;
2390         il3[i].bufadr   = NULL;
2391         il3[i++].retlen = NULL;
2392
2393         status = sys$getjpiw(EFN$C_ENF, NULL, NULL, il3, iosb, NULL, 0);
2394         if ($VMS_STATUS_SUCCESS(status))
2395             status = iosb[0];
2396
2397         switch (status) {
2398             case SS$_NORMAL:
2399                 break;
2400             case SS$_NOPRIV:
2401             case SS$_SUSPENDED:
2402                 SETERRNO(EPERM, status);
2403                 break;
2404             case SS$_NOMOREPROC:
2405             case SS$_NONEXPR:
2406             case SS$_NOSUCHNODE:
2407             case SS$_UNREACHABLE:
2408                 SETERRNO(ESRCH, status);
2409                 break;
2410             case SS$_ACCVIO:
2411             case SS$_BADPARAM:
2412                 SETERRNO(EINVAL, status);
2413                 break;
2414             default:
2415                 SETERRNO(EVMSERR, status);
2416         }
2417         if (!$VMS_STATUS_SUCCESS(status))
2418             return -1;
2419     }
2420
2421     /* Set up a process context for those processes we will scan
2422      * with sys$getjpiw.  Ask for all processes belonging to the
2423      * master pid.
2424      */
2425
2426     i = 0;
2427     il3[i].buflen   = 0;
2428     il3[i].itmcode   = PSCAN$_MASTER_PID;
2429     il3[i].bufadr   = (void *)master_pid;
2430     il3[i++].retlen = NULL;
2431
2432     il3[i].buflen   = 0;
2433     il3[i].itmcode   = 0;
2434     il3[i].bufadr   = NULL;
2435     il3[i++].retlen = NULL;
2436
2437     status = sys$process_scan(&jpi_context, il3);
2438     switch (status) {
2439         case SS$_NORMAL:
2440             break;
2441         case SS$_ACCVIO:
2442         case SS$_BADPARAM:
2443         case SS$_IVBUFLEN:
2444         case SS$_IVSSRQ:
2445             SETERRNO(EINVAL, status);
2446             break;
2447         default:
2448             SETERRNO(EVMSERR, status);
2449     }
2450     if (!$VMS_STATUS_SUCCESS(status))
2451         return -1;
2452
2453     i = 0;
2454     il3[i].buflen   = sizeof(int);
2455     il3[i].itmcode  = JPI$_PID;
2456     il3[i].bufadr   = &pid;
2457     il3[i++].retlen = NULL;
2458
2459     il3[i].buflen   = 0;
2460     il3[i].itmcode  = 0;
2461     il3[i].bufadr   = NULL;
2462     il3[i++].retlen = NULL;
2463
2464     /* Loop through the processes matching our specified criteria
2465      */
2466
2467     while (1) {
2468         /* Find the next process...
2469          */
2470         status = sys$getjpiw( EFN$C_ENF, &jpi_context, NULL, il3, iosb, NULL, 0);
2471         if ($VMS_STATUS_SUCCESS(status)) status = iosb[0];
2472
2473         switch (status) {
2474             case SS$_NORMAL:
2475                 if (kill(pid, signum) == -1)
2476                     break;
2477
2478                 continue;     /* next process */
2479             case SS$_NOPRIV:
2480             case SS$_SUSPENDED:
2481                 SETERRNO(EPERM, status);
2482                 break;
2483             case SS$_NOMOREPROC:
2484                 break;
2485             case SS$_NONEXPR:
2486             case SS$_NOSUCHNODE:
2487             case SS$_UNREACHABLE:
2488                 SETERRNO(ESRCH, status);
2489                 break;
2490             case SS$_ACCVIO:
2491             case SS$_BADPARAM:
2492                 SETERRNO(EINVAL, status);
2493                 break;
2494             default:
2495                SETERRNO(EVMSERR, status);
2496         }
2497
2498         if (!$VMS_STATUS_SUCCESS(status))
2499             break;
2500     }
2501
2502     /* Release context-related resources.
2503      */
2504     (void) sys$process_scan(&jpi_context);
2505
2506     if (status != SS$_NOMOREPROC)
2507         return -1;
2508
2509     return 0;
2510 }
2511
2512 /* Routine to convert a VMS status code to a UNIX status code.
2513 ** More tricky than it appears because of conflicting conventions with
2514 ** existing code.
2515 **
2516 ** VMS status codes are a bit mask, with the least significant bit set for
2517 ** success.
2518 **
2519 ** Special UNIX status of EVMSERR indicates that no translation is currently
2520 ** available, and programs should check the VMS status code.
2521 **
2522 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2523 ** decoding.
2524 */
2525
2526 #ifndef C_FACILITY_NO
2527 #define C_FACILITY_NO 0x350000
2528 #endif
2529 #ifndef DCL_IVVERB
2530 #define DCL_IVVERB 0x38090
2531 #endif
2532
2533 int
2534 Perl_vms_status_to_unix(int vms_status, int child_flag)
2535 {
2536   int facility;
2537   int fac_sp;
2538   int msg_no;
2539   int msg_status;
2540   int unix_status;
2541
2542   /* Assume the best or the worst */
2543   if (vms_status & STS$M_SUCCESS)
2544     unix_status = 0;
2545   else
2546     unix_status = EVMSERR;
2547
2548   msg_status = vms_status & ~STS$M_CONTROL;
2549
2550   facility = vms_status & STS$M_FAC_NO;
2551   fac_sp = vms_status & STS$M_FAC_SP;
2552   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2553
2554   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2555     switch(msg_no) {
2556     case SS$_NORMAL:
2557         unix_status = 0;
2558         break;
2559     case SS$_ACCVIO:
2560         unix_status = EFAULT;
2561         break;
2562     case SS$_DEVOFFLINE:
2563         unix_status = EBUSY;
2564         break;
2565     case SS$_CLEARED:
2566         unix_status = ENOTCONN;
2567         break;
2568     case SS$_IVCHAN:
2569     case SS$_IVLOGNAM:
2570     case SS$_BADPARAM:
2571     case SS$_IVLOGTAB:
2572     case SS$_NOLOGNAM:
2573     case SS$_NOLOGTAB:
2574     case SS$_INVFILFOROP:
2575     case SS$_INVARG:
2576     case SS$_NOSUCHID:
2577     case SS$_IVIDENT:
2578         unix_status = EINVAL;
2579         break;
2580     case SS$_UNSUPPORTED:
2581         unix_status = ENOTSUP;
2582         break;
2583     case SS$_FILACCERR:
2584     case SS$_NOGRPPRV:
2585     case SS$_NOSYSPRV:
2586         unix_status = EACCES;
2587         break;
2588     case SS$_DEVICEFULL:
2589         unix_status = ENOSPC;
2590         break;
2591     case SS$_NOSUCHDEV:
2592         unix_status = ENODEV;
2593         break;
2594     case SS$_NOSUCHFILE:
2595     case SS$_NOSUCHOBJECT:
2596         unix_status = ENOENT;
2597         break;
2598     case SS$_ABORT:                                 /* Fatal case */
2599     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2600     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2601         unix_status = EINTR;
2602         break;
2603     case SS$_BUFFEROVF:
2604         unix_status = E2BIG;
2605         break;
2606     case SS$_INSFMEM:
2607         unix_status = ENOMEM;
2608         break;
2609     case SS$_NOPRIV:
2610         unix_status = EPERM;
2611         break;
2612     case SS$_NOSUCHNODE:
2613     case SS$_UNREACHABLE:
2614         unix_status = ESRCH;
2615         break;
2616     case SS$_NONEXPR:
2617         unix_status = ECHILD;
2618         break;
2619     default:
2620         if ((facility == 0) && (msg_no < 8)) {
2621           /* These are not real VMS status codes so assume that they are
2622           ** already UNIX status codes
2623           */
2624           unix_status = msg_no;
2625           break;
2626         }
2627     }
2628   }
2629   else {
2630     /* Translate a POSIX exit code to a UNIX exit code */
2631     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2632         unix_status = (msg_no & 0x07F8) >> 3;
2633     }
2634     else {
2635
2636          /* Documented traditional behavior for handling VMS child exits */
2637         /*--------------------------------------------------------------*/
2638         if (child_flag != 0) {
2639
2640              /* Success / Informational return 0 */
2641             /*----------------------------------*/
2642             if (msg_no & STS$K_SUCCESS)
2643                 return 0;
2644
2645              /* Warning returns 1 */
2646             /*-------------------*/
2647             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2648                 return 1;
2649
2650              /* Everything else pass through the severity bits */
2651             /*------------------------------------------------*/
2652             return (msg_no & STS$M_SEVERITY);
2653         }
2654
2655          /* Normal VMS status to ERRNO mapping attempt */
2656         /*--------------------------------------------*/
2657         switch(msg_status) {
2658         /* case RMS$_EOF: */ /* End of File */
2659         case RMS$_FNF:  /* File Not Found */
2660         case RMS$_DNF:  /* Dir Not Found */
2661                 unix_status = ENOENT;
2662                 break;
2663         case RMS$_RNF:  /* Record Not Found */
2664                 unix_status = ESRCH;
2665                 break;
2666         case RMS$_DIR:
2667                 unix_status = ENOTDIR;
2668                 break;
2669         case RMS$_DEV:
2670                 unix_status = ENODEV;
2671                 break;
2672         case RMS$_IFI:
2673         case RMS$_FAC:
2674         case RMS$_ISI:
2675                 unix_status = EBADF;
2676                 break;
2677         case RMS$_FEX:
2678                 unix_status = EEXIST;
2679                 break;
2680         case RMS$_SYN:
2681         case RMS$_FNM:
2682         case LIB$_INVSTRDES:
2683         case LIB$_INVARG:
2684         case LIB$_NOSUCHSYM:
2685         case LIB$_INVSYMNAM:
2686         case DCL_IVVERB:
2687                 unix_status = EINVAL;
2688                 break;
2689         case CLI$_BUFOVF:
2690         case RMS$_RTB:
2691         case CLI$_TKNOVF:
2692         case CLI$_RSLOVF:
2693                 unix_status = E2BIG;
2694                 break;
2695         case RMS$_PRV:  /* No privilege */
2696         case RMS$_ACC:  /* ACP file access failed */
2697         case RMS$_WLK:  /* Device write locked */
2698                 unix_status = EACCES;
2699                 break;
2700         case RMS$_MKD:  /* Failed to mark for delete */
2701                 unix_status = EPERM;
2702                 break;
2703         /* case RMS$_NMF: */  /* No more files */
2704         }
2705     }
2706   }
2707
2708   return unix_status;
2709 }
2710
2711 /* Try to guess at what VMS error status should go with a UNIX errno
2712  * value.  This is hard to do as there could be many possible VMS
2713  * error statuses that caused the errno value to be set.
2714  */
2715
2716 int
2717 Perl_unix_status_to_vms(int unix_status)
2718 {
2719     int test_unix_status;
2720
2721      /* Trivial cases first */
2722     /*---------------------*/
2723     if (unix_status == EVMSERR)
2724         return vaxc$errno;
2725
2726      /* Is vaxc$errno sane? */
2727     /*---------------------*/
2728     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2729     if (test_unix_status == unix_status)
2730         return vaxc$errno;
2731
2732      /* If way out of range, must be VMS code already */
2733     /*-----------------------------------------------*/
2734     if (unix_status > EVMSERR)
2735         return unix_status;
2736
2737      /* If out of range, punt */
2738     /*-----------------------*/
2739     if (unix_status > __ERRNO_MAX)
2740         return SS$_ABORT;
2741
2742
2743      /* Ok, now we have to do it the hard way. */
2744     /*----------------------------------------*/
2745     switch(unix_status) {
2746     case 0:     return SS$_NORMAL;
2747     case EPERM: return SS$_NOPRIV;
2748     case ENOENT: return SS$_NOSUCHOBJECT;
2749     case ESRCH: return SS$_UNREACHABLE;
2750     case EINTR: return SS$_ABORT;
2751     /* case EIO: */
2752     /* case ENXIO:  */
2753     case E2BIG: return SS$_BUFFEROVF;
2754     /* case ENOEXEC */
2755     case EBADF: return RMS$_IFI;
2756     case ECHILD: return SS$_NONEXPR;
2757     /* case EAGAIN */
2758     case ENOMEM: return SS$_INSFMEM;
2759     case EACCES: return SS$_FILACCERR;
2760     case EFAULT: return SS$_ACCVIO;
2761     /* case ENOTBLK */
2762     case EBUSY: return SS$_DEVOFFLINE;
2763     case EEXIST: return RMS$_FEX;
2764     /* case EXDEV */
2765     case ENODEV: return SS$_NOSUCHDEV;
2766     case ENOTDIR: return RMS$_DIR;
2767     /* case EISDIR */
2768     case EINVAL: return SS$_INVARG;
2769     /* case ENFILE */
2770     /* case EMFILE */
2771     /* case ENOTTY */
2772     /* case ETXTBSY */
2773     /* case EFBIG */
2774     case ENOSPC: return SS$_DEVICEFULL;
2775     case ESPIPE: return LIB$_INVARG;
2776     /* case EROFS: */
2777     /* case EMLINK: */
2778     /* case EPIPE: */
2779     /* case EDOM */
2780     case ERANGE: return LIB$_INVARG;
2781     /* case EWOULDBLOCK */
2782     /* case EINPROGRESS */
2783     /* case EALREADY */
2784     /* case ENOTSOCK */
2785     /* case EDESTADDRREQ */
2786     /* case EMSGSIZE */
2787     /* case EPROTOTYPE */
2788     /* case ENOPROTOOPT */
2789     /* case EPROTONOSUPPORT */
2790     /* case ESOCKTNOSUPPORT */
2791     /* case EOPNOTSUPP */
2792     /* case EPFNOSUPPORT */
2793     /* case EAFNOSUPPORT */
2794     /* case EADDRINUSE */
2795     /* case EADDRNOTAVAIL */
2796     /* case ENETDOWN */
2797     /* case ENETUNREACH */
2798     /* case ENETRESET */
2799     /* case ECONNABORTED */
2800     /* case ECONNRESET */
2801     /* case ENOBUFS */
2802     /* case EISCONN */
2803     case ENOTCONN: return SS$_CLEARED;
2804     /* case ESHUTDOWN */
2805     /* case ETOOMANYREFS */
2806     /* case ETIMEDOUT */
2807     /* case ECONNREFUSED */
2808     /* case ELOOP */
2809     /* case ENAMETOOLONG */
2810     /* case EHOSTDOWN */
2811     /* case EHOSTUNREACH */
2812     /* case ENOTEMPTY */
2813     /* case EPROCLIM */
2814     /* case EUSERS  */
2815     /* case EDQUOT  */
2816     /* case ENOMSG  */
2817     /* case EIDRM */
2818     /* case EALIGN */
2819     /* case ESTALE */
2820     /* case EREMOTE */
2821     /* case ENOLCK */
2822     /* case ENOSYS */
2823     /* case EFTYPE */
2824     /* case ECANCELED */
2825     /* case EFAIL */
2826     /* case EINPROG */
2827     case ENOTSUP:
2828         return SS$_UNSUPPORTED;
2829     /* case EDEADLK */
2830     /* case ENWAIT */
2831     /* case EILSEQ */
2832     /* case EBADCAT */
2833     /* case EBADMSG */
2834     /* case EABANDONED */
2835     default:
2836         return SS$_ABORT; /* punt */
2837     }
2838 }
2839
2840
2841 /* default piping mailbox size */
2842 #define PERL_BUFSIZ        8192
2843
2844
2845 static void
2846 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2847 {
2848   unsigned long int mbxbufsiz;
2849   static unsigned long int syssize = 0;
2850   unsigned long int dviitm = DVI$_DEVNAM;
2851   char csize[LNM$C_NAMLENGTH+1];
2852   int sts;
2853
2854   if (!syssize) {
2855     unsigned long syiitm = SYI$_MAXBUF;
2856     /*
2857      * Get the SYSGEN parameter MAXBUF
2858      *
2859      * If the logical 'PERL_MBX_SIZE' is defined
2860      * use the value of the logical instead of PERL_BUFSIZ, but
2861      * keep the size between 128 and MAXBUF.
2862      *
2863      */
2864     _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2865   }
2866
2867   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2868       mbxbufsiz = atoi(csize);
2869   } else {
2870       mbxbufsiz = PERL_BUFSIZ;
2871   }
2872   if (mbxbufsiz < 128) mbxbufsiz = 128;
2873   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2874
2875   _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2876
2877   sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2878   _ckvmssts_noperl(sts);
2879   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2880
2881 }  /* end of create_mbx() */
2882
2883
2884 /*{{{  my_popen and my_pclose*/
2885
2886 typedef struct _iosb           IOSB;
2887 typedef struct _iosb*         pIOSB;
2888 typedef struct _pipe           Pipe;
2889 typedef struct _pipe*         pPipe;
2890 typedef struct pipe_details    Info;
2891 typedef struct pipe_details*  pInfo;
2892 typedef struct _srqp            RQE;
2893 typedef struct _srqp*          pRQE;
2894 typedef struct _tochildbuf      CBuf;
2895 typedef struct _tochildbuf*    pCBuf;
2896
2897 struct _iosb {
2898     unsigned short status;
2899     unsigned short count;
2900     unsigned long  dvispec;
2901 };
2902
2903 #pragma member_alignment save
2904 #pragma nomember_alignment quadword
2905 struct _srqp {          /* VMS self-relative queue entry */
2906     unsigned long qptr[2];
2907 };
2908 #pragma member_alignment restore
2909 static RQE  RQE_ZERO = {0,0};
2910
2911 struct _tochildbuf {
2912     RQE             q;
2913     int             eof;
2914     unsigned short  size;
2915     char            *buf;
2916 };
2917
2918 struct _pipe {
2919     RQE            free;
2920     RQE            wait;
2921     int            fd_out;
2922     unsigned short chan_in;
2923     unsigned short chan_out;
2924     char          *buf;
2925     unsigned int   bufsize;
2926     IOSB           iosb;
2927     IOSB           iosb2;
2928     int           *pipe_done;
2929     int            retry;
2930     int            type;
2931     int            shut_on_empty;
2932     int            need_wake;
2933     pPipe         *home;
2934     pInfo          info;
2935     pCBuf          curr;
2936     pCBuf          curr2;
2937 #if defined(PERL_IMPLICIT_CONTEXT)
2938     void            *thx;           /* Either a thread or an interpreter */
2939                                     /* pointer, depending on how we're built */
2940 #endif
2941 };
2942
2943
2944 struct pipe_details
2945 {
2946     pInfo           next;
2947     PerlIO *fp;  /* file pointer to pipe mailbox */
2948     int useFILE; /* using stdio, not perlio */
2949     int pid;   /* PID of subprocess */
2950     int mode;  /* == 'r' if pipe open for reading */
2951     int done;  /* subprocess has completed */
2952     int waiting; /* waiting for completion/closure */
2953     int             closing;        /* my_pclose is closing this pipe */
2954     unsigned long   completion;     /* termination status of subprocess */
2955     pPipe           in;             /* pipe in to sub */
2956     pPipe           out;            /* pipe out of sub */
2957     pPipe           err;            /* pipe of sub's sys$error */
2958     int             in_done;        /* true when in pipe finished */
2959     int             out_done;
2960     int             err_done;
2961     unsigned short  xchan;          /* channel to debug xterm */
2962     unsigned short  xchan_valid;    /* channel is assigned */
2963 };
2964
2965 struct exit_control_block
2966 {
2967     struct exit_control_block *flink;
2968     unsigned long int (*exit_routine)(void);
2969     unsigned long int arg_count;
2970     unsigned long int *status_address;
2971     unsigned long int exit_status;
2972 };
2973
2974 typedef struct _closed_pipes    Xpipe;
2975 typedef struct _closed_pipes*  pXpipe;
2976
2977 struct _closed_pipes {
2978     int             pid;            /* PID of subprocess */
2979     unsigned long   completion;     /* termination status of subprocess */
2980 };
2981 #define NKEEPCLOSED 50
2982 static Xpipe closed_list[NKEEPCLOSED];
2983 static int   closed_index = 0;
2984 static int   closed_num = 0;
2985
2986 #define RETRY_DELAY     "0 ::0.20"
2987 #define MAX_RETRY              50
2988
2989 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2990 static unsigned long mypid;
2991 static unsigned long delaytime[2];
2992
2993 static pInfo open_pipes = NULL;
2994 static $DESCRIPTOR(nl_desc, "NL:");
2995
2996 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2997
2998
2999
3000 static unsigned long int
3001 pipe_exit_routine(void)
3002 {
3003     pInfo info;
3004     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
3005     int sts, did_stuff, j;
3006
3007    /*
3008     * Flush any pending i/o, but since we are in process run-down, be
3009     * careful about referencing PerlIO structures that may already have
3010     * been deallocated.  We may not even have an interpreter anymore.
3011     */
3012     info = open_pipes;
3013     while (info) {
3014         if (info->fp) {
3015 #if defined(PERL_IMPLICIT_CONTEXT)
3016            /* We need to use the Perl context of the thread that created */
3017            /* the pipe. */
3018            pTHX;
3019            if (info->err)
3020                aTHX = info->err->thx;
3021            else if (info->out)
3022                aTHX = info->out->thx;
3023            else if (info->in)
3024                aTHX = info->in->thx;
3025 #endif
3026            if (!info->useFILE
3027 #if defined(USE_ITHREADS)
3028              && my_perl
3029 #endif
3030 #ifdef USE_PERLIO
3031              && PL_perlio_fd_refcnt
3032 #endif
3033               )
3034                PerlIO_flush(info->fp);
3035            else
3036                fflush((FILE *)info->fp);
3037         }
3038         info = info->next;
3039     }
3040
3041     /*
3042      next we try sending an EOF...ignore if doesn't work, make sure we
3043      don't hang
3044     */
3045     did_stuff = 0;
3046     info = open_pipes;
3047
3048     while (info) {
3049       _ckvmssts_noperl(sys$setast(0));
3050       if (info->in && !info->in->shut_on_empty) {
3051         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3052                                  0, 0, 0, 0, 0, 0));
3053         info->waiting = 1;
3054         did_stuff = 1;
3055       }
3056       _ckvmssts_noperl(sys$setast(1));
3057       info = info->next;
3058     }
3059
3060     /* wait for EOF to have effect, up to ~ 30 sec [default] */
3061
3062     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3063         int nwait = 0;
3064
3065         info = open_pipes;
3066         while (info) {
3067           _ckvmssts_noperl(sys$setast(0));
3068           if (info->waiting && info->done)
3069                 info->waiting = 0;
3070           nwait += info->waiting;
3071           _ckvmssts_noperl(sys$setast(1));
3072           info = info->next;
3073         }
3074         if (!nwait) break;
3075         sleep(1);
3076     }
3077
3078     did_stuff = 0;
3079     info = open_pipes;
3080     while (info) {
3081       _ckvmssts_noperl(sys$setast(0));
3082       if (!info->done) { /* Tap them gently on the shoulder . . .*/
3083         sts = sys$forcex(&info->pid,0,&abort);
3084         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3085         did_stuff = 1;
3086       }
3087       _ckvmssts_noperl(sys$setast(1));
3088       info = info->next;
3089     }
3090
3091     /* again, wait for effect */
3092
3093     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3094         int nwait = 0;
3095
3096         info = open_pipes;
3097         while (info) {
3098           _ckvmssts_noperl(sys$setast(0));
3099           if (info->waiting && info->done)
3100                 info->waiting = 0;
3101           nwait += info->waiting;
3102           _ckvmssts_noperl(sys$setast(1));
3103           info = info->next;
3104         }
3105         if (!nwait) break;
3106         sleep(1);
3107     }
3108
3109     info = open_pipes;
3110     while (info) {
3111       _ckvmssts_noperl(sys$setast(0));
3112       if (!info->done) {  /* We tried to be nice . . . */
3113         sts = sys$delprc(&info->pid,0);
3114         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3115         info->done = 1;  /* sys$delprc is as done as we're going to get. */
3116       }
3117       _ckvmssts_noperl(sys$setast(1));
3118       info = info->next;
3119     }
3120
3121     while(open_pipes) {
3122
3123 #if defined(PERL_IMPLICIT_CONTEXT)
3124       /* We need to use the Perl context of the thread that created */
3125       /* the pipe. */
3126       pTHX;
3127       if (open_pipes->err)
3128           aTHX = open_pipes->err->thx;
3129       else if (open_pipes->out)
3130           aTHX = open_pipes->out->thx;
3131       else if (open_pipes->in)
3132           aTHX = open_pipes->in->thx;
3133 #endif
3134       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3135       else if (!(sts & 1)) retsts = sts;
3136     }
3137     return retsts;
3138 }
3139
3140 static struct exit_control_block pipe_exitblock =
3141        {(struct exit_control_block *) 0,
3142         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3143
3144 static void pipe_mbxtofd_ast(pPipe p);
3145 static void pipe_tochild1_ast(pPipe p);
3146 static void pipe_tochild2_ast(pPipe p);
3147
3148 static void
3149 popen_completion_ast(pInfo info)
3150 {
3151   pInfo i = open_pipes;
3152   int iss;
3153
3154   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3155   closed_list[closed_index].pid = info->pid;
3156   closed_list[closed_index].completion = info->completion;
3157   closed_index++;
3158   if (closed_index == NKEEPCLOSED)
3159     closed_index = 0;
3160   closed_num++;
3161
3162   while (i) {
3163     if (i == info) break;
3164     i = i->next;
3165   }
3166   if (!i) return;       /* unlinked, probably freed too */
3167
3168   info->done = TRUE;
3169
3170 /*
3171     Writing to subprocess ...
3172             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3173
3174             chan_out may be waiting for "done" flag, or hung waiting
3175             for i/o completion to child...cancel the i/o.  This will
3176             put it into "snarf mode" (done but no EOF yet) that discards
3177             input.
3178
3179     Output from subprocess (stdout, stderr) needs to be flushed and
3180     shut down.   We try sending an EOF, but if the mbx is full the pipe
3181     routine should still catch the "shut_on_empty" flag, telling it to
3182     use immediate-style reads so that "mbx empty" -> EOF.
3183
3184
3185 */
3186   if (info->in && !info->in_done) {               /* only for mode=w */
3187         if (info->in->shut_on_empty && info->in->need_wake) {
3188             info->in->need_wake = FALSE;
3189             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3190         } else {
3191             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3192         }
3193   }
3194
3195   if (info->out && !info->out_done) {             /* were we also piping output? */
3196       info->out->shut_on_empty = TRUE;
3197       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3198       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3199       _ckvmssts_noperl(iss);
3200   }
3201
3202   if (info->err && !info->err_done) {        /* we were piping stderr */
3203         info->err->shut_on_empty = TRUE;
3204         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3205         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3206         _ckvmssts_noperl(iss);
3207   }
3208   _ckvmssts_noperl(sys$setef(pipe_ef));
3209
3210 }
3211
3212 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3213 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3214 static void pipe_infromchild_ast(pPipe p);
3215
3216 /*
3217     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3218     inside an AST routine without worrying about reentrancy and which Perl
3219     memory allocator is being used.
3220
3221     We read data and queue up the buffers, then spit them out one at a
3222     time to the output mailbox when the output mailbox is ready for one.
3223
3224 */
3225 #define INITIAL_TOCHILDQUEUE  2
3226
3227 static pPipe
3228 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3229 {
3230     pPipe p;
3231     pCBuf b;
3232     char mbx1[64], mbx2[64];
3233     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3234                                       DSC$K_CLASS_S, mbx1},
3235                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3236                                       DSC$K_CLASS_S, mbx2};
3237     unsigned int dviitm = DVI$_DEVBUFSIZ;
3238     int j, n;
3239
3240     n = sizeof(Pipe);
3241     _ckvmssts_noperl(lib$get_vm(&n, &p));
3242
3243     create_mbx(&p->chan_in , &d_mbx1);
3244     create_mbx(&p->chan_out, &d_mbx2);
3245     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3246
3247     p->buf           = 0;
3248     p->shut_on_empty = FALSE;
3249     p->need_wake     = FALSE;
3250     p->type          = 0;
3251     p->retry         = 0;
3252     p->iosb.status   = SS$_NORMAL;
3253     p->iosb2.status  = SS$_NORMAL;
3254     p->free          = RQE_ZERO;
3255     p->wait          = RQE_ZERO;
3256     p->curr          = 0;
3257     p->curr2         = 0;
3258     p->info          = 0;
3259 #ifdef PERL_IMPLICIT_CONTEXT
3260     p->thx           = aTHX;
3261 #endif
3262
3263     n = sizeof(CBuf) + p->bufsize;
3264
3265     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3266         _ckvmssts_noperl(lib$get_vm(&n, &b));
3267         b->buf = (char *) b + sizeof(CBuf);
3268         _ckvmssts_noperl(lib$insqhi(b, &p->free));
3269     }
3270
3271     pipe_tochild2_ast(p);
3272     pipe_tochild1_ast(p);
3273     strcpy(wmbx, mbx1);
3274     strcpy(rmbx, mbx2);
3275     return p;
3276 }
3277
3278 /*  reads the MBX Perl is writing, and queues */
3279
3280 static void
3281 pipe_tochild1_ast(pPipe p)
3282 {
3283     pCBuf b = p->curr;
3284     int iss = p->iosb.status;
3285     int eof = (iss == SS$_ENDOFFILE);
3286     int sts;
3287 #ifdef PERL_IMPLICIT_CONTEXT
3288     pTHX = p->thx;
3289 #endif
3290
3291     if (p->retry) {
3292         if (eof) {
3293             p->shut_on_empty = TRUE;
3294             b->eof     = TRUE;
3295             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3296         } else  {
3297             _ckvmssts_noperl(iss);
3298         }
3299
3300         b->eof  = eof;
3301         b->size = p->iosb.count;
3302         _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3303         if (p->need_wake) {
3304             p->need_wake = FALSE;
3305             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3306         }
3307     } else {
3308         p->retry = 1;   /* initial call */
3309     }
3310
3311     if (eof) {                  /* flush the free queue, return when done */
3312         int n = sizeof(CBuf) + p->bufsize;
3313         while (1) {
3314             iss = lib$remqti(&p->free, &b);
3315             if (iss == LIB$_QUEWASEMP) return;
3316             _ckvmssts_noperl(iss);
3317             _ckvmssts_noperl(lib$free_vm(&n, &b));
3318         }
3319     }
3320
3321     iss = lib$remqti(&p->free, &b);
3322     if (iss == LIB$_QUEWASEMP) {
3323         int n = sizeof(CBuf) + p->bufsize;
3324         _ckvmssts_noperl(lib$get_vm(&n, &b));
3325         b->buf = (char *) b + sizeof(CBuf);
3326     } else {
3327        _ckvmssts_noperl(iss);
3328     }
3329
3330     p->curr = b;
3331     iss = sys$qio(0,p->chan_in,
3332              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3333              &p->iosb,
3334              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3335     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3336     _ckvmssts_noperl(iss);
3337 }
3338
3339
3340 /* writes queued buffers to output, waits for each to complete before
3341    doing the next */
3342
3343 static void
3344 pipe_tochild2_ast(pPipe p)
3345 {
3346     pCBuf b = p->curr2;
3347     int iss = p->iosb2.status;
3348     int n = sizeof(CBuf) + p->bufsize;
3349     int done = (p->info && p->info->done) ||
3350               iss == SS$_CANCEL || iss == SS$_ABORT;
3351 #if defined(PERL_IMPLICIT_CONTEXT)
3352     pTHX = p->thx;
3353 #endif
3354
3355     do {
3356         if (p->type) {         /* type=1 has old buffer, dispose */
3357             if (p->shut_on_empty) {
3358                 _ckvmssts_noperl(lib$free_vm(&n, &b));
3359             } else {
3360                 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3361             }
3362             p->type = 0;
3363         }
3364
3365         iss = lib$remqti(&p->wait, &b);
3366         if (iss == LIB$_QUEWASEMP) {
3367             if (p->shut_on_empty) {
3368                 if (done) {
3369                     _ckvmssts_noperl(sys$dassgn(p->chan_out));
3370                     *p->pipe_done = TRUE;
3371                     _ckvmssts_noperl(sys$setef(pipe_ef));
3372                 } else {
3373                     _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3374                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3375                 }
3376                 return;
3377             }
3378             p->need_wake = TRUE;
3379             return;
3380         }
3381         _ckvmssts_noperl(iss);
3382         p->type = 1;
3383     } while (done);
3384
3385
3386     p->curr2 = b;
3387     if (b->eof) {
3388         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3389             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3390     } else {
3391         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3392             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3393     }
3394
3395     return;
3396
3397 }
3398
3399
3400 static pPipe
3401 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3402 {
3403     pPipe p;
3404     char mbx1[64], mbx2[64];
3405     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3406                                       DSC$K_CLASS_S, mbx1},
3407                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3408                                       DSC$K_CLASS_S, mbx2};
3409     unsigned int dviitm = DVI$_DEVBUFSIZ;
3410
3411     int n = sizeof(Pipe);
3412     _ckvmssts_noperl(lib$get_vm(&n, &p));
3413     create_mbx(&p->chan_in , &d_mbx1);
3414     create_mbx(&p->chan_out, &d_mbx2);
3415
3416     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3417     n = p->bufsize * sizeof(char);
3418     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3419     p->shut_on_empty = FALSE;
3420     p->info   = 0;
3421     p->type   = 0;
3422     p->iosb.status = SS$_NORMAL;
3423 #if defined(PERL_IMPLICIT_CONTEXT)
3424     p->thx = aTHX;
3425 #endif
3426     pipe_infromchild_ast(p);
3427
3428     strcpy(wmbx, mbx1);
3429     strcpy(rmbx, mbx2);
3430     return p;
3431 }
3432
3433 static void
3434 pipe_infromchild_ast(pPipe p)
3435 {
3436     int iss = p->iosb.status;
3437     int eof = (iss == SS$_ENDOFFILE);
3438     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3439     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3440 #if defined(PERL_IMPLICIT_CONTEXT)
3441     pTHX = p->thx;
3442 #endif
3443
3444     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3445         _ckvmssts_noperl(sys$dassgn(p->chan_out));
3446         p->chan_out = 0;
3447     }
3448
3449     /* read completed:
3450             input shutdown if EOF from self (done or shut_on_empty)
3451             output shutdown if closing flag set (my_pclose)
3452             send data/eof from child or eof from self
3453             otherwise, re-read (snarf of data from child)
3454     */
3455
3456     if (p->type == 1) {
3457         p->type = 0;
3458         if (myeof && p->chan_in) {                  /* input shutdown */
3459             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3460             p->chan_in = 0;
3461         }
3462
3463         if (p->chan_out) {
3464             if (myeof || kideof) {      /* pass EOF to parent */
3465                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3466                                          pipe_infromchild_ast, p,
3467                                          0, 0, 0, 0, 0, 0));
3468                 return;
3469             } else if (eof) {       /* eat EOF --- fall through to read*/
3470
3471             } else {                /* transmit data */
3472                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3473                                          pipe_infromchild_ast,p,
3474                                          p->buf, p->iosb.count, 0, 0, 0, 0));
3475                 return;
3476             }
3477         }
3478     }
3479
3480     /*  everything shut? flag as done */
3481
3482     if (!p->chan_in && !p->chan_out) {
3483         *p->pipe_done = TRUE;
3484         _ckvmssts_noperl(sys$setef(pipe_ef));
3485         return;
3486     }
3487
3488     /* write completed (or read, if snarfing from child)
3489             if still have input active,
3490                queue read...immediate mode if shut_on_empty so we get EOF if empty
3491             otherwise,
3492                check if Perl reading, generate EOFs as needed
3493     */
3494
3495     if (p->type == 0) {
3496         p->type = 1;
3497         if (p->chan_in) {
3498             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3499                           pipe_infromchild_ast,p,
3500                           p->buf, p->bufsize, 0, 0, 0, 0);
3501             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3502             _ckvmssts_noperl(iss);
3503         } else {           /* send EOFs for extra reads */
3504             p->iosb.status = SS$_ENDOFFILE;
3505             p->iosb.dvispec = 0;
3506             _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3507                                      0, 0, 0,
3508                                      pipe_infromchild_ast, p, 0, 0, 0, 0));
3509         }
3510     }
3511 }
3512
3513 static pPipe
3514 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3515 {
3516     pPipe p;
3517     char mbx[64];
3518     unsigned long dviitm = DVI$_DEVBUFSIZ;
3519     struct stat s;
3520     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3521                                       DSC$K_CLASS_S, mbx};
3522     int n = sizeof(Pipe);
3523
3524     /* things like terminals and mbx's don't need this filter */
3525     if (fd && fstat(fd,&s) == 0) {
3526         unsigned long devchar;
3527         char device[65];
3528         unsigned short dev_len;
3529         struct dsc$descriptor_s d_dev;
3530         char * cptr;
3531         struct item_list_3 items[3];
3532         int status;
3533         unsigned short dvi_iosb[4];
3534
3535         cptr = getname(fd, out, 1);
3536         if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3537         d_dev.dsc$a_pointer = out;
3538         d_dev.dsc$w_length = strlen(out);
3539         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3540         d_dev.dsc$b_class = DSC$K_CLASS_S;
3541
3542         items[0].len = 4;
3543         items[0].code = DVI$_DEVCHAR;
3544         items[0].bufadr = &devchar;
3545         items[0].retadr = NULL;
3546         items[1].len = 64;
3547         items[1].code = DVI$_FULLDEVNAM;
3548         items[1].bufadr = device;
3549         items[1].retadr = &dev_len;
3550         items[2].len = 0;
3551         items[2].code = 0;
3552
3553         status = sys$getdviw
3554                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3555         _ckvmssts_noperl(status);
3556         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3557             device[dev_len] = 0;
3558
3559             if (!(devchar & DEV$M_DIR)) {
3560                 strcpy(out, device);
3561                 return 0;
3562             }
3563         }
3564     }
3565
3566     _ckvmssts_noperl(lib$get_vm(&n, &p));
3567     p->fd_out = dup(fd);
3568     create_mbx(&p->chan_in, &d_mbx);
3569     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3570     n = (p->bufsize+1) * sizeof(char);
3571     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3572     p->shut_on_empty = FALSE;
3573     p->retry = 0;
3574     p->info  = 0;
3575     strcpy(out, mbx);
3576
3577     _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3578                              pipe_mbxtofd_ast, p,
3579                              p->buf, p->bufsize, 0, 0, 0, 0));
3580
3581     return p;
3582 }
3583
3584 static void
3585 pipe_mbxtofd_ast(pPipe p)
3586 {
3587     int iss = p->iosb.status;
3588     int done = p->info->done;
3589     int iss2;
3590     int eof = (iss == SS$_ENDOFFILE);
3591     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3592     int err = !(iss&1) && !eof;
3593 #if defined(PERL_IMPLICIT_CONTEXT)
3594     pTHX = p->thx;
3595 #endif
3596
3597     if (done && myeof) {               /* end piping */
3598         close(p->fd_out);
3599         sys$dassgn(p->chan_in);
3600         *p->pipe_done = TRUE;
3601         _ckvmssts_noperl(sys$setef(pipe_ef));
3602         return;
3603     }
3604
3605     if (!err && !eof) {             /* good data to send to file */
3606         p->buf[p->iosb.count] = '\n';
3607         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3608         if (iss2 < 0) {
3609             p->retry++;
3610             if (p->retry < MAX_RETRY) {
3611                 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3612                 return;
3613             }
3614         }
3615         p->retry = 0;
3616     } else if (err) {
3617         _ckvmssts_noperl(iss);
3618     }
3619
3620
3621     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3622           pipe_mbxtofd_ast, p,
3623           p->buf, p->bufsize, 0, 0, 0, 0);
3624     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3625     _ckvmssts_noperl(iss);
3626 }
3627
3628
3629 typedef struct _pipeloc     PLOC;
3630 typedef struct _pipeloc*   pPLOC;
3631
3632 struct _pipeloc {
3633     pPLOC   next;
3634     char    dir[NAM$C_MAXRSS+1];
3635 };
3636 static pPLOC  head_PLOC = 0;
3637
3638 void
3639 free_pipelocs(pTHX_ void *head)
3640 {
3641     pPLOC p, pnext;
3642     pPLOC *pHead = (pPLOC *)head;
3643
3644     p = *pHead;
3645     while (p) {
3646         pnext = p->next;
3647         PerlMem_free(p);
3648         p = pnext;
3649     }
3650     *pHead = 0;
3651 }
3652
3653 static void
3654 store_pipelocs(pTHX)
3655 {
3656     int    i;
3657     pPLOC  p;
3658     AV    *av = 0;
3659     SV    *dirsv;
3660     char  *dir, *x;
3661     char  *unixdir;
3662     char  temp[NAM$C_MAXRSS+1];
3663     STRLEN n_a;
3664
3665     if (head_PLOC)
3666         free_pipelocs(aTHX_ &head_PLOC);
3667
3668 /*  the . directory from @INC comes last */
3669
3670     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3671     if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3672     p->next = head_PLOC;
3673     head_PLOC = p;
3674     strcpy(p->dir,"./");
3675
3676 /*  get the directory from $^X */
3677
3678     unixdir = (char *)PerlMem_malloc(VMS_MAXRSS);
3679     if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3680
3681 #ifdef PERL_IMPLICIT_CONTEXT
3682     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3683 #else
3684     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3685 #endif
3686         my_strlcpy(temp, PL_origargv[0], sizeof(temp));
3687         x = strrchr(temp,']');
3688         if (x == NULL) {
3689         x = strrchr(temp,'>');
3690           if (x == NULL) {
3691             /* It could be a UNIX path */
3692             x = strrchr(temp,'/');
3693           }
3694         }
3695         if (x)
3696           x[1] = '\0';
3697         else {
3698           /* Got a bare name, so use default directory */
3699           temp[0] = '.';
3700           temp[1] = '\0';
3701         }
3702
3703         if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3704             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3705             if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3706             p->next = head_PLOC;
3707             head_PLOC = p;
3708             my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3709         }
3710     }
3711
3712 /*  reverse order of @INC entries, skip "." since entered above */
3713
3714 #ifdef PERL_IMPLICIT_CONTEXT
3715     if (aTHX)
3716 #endif
3717     if (PL_incgv) av = GvAVn(PL_incgv);
3718
3719     for (i = 0; av && i <= AvFILL(av); i++) {
3720         dirsv = *av_fetch(av,i,TRUE);
3721
3722         if (SvROK(dirsv)) continue;
3723         dir = SvPVx(dirsv,n_a);
3724         if (strcmp(dir,".") == 0) continue;
3725         if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3726             continue;
3727
3728         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3729         p->next = head_PLOC;
3730         head_PLOC = p;
3731         my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3732     }
3733
3734 /* most likely spot (ARCHLIB) put first in the list */
3735
3736 #ifdef ARCHLIB_EXP
3737     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3738         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3739         if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3740         p->next = head_PLOC;
3741         head_PLOC = p;
3742         my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3743     }
3744 #endif
3745     PerlMem_free(unixdir);
3746 }
3747
3748 static I32 Perl_cando_by_name_int(pTHX_ I32 bit, bool effective,
3749                                   const char *fname, int opts);
3750 #if !defined(PERL_IMPLICIT_CONTEXT)
3751 #define cando_by_name_int               Perl_cando_by_name_int
3752 #else
3753 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3754 #endif
3755
3756 static char *
3757 find_vmspipe(pTHX)
3758 {
3759     static int   vmspipe_file_status = 0;
3760     static char  vmspipe_file[NAM$C_MAXRSS+1];
3761
3762     /* already found? Check and use ... need read+execute permission */
3763
3764     if (vmspipe_file_status == 1) {
3765         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3766          && cando_by_name_int
3767            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3768             return vmspipe_file;
3769         }
3770         vmspipe_file_status = 0;
3771     }
3772
3773     /* scan through stored @INC, $^X */
3774
3775     if (vmspipe_file_status == 0) {
3776         char file[NAM$C_MAXRSS+1];
3777         pPLOC  p = head_PLOC;
3778
3779         while (p) {
3780             char * exp_res;
3781             int dirlen;
3782             dirlen = my_strlcpy(file, p->dir, sizeof(file));
3783             my_strlcat(file, "vmspipe.com", sizeof(file));
3784             p = p->next;
3785
3786             exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3787             if (!exp_res) continue;
3788
3789             if (cando_by_name_int
3790                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3791              && cando_by_name_int
3792                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3793                 vmspipe_file_status = 1;
3794                 return vmspipe_file;
3795             }
3796         }
3797         vmspipe_file_status = -1;   /* failed, use tempfiles */
3798     }
3799
3800     return 0;
3801 }
3802
3803 static FILE *
3804 vmspipe_tempfile(pTHX)
3805 {
3806     char file[NAM$C_MAXRSS+1];
3807     FILE *fp;
3808     static int index = 0;
3809     Stat_t s0, s1;
3810     int cmp_result;
3811
3812     /* create a tempfile */
3813
3814     /* we can't go from   W, shr=get to  R, shr=get without
3815        an intermediate vulnerable state, so don't bother trying...
3816
3817        and lib$spawn doesn't shr=put, so have to close the write
3818
3819        So... match up the creation date/time and the FID to
3820        make sure we're dealing with the same file
3821
3822     */
3823
3824     index++;
3825     if (!decc_filename_unix_only) {
3826       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3827       fp = fopen(file,"w");
3828       if (!fp) {
3829         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3830         fp = fopen(file,"w");
3831         if (!fp) {
3832             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3833             fp = fopen(file,"w");
3834         }
3835       }
3836      }
3837      else {
3838       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3839       fp = fopen(file,"w");
3840       if (!fp) {
3841         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3842         fp = fopen(file,"w");
3843         if (!fp) {
3844           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3845           fp = fopen(file,"w");
3846         }
3847       }
3848     }
3849     if (!fp) return 0;  /* we're hosed */
3850
3851     fprintf(fp,"$! 'f$verify(0)'\n");
3852     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3853     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3854     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3855     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3856     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3857     fprintf(fp,"$ perl_del    = \"delete\"\n");
3858     fprintf(fp,"$ pif         = \"if\"\n");
3859     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3860     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3861     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3862     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3863     fprintf(fp,"$!  --- build command line to get max possible length\n");
3864     fprintf(fp,"$c=perl_popen_cmd0\n");
3865     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3866     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3867     fprintf(fp,"$x=perl_popen_cmd3\n");
3868     fprintf(fp,"$c=c+x\n");
3869     fprintf(fp,"$ perl_on\n");
3870     fprintf(fp,"$ 'c'\n");
3871     fprintf(fp,"$ perl_status = $STATUS\n");
3872     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3873     fprintf(fp,"$ perl_exit 'perl_status'\n");
3874     fsync(fileno(fp));
3875
3876     fgetname(fp, file, 1);
3877     fstat(fileno(fp), &s0.crtl_stat);
3878     fclose(fp);
3879
3880     if (decc_filename_unix_only)
3881         int_tounixspec(file, file, NULL);
3882     fp = fopen(file,"r","shr=get");
3883     if (!fp) return 0;
3884     fstat(fileno(fp), &s1.crtl_stat);
3885
3886     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3887     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3888         fclose(fp);
3889         return 0;
3890     }
3891
3892     return fp;
3893 }
3894
3895
3896 static int
3897 vms_is_syscommand_xterm(void)
3898 {
3899     const static struct dsc$descriptor_s syscommand_dsc =
3900       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3901
3902     const static struct dsc$descriptor_s decwdisplay_dsc =
3903       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3904
3905     struct item_list_3 items[2];
3906     unsigned short dvi_iosb[4];
3907     unsigned long devchar;
3908     unsigned long devclass;
3909     int status;
3910
3911     /* Very simple check to guess if sys$command is a decterm? */
3912     /* First see if the DECW$DISPLAY: device exists */
3913     items[0].len = 4;
3914     items[0].code = DVI$_DEVCHAR;
3915     items[0].bufadr = &devchar;
3916     items[0].retadr = NULL;
3917     items[1].len = 0;
3918     items[1].code = 0;
3919
3920     status = sys$getdviw
3921         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3922
3923     if ($VMS_STATUS_SUCCESS(status)) {
3924         status = dvi_iosb[0];
3925     }
3926
3927     if (!$VMS_STATUS_SUCCESS(status)) {
3928         SETERRNO(EVMSERR, status);
3929         return -1;
3930     }
3931
3932     /* If it does, then for now assume that we are on a workstation */
3933     /* Now verify that SYS$COMMAND is a terminal */
3934     /* for creating the debugger DECTerm */
3935
3936     items[0].len = 4;
3937     items[0].code = DVI$_DEVCLASS;
3938     items[0].bufadr = &devclass;
3939     items[0].retadr = NULL;
3940     items[1].len = 0;
3941     items[1].code = 0;
3942
3943     status = sys$getdviw
3944         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3945
3946     if ($VMS_STATUS_SUCCESS(status)) {
3947         status = dvi_iosb[0];
3948     }
3949
3950     if (!$VMS_STATUS_SUCCESS(status)) {
3951         SETERRNO(EVMSERR, status);
3952         return -1;
3953     }
3954     else {
3955         if (devclass == DC$_TERM) {
3956             return 0;
3957         }
3958     }
3959     return -1;
3960 }
3961
3962 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3963 static PerlIO*
3964 create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3965 {
3966     int status;
3967     int ret_stat;
3968     char * ret_char;
3969     char device_name[65];
3970     unsigned short device_name_len;
3971     struct dsc$descriptor_s customization_dsc;
3972     struct dsc$descriptor_s device_name_dsc;
3973     const char * cptr;
3974     char customization[200];
3975     char title[40];
3976     pInfo info = NULL;
3977     char mbx1[64];
3978     unsigned short p_chan;
3979     int n;
3980     unsigned short iosb[4];
3981     const char * cust_str =
3982         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3983     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3984                                           DSC$K_CLASS_S, mbx1};
3985
3986      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3987     /*---------------------------------------*/
3988     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
3989
3990
3991     /* Make sure that this is from the Perl debugger */
3992     ret_char = strstr(cmd," xterm ");
3993     if (ret_char == NULL)
3994         return NULL;
3995     cptr = ret_char + 7;
3996     ret_char = strstr(cmd,"tty");
3997     if (ret_char == NULL)
3998         return NULL;
3999     ret_char = strstr(cmd,"sleep");
4000     if (ret_char == NULL)
4001         return NULL;
4002
4003     if (decw_term_port == 0) {
4004         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
4005         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
4006         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
4007
4008        status = lib$find_image_symbol
4009                                (&filename1_dsc,
4010                                 &decw_term_port_dsc,
4011                                 (void *)&decw_term_port,
4012                                 NULL,
4013                                 0);
4014
4015         /* Try again with the other image name */
4016         if (!$VMS_STATUS_SUCCESS(status)) {
4017
4018            status = lib$find_image_symbol
4019                                (&filename2_dsc,
4020                                 &decw_term_port_dsc,
4021                                 (void *)&decw_term_port,
4022                                 NULL,
4023                                 0);
4024
4025         }
4026
4027     }
4028
4029
4030     /* No decw$term_port, give it up */
4031     if (!$VMS_STATUS_SUCCESS(status))
4032         return NULL;
4033
4034     /* Are we on a workstation? */
4035     /* to do: capture the rows / columns and pass their properties */
4036     ret_stat = vms_is_syscommand_xterm();
4037     if (ret_stat < 0)
4038         return NULL;
4039
4040     /* Make the title: */
4041     ret_char = strstr(cptr,"-title");
4042     if (ret_char != NULL) {
4043         while ((*cptr != 0) && (*cptr != '\"')) {
4044             cptr++;
4045         }
4046         if (*cptr == '\"')
4047             cptr++;
4048         n = 0;
4049         while ((*cptr != 0) && (*cptr != '\"')) {
4050             title[n] = *cptr;
4051             n++;
4052             if (n == 39) {
4053                 title[39] = 0;
4054                 break;
4055             }
4056             cptr++;
4057         }
4058         title[n] = 0;
4059     }
4060     else {
4061             /* Default title */
4062             strcpy(title,"Perl Debug DECTerm");
4063     }
4064     sprintf(customization, cust_str, title);
4065
4066     customization_dsc.dsc$a_pointer = customization;
4067     customization_dsc.dsc$w_length = strlen(customization);
4068     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4069     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
4070
4071     device_name_dsc.dsc$a_pointer = device_name;
4072     device_name_dsc.dsc$w_length = sizeof device_name -1;
4073     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4074     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
4075
4076     device_name_len = 0;
4077
4078     /* Try to create the window */
4079      status = (*decw_term_port)
4080        (NULL,
4081         NULL,
4082         &customization_dsc,
4083         &device_name_dsc,
4084         &device_name_len,
4085         NULL,
4086         NULL,
4087         NULL);
4088     if (!$VMS_STATUS_SUCCESS(status)) {
4089         SETERRNO(EVMSERR, status);
4090         return NULL;
4091     }
4092
4093     device_name[device_name_len] = '\0';
4094
4095     /* Need to set this up to look like a pipe for cleanup */
4096     n = sizeof(Info);
4097     status = lib$get_vm(&n, &info);
4098     if (!$VMS_STATUS_SUCCESS(status)) {
4099         SETERRNO(ENOMEM, status);
4100         return NULL;
4101     }
4102
4103     info->mode = *mode;
4104     info->done = FALSE;
4105     info->completion = 0;
4106     info->closing    = FALSE;
4107     info->in         = 0;
4108     info->out        = 0;
4109     info->err        = 0;
4110     info->fp         = NULL;
4111     info->useFILE    = 0;
4112     info->waiting    = 0;
4113     info->in_done    = TRUE;
4114     info->out_done   = TRUE;
4115     info->err_done   = TRUE;
4116
4117     /* Assign a channel on this so that it will persist, and not login */
4118     /* We stash this channel in the info structure for reference. */
4119     /* The created xterm self destructs when the last channel is removed */
4120     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4121     /* So leave this assigned. */
4122     device_name_dsc.dsc$w_length = device_name_len;
4123     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4124     if (!$VMS_STATUS_SUCCESS(status)) {
4125         SETERRNO(EVMSERR, status);
4126         return NULL;
4127     }
4128     info->xchan_valid = 1;
4129
4130     /* Now create a mailbox to be read by the application */
4131
4132     create_mbx(&p_chan, &d_mbx1);
4133
4134     /* write the name of the created terminal to the mailbox */
4135     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4136             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4137
4138     if (!$VMS_STATUS_SUCCESS(status)) {
4139         SETERRNO(EVMSERR, status);
4140         return NULL;
4141     }
4142
4143     info->fp  = PerlIO_open(mbx1, mode);
4144
4145     /* Done with this channel */
4146     sys$dassgn(p_chan);
4147
4148     /* If any errors, then clean up */
4149     if (!info->fp) {
4150         n = sizeof(Info);
4151         _ckvmssts_noperl(lib$free_vm(&n, &info));
4152         return NULL;
4153         }
4154
4155     /* All done */
4156     return info->fp;
4157 }
4158
4159 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4160
4161 static PerlIO *
4162 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4163 {
4164     static int handler_set_up = FALSE;
4165     PerlIO * ret_fp;
4166     unsigned long int sts, flags = CLI$M_NOWAIT;
4167     /* The use of a GLOBAL table (as was done previously) rendered
4168      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4169      * environment.  Hence we've switched to LOCAL symbol table.
4170      */
4171     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4172     int j, wait = 0, n;
4173     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4174     char *in, *out, *err, mbx[512];
4175     FILE *tpipe = 0;
4176     char tfilebuf[NAM$C_MAXRSS+1];
4177     pInfo info = NULL;
4178     char cmd_sym_name[20];
4179     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4180                                       DSC$K_CLASS_S, symbol};
4181     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4182                                       DSC$K_CLASS_S, 0};
4183     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4184                                       DSC$K_CLASS_S, cmd_sym_name};
4185     struct dsc$descriptor_s *vmscmd;
4186     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4187     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4188     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4189
4190     /* Check here for Xterm create request.  This means looking for
4191      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4192      *  is possible to create an xterm.
4193      */
4194     if (*in_mode == 'r') {
4195         PerlIO * xterm_fd;
4196
4197 #if defined(PERL_IMPLICIT_CONTEXT)
4198         /* Can not fork an xterm with a NULL context */
4199         /* This probably could never happen */
4200         xterm_fd = NULL;
4201         if (aTHX != NULL)
4202 #endif
4203         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4204         if (xterm_fd != NULL)
4205             return xterm_fd;
4206     }
4207
4208     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4209
4210     /* once-per-program initialization...
4211        note that the SETAST calls and the dual test of pipe_ef
4212        makes sure that only the FIRST thread through here does
4213        the initialization...all other threads wait until it's
4214        done.
4215
4216        Yeah, uglier than a pthread call, it's got all the stuff inline
4217        rather than in a separate routine.
4218     */
4219
4220     if (!pipe_ef) {
4221         _ckvmssts_noperl(sys$setast(0));
4222         if (!pipe_ef) {
4223             unsigned long int pidcode = JPI$_PID;
4224             $DESCRIPTOR(d_delay, RETRY_DELAY);
4225             _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4226             _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4227             _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4228         }
4229         if (!handler_set_up) {
4230           _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4231           handler_set_up = TRUE;
4232         }
4233         _ckvmssts_noperl(sys$setast(1));
4234     }
4235
4236     /* see if we can find a VMSPIPE.COM */
4237
4238     tfilebuf[0] = '@';
4239     vmspipe = find_vmspipe(aTHX);
4240     if (vmspipe) {
4241         vmspipedsc.dsc$w_length = my_strlcpy(tfilebuf+1, vmspipe, sizeof(tfilebuf)-1) + 1;
4242     } else {        /* uh, oh...we're in tempfile hell */
4243         tpipe = vmspipe_tempfile(aTHX);
4244         if (!tpipe) {       /* a fish popular in Boston */
4245             if (ckWARN(WARN_PIPE)) {
4246                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4247             }
4248         return NULL;
4249         }
4250         fgetname(tpipe,tfilebuf+1,1);
4251         vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4252     }
4253     vmspipedsc.dsc$a_pointer = tfilebuf;
4254
4255     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4256     if (!(sts & 1)) {
4257       switch (sts) {
4258         case RMS$_FNF:  case RMS$_DNF:
4259           set_errno(ENOENT); break;
4260         case RMS$_DIR:
4261           set_errno(ENOTDIR); break;
4262         case RMS$_DEV:
4263           set_errno(ENODEV); break;
4264         case RMS$_PRV:
4265           set_errno(EACCES); break;
4266         case RMS$_SYN:
4267           set_errno(EINVAL); break;
4268         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4269           set_errno(E2BIG); break;
4270         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4271           _ckvmssts_noperl(sts); /* fall through */
4272         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4273           set_errno(EVMSERR);
4274       }
4275       set_vaxc_errno(sts);
4276       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4277         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4278       }
4279       *psts = sts;
4280       return NULL;
4281     }
4282     n = sizeof(Info);
4283     _ckvmssts_noperl(lib$get_vm(&n, &info));
4284
4285     my_strlcpy(mode, in_mode, sizeof(mode));
4286     info->mode = *mode;
4287     info->done = FALSE;
4288     info->completion = 0;
4289     info->closing    = FALSE;
4290     info->in         = 0;
4291     info->out        = 0;
4292     info->err        = 0;
4293     info->fp         = NULL;
4294     info->useFILE    = 0;
4295     info->waiting    = 0;
4296     info->in_done    = TRUE;
4297     info->out_done   = TRUE;
4298     info->err_done   = TRUE;
4299     info->xchan      = 0;
4300     info->xchan_valid = 0;
4301
4302     in = (char *)PerlMem_malloc(VMS_MAXRSS);
4303     if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4304     out = (char *)PerlMem_malloc(VMS_MAXRSS);
4305     if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4306     err = (char *)PerlMem_malloc(VMS_MAXRSS);
4307     if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4308
4309     in[0] = out[0] = err[0] = '\0';
4310
4311     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4312         info->useFILE = 1;
4313         strcpy(p,p+1);
4314     }
4315     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4316         wait = 1;
4317         strcpy(p,p+1);
4318     }
4319
4320     if (*mode == 'r') {             /* piping from subroutine */
4321
4322         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4323         if (info->out) {
4324             info->out->pipe_done = &info->out_done;
4325             info->out_done = FALSE;
4326             info->out->info = info;
4327         }
4328         if (!info->useFILE) {
4329             info->fp  = PerlIO_open(mbx, mode);
4330         } else {
4331             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4332             vmssetuserlnm("SYS$INPUT", mbx);
4333         }
4334
4335         if (!info->fp && info->out) {
4336             sys$cancel(info->out->chan_out);
4337
4338             while (!info->out_done) {
4339                 int done;
4340                 _ckvmssts_noperl(sys$setast(0));
4341                 done = info->out_done;
4342                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4343                 _ckvmssts_noperl(sys$setast(1));
4344                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4345             }
4346
4347             if (info->out->buf) {
4348                 n = info->out->bufsize * sizeof(char);
4349                 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4350             }
4351             n = sizeof(Pipe);
4352             _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4353             n = sizeof(Info);
4354             _ckvmssts_noperl(lib$free_vm(&n, &info));
4355             *psts = RMS$_FNF;
4356             return NULL;
4357         }
4358
4359         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4360         if (info->err) {
4361             info->err->pipe_done = &info->err_done;
4362             info->err_done = FALSE;
4363             info->err->info = info;
4364         }
4365
4366     } else if (*mode == 'w') {      /* piping to subroutine */
4367
4368         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4369         if (info->out) {
4370             info->out->pipe_done = &info->out_done;
4371             info->out_done = FALSE;
4372             info->out->info = info;
4373         }
4374
4375         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4376         if (info->err) {
4377             info->err->pipe_done = &info->err_done;
4378             info->err_done = FALSE;
4379             info->err->info = info;
4380         }
4381
4382         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4383         if (!info->useFILE) {
4384             info->fp  = PerlIO_open(mbx, mode);
4385         } else {
4386             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4387             vmssetuserlnm("SYS$OUTPUT", mbx);
4388         }
4389
4390         if (info->in) {
4391             info->in->pipe_done = &info->in_done;
4392             info->in_done = FALSE;
4393             info->in->info = info;
4394         }
4395
4396         /* error cleanup */
4397         if (!info->fp && info->in) {
4398             info->done = TRUE;
4399             _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4400                                       0, 0, 0, 0, 0, 0, 0, 0));
4401
4402             while (!info->in_done) {
4403                 int done;
4404                 _ckvmssts_noperl(sys$setast(0));
4405                 done = info->in_done;
4406                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4407                 _ckvmssts_noperl(sys$setast(1));
4408                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4409             }
4410
4411             if (info->in->buf) {
4412                 n = info->in->bufsize * sizeof(char);
4413                 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4414             }
4415             n = sizeof(Pipe);
4416             _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4417             n = sizeof(Info);
4418             _ckvmssts_noperl(lib$free_vm(&n, &info));
4419             *psts = RMS$_FNF;
4420             return NULL;
4421         }
4422
4423
4424     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4425         /* Let the child inherit standard input, unless it's a directory. */
4426         Stat_t st;
4427         if (my_trnlnm("SYS$INPUT", in, 0)) {
4428             if (flex_stat(in, &st) != 0 || S_ISDIR(st.st_mode))
4429                 *in = '\0';
4430         }
4431
4432         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4433         if (info->out) {
4434             info->out->pipe_done = &info->out_done;
4435             info->out_done = FALSE;
4436             info->out->info = info;
4437         }
4438
4439         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4440         if (info->err) {
4441             info->err->pipe_done = &info->err_done;
4442             info->err_done = FALSE;
4443             info->err->info = info;
4444         }
4445     }
4446
4447     d_symbol.dsc$w_length = my_strlcpy(symbol, in, sizeof(symbol));
4448     _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4449
4450     d_symbol.dsc$w_length = my_strlcpy(symbol, err, sizeof(symbol));
4451     _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4452
4453     d_symbol.dsc$w_length = my_strlcpy(symbol, out, sizeof(symbol));
4454     _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4455
4456     /* Done with the names for the pipes */
4457     PerlMem_free(err);
4458     PerlMem_free(out);
4459     PerlMem_free(in);
4460
4461     p = vmscmd->dsc$a_pointer;
4462     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4463     if (*p == '$') p++;                         /* remove leading $ */
4464     while (*p == ' ' || *p == '\t') p++;
4465
4466     for (j = 0; j < 4; j++) {
4467         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4468         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4469
4470     d_symbol.dsc$w_length = my_strlcpy(symbol, p, sizeof(symbol));
4471     _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4472
4473         if (strlen(p) > MAX_DCL_SYMBOL) {
4474             p += MAX_DCL_SYMBOL;
4475         } else {
4476             p += strlen(p);
4477         }
4478     }
4479     _ckvmssts_noperl(sys$setast(0));
4480     info->next=open_pipes;  /* prepend to list */
4481     open_pipes=info;
4482     _ckvmssts_noperl(sys$setast(1));
4483     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4484      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4485      * have SYS$COMMAND if we need it.
4486      */
4487     _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4488                       0, &info->pid, &info->completion,
4489                       0, popen_completion_ast,info,0,0,0));
4490
4491     /* if we were using a tempfile, close it now */
4492
4493     if (tpipe) fclose(tpipe);
4494
4495     /* once the subprocess is spawned, it has copied the symbols and
4496        we can get rid of ours */
4497
4498     for (j = 0; j < 4; j++) {
4499         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4500         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4501     _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4502     }
4503     _ckvmssts_noperl(lib$delete_symbol(&d_sym_in,  &table));
4504     _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4505     _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4506     vms_execfree(vmscmd);
4507
4508 #ifdef PERL_IMPLICIT_CONTEXT
4509     if (aTHX)
4510 #endif
4511     PL_forkprocess = info->pid;
4512
4513     ret_fp = info->fp;
4514     if (wait) {
4515          dSAVEDERRNO;
4516          int done = 0;
4517          while (!done) {
4518              _ckvmssts_noperl(sys$setast(0));
4519              done = info->done;
4520              if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4521              _ckvmssts_noperl(sys$setast(1));
4522              if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4523          }
4524         *psts = info->completion;
4525 /* Caller thinks it is open and tries to close it. */
4526 /* This causes some problems, as it changes the error status */
4527 /*        my_pclose(info->fp); */
4528
4529          /* If we did not have a file pointer open, then we have to */
4530          /* clean up here or eventually we will run out of something */
4531          SAVE_ERRNO;
4532          if (info->fp == NULL) {
4533              my_pclose_pinfo(aTHX_ info);
4534          }
4535          RESTORE_ERRNO;
4536
4537     } else {
4538         *psts = info->pid;
4539     }
4540     return ret_fp;
4541 }  /* end of safe_popen */
4542
4543
4544 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4545 PerlIO *
4546 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4547 {
4548     int sts;
4549     TAINT_ENV();
4550     TAINT_PROPER("popen");
4551     PERL_FLUSHALL_FOR_CHILD;
4552     return safe_popen(aTHX_ cmd,mode,&sts);
4553 }
4554
4555 /*}}}*/
4556
4557
4558 /* Routine to close and cleanup a pipe info structure */
4559
4560 static I32
4561 my_pclose_pinfo(pTHX_ pInfo info) {
4562
4563     unsigned long int retsts;
4564     int done, n;
4565     pInfo next, last;
4566
4567     /* If we were writing to a subprocess, insure that someone reading from
4568      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4569      * produce an EOF record in the mailbox.
4570      *
4571      *  well, at least sometimes it *does*, so we have to watch out for
4572      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4573      */
4574      if (info->fp) {
4575         if (!info->useFILE
4576 #if defined(USE_ITHREADS)
4577           && my_perl
4578 #endif
4579 #ifdef USE_PERLIO
4580           && PL_perlio_fd_refcnt
4581 #endif
4582            )
4583             PerlIO_flush(info->fp);
4584         else
4585             fflush((FILE *)info->fp);
4586     }
4587
4588     _ckvmssts(sys$setast(0));
4589      info->closing = TRUE;
4590      done = info->done && info->in_done && info->out_done && info->err_done;
4591      /* hanging on write to Perl's input? cancel it */
4592      if (info->mode == 'r' && info->out && !info->out_done) {
4593         if (info->out->chan_out) {
4594             _ckvmssts(sys$cancel(info->out->chan_out));
4595             if (!info->out->chan_in) {   /* EOF generation, need AST */
4596                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4597             }
4598         }
4599      }
4600      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4601          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4602                            0, 0, 0, 0, 0, 0));
4603     _ckvmssts(sys$setast(1));
4604     if (info->fp) {
4605      if (!info->useFILE
4606 #if defined(USE_ITHREADS)
4607          && my_perl
4608 #endif
4609 #ifdef USE_PERLIO
4610          && PL_perlio_fd_refcnt
4611 #endif
4612         )
4613         PerlIO_close(info->fp);
4614      else
4615         fclose((FILE *)info->fp);
4616     }
4617      /*
4618         we have to wait until subprocess completes, but ALSO wait until all
4619         the i/o completes...otherwise we'll be freeing the "info" structure
4620         that the i/o ASTs could still be using...
4621      */
4622
4623      while (!done) {
4624          _ckvmssts(sys$setast(0));
4625          done = info->done && info->in_done && info->out_done && info->err_done;
4626          if (!done) _ckvmssts(sys$clref(pipe_ef));
4627          _ckvmssts(sys$setast(1));
4628          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4629      }
4630      retsts = info->completion;
4631
4632     /* remove from list of open pipes */
4633     _ckvmssts(sys$setast(0));
4634     last = NULL;
4635     for (next = open_pipes; next != NULL; last = next, next = next->next) {
4636         if (next == info)
4637             break;
4638     }
4639
4640     if (last)
4641         last->next = info->next;
4642     else
4643         open_pipes = info->next;
4644     _ckvmssts(sys$setast(1));
4645
4646     /* free buffers and structures */
4647
4648     if (info->in) {
4649         if (info->in->buf) {
4650             n = info->in->bufsize * sizeof(char);
4651             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4652         }
4653         n = sizeof(Pipe);
4654         _ckvmssts(lib$free_vm(&n, &info->in));
4655     }
4656     if (info->out) {
4657         if (info->out->buf) {
4658             n = info->out->bufsize * sizeof(char);
4659             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4660         }
4661         n = sizeof(Pipe);
4662         _ckvmssts(lib$free_vm(&n, &info->out));
4663     }
4664     if (info->err) {
4665         if (info->err->buf) {
4666             n = info->err->bufsize * sizeof(char);
4667             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4668         }
4669         n = sizeof(Pipe);
4670         _ckvmssts(lib$free_vm(&n, &info->err));
4671     }
4672     n = sizeof(Info);
4673     _ckvmssts(lib$free_vm(&n, &info));
4674
4675     return retsts;
4676 }
4677
4678
4679 /*{{{  I32 my_pclose(PerlIO *fp)*/
4680 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4681 {
4682     pInfo info, last = NULL;
4683     I32 ret_status;
4684
4685     /* Fixme - need ast and mutex protection here */
4686     for (info = open_pipes; info != NULL; last = info, info = info->next)
4687         if (info->fp == fp) break;
4688
4689     if (info == NULL) {  /* no such pipe open */
4690       set_errno(ECHILD); /* quoth POSIX */
4691       set_vaxc_errno(SS$_NONEXPR);
4692       return -1;
4693     }
4694
4695     ret_status = my_pclose_pinfo(aTHX_ info);
4696
4697     return ret_status;
4698
4699 }  /* end of my_pclose() */
4700
4701   /* Roll our own prototype because we want this regardless of whether
4702    * _VMS_WAIT is defined.
4703    */
4704
4705 #ifdef __cplusplus
4706 extern "C" {
4707 #endif
4708   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4709 #ifdef __cplusplus
4710 }
4711 #endif
4712
4713 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4714    created with popen(); otherwise partially emulate waitpid() unless
4715    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4716    Also check processes not considered by the CRTL waitpid().
4717  */
4718 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4719 Pid_t
4720 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4721 {
4722     pInfo info;
4723     int done;
4724     int sts;
4725     int j;
4726
4727     if (statusp) *statusp = 0;
4728
4729     for (info = open_pipes; info != NULL; info = info->next)
4730         if (info->pid == pid) break;
4731
4732     if (info != NULL) {  /* we know about this child */
4733       while (!info->done) {
4734           _ckvmssts(sys$setast(0));
4735           done = info->done;
4736           if (!done) _ckvmssts(sys$clref(pipe_ef));
4737           _ckvmssts(sys$setast(1));
4738           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4739       }
4740
4741       if (statusp) *statusp = info->completion;
4742       return pid;
4743     }
4744
4745     /* child that already terminated? */
4746
4747     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4748         if (closed_list[j].pid == pid) {
4749             if (statusp) *statusp = closed_list[j].completion;
4750             return pid;
4751         }
4752     }
4753
4754     /* fall through if this child is not one of our own pipe children */
4755
4756       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4757        * in 7.2 did we get a version that fills in the VMS completion
4758        * status as Perl has always tried to do.
4759        */
4760
4761       sts = __vms_waitpid( pid, statusp, flags );
4762
4763       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4764          return sts;
4765
4766       /* If the real waitpid tells us the child does not exist, we
4767        * fall through here to implement waiting for a child that
4768        * was created by some means other than exec() (say, spawned
4769        * from DCL) or to wait for a process that is not a subprocess
4770        * of the current process.
4771        */
4772
4773     {
4774       $DESCRIPTOR(intdsc,"0 00:00:01");
4775       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4776       unsigned long int pidcode = JPI$_PID, mypid;
4777       unsigned long int interval[2];
4778       unsigned int jpi_iosb[2];
4779       struct itmlst_3 jpilist[2] = {
4780           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4781           {                      0,         0,                 0, 0}
4782       };
4783
4784       if (pid <= 0) {
4785         /* Sorry folks, we don't presently implement rooting around for
4786            the first child we can find, and we definitely don't want to
4787            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4788          */
4789         set_errno(ENOTSUP);
4790         return -1;
4791       }
4792
4793       /* Get the owner of the child so I can warn if it's not mine. If the
4794        * process doesn't exist or I don't have the privs to look at it,
4795        * I can go home early.
4796        */
4797       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4798       if (sts & 1) sts = jpi_iosb[0];
4799       if (!(sts & 1)) {
4800         switch (sts) {
4801             case SS$_NONEXPR:
4802                 set_errno(ECHILD);
4803                 break;
4804             case SS$_NOPRIV:
4805                 set_errno(EACCES);
4806                 break;
4807             default:
4808                 _ckvmssts(sts);
4809         }
4810         set_vaxc_errno(sts);
4811         return -1;
4812       }
4813
4814       if (ckWARN(WARN_EXEC)) {
4815         /* remind folks they are asking for non-standard waitpid behavior */
4816         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4817         if (ownerpid != mypid)
4818           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4819                       "waitpid: process %x is not a child of process %x",
4820                       pid,mypid);
4821       }
4822
4823       /* simply check on it once a second until it's not there anymore. */
4824
4825       _ckvmssts(sys$bintim(&intdsc,interval));
4826       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4827             _ckvmssts(sys$schdwk(0,0,interval,0));
4828             _ckvmssts(sys$hiber());
4829       }
4830       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4831
4832       _ckvmssts(sts);
4833       return pid;
4834     }
4835 }  /* end of waitpid() */
4836 /*}}}*/
4837 /*}}}*/
4838 /*}}}*/
4839
4840 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4841 char *
4842 my_gconvert(double val, int ndig, int trail, char *buf)
4843 {
4844   static char __gcvtbuf[DBL_DIG+1];
4845   char *loc;
4846
4847   loc = buf ? buf : __gcvtbuf;
4848
4849   if (val) {
4850     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4851     return gcvt(val,ndig,loc);
4852   }
4853   else {
4854     loc[0] = '0'; loc[1] = '\0';
4855     return loc;
4856   }
4857
4858 }
4859 /*}}}*/
4860
4861 #if !defined(NAML$C_MAXRSS)
4862 static int
4863 rms_free_search_context(struct FAB * fab)
4864 {
4865     struct NAM * nam;
4866
4867     nam = fab->fab$l_nam;
4868     nam->nam$b_nop |= NAM$M_SYNCHK;
4869     nam->nam$l_rlf = NULL;
4870     fab->fab$b_dns = 0;
4871     return sys$parse(fab, NULL, NULL);
4872 }
4873
4874 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4875 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4876 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4877 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4878 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4879 #define rms_nam_esll(nam) nam.nam$b_esl
4880 #define rms_nam_esl(nam) nam.nam$b_esl
4881 #define rms_nam_name(nam) nam.nam$l_name
4882 #define rms_nam_namel(nam) nam.nam$l_name
4883 #define rms_nam_type(nam) nam.nam$l_type
4884 #define rms_nam_typel(nam) nam.nam$l_type
4885 #define rms_nam_ver(nam) nam.nam$l_ver
4886 #define rms_nam_verl(nam) nam.nam$l_ver
4887 #define rms_nam_rsll(nam) nam.nam$b_rsl
4888 #define rms_nam_rsl(nam) nam.nam$b_rsl
4889 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4890 #define rms_set_fna(fab, nam, name, size) \
4891         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4892 #define rms_get_fna(fab, nam) fab.fab$l_fna
4893 #define rms_set_dna(fab, nam, name, size) \
4894         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4895 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4896 #define rms_set_esa(nam, name, size) \
4897         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4898 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4899         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4900 #define rms_set_rsa(nam, name, size) \
4901         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4902 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4903         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4904 #define rms_nam_name_type_l_size(nam) \
4905         (nam.nam$b_name + nam.nam$b_type)
4906 #else
4907 static int
4908 rms_free_search_context(struct FAB * fab)
4909 {
4910     struct NAML * nam;
4911
4912     nam = fab->fab$l_naml;
4913     nam->naml$b_nop |= NAM$M_SYNCHK;
4914     nam->naml$l_rlf = NULL;
4915     nam->naml$l_long_defname_size = 0;
4916
4917     fab->fab$b_dns = 0;
4918     return sys$parse(fab, NULL, NULL);
4919 }
4920
4921 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4922 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4923 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4924 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4925 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4926 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4927 #define rms_nam_esl(nam) nam.naml$b_esl
4928 #define rms_nam_name(nam) nam.naml$l_name
4929 #define rms_nam_namel(nam) nam.naml$l_long_name
4930 #define rms_nam_type(nam) nam.naml$l_type
4931 #define rms_nam_typel(nam) nam.naml$l_long_type
4932 #define rms_nam_ver(nam) nam.naml$l_ver
4933 #define rms_nam_verl(nam) nam.naml$l_long_ver
4934 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4935 #define rms_nam_rsl(nam) nam.naml$b_rsl
4936 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4937 #define rms_set_fna(fab, nam, name, size) \
4938         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4939         nam.naml$l_long_filename_size = size; \
4940         nam.naml$l_long_filename = name;}
4941 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4942 #define rms_set_dna(fab, nam, name, size) \
4943         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4944         nam.naml$l_long_defname_size = size; \
4945         nam.naml$l_long_defname = name; }
4946 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4947 #define rms_set_esa(nam, name, size) \
4948         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4949         nam.naml$l_long_expand_alloc = size; \
4950         nam.naml$l_long_expand = name; }
4951 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4952         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4953         nam.naml$l_long_expand = l_name; \
4954         nam.naml$l_long_expand_alloc = l_size; }
4955 #define rms_set_rsa(nam, name, size) \
4956         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4957         nam.naml$l_long_result = name; \
4958         nam.naml$l_long_result_alloc = size; }
4959 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4960         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4961         nam.naml$l_long_result = l_name; \
4962         nam.naml$l_long_result_alloc = l_size; }
4963 #define rms_nam_name_type_l_size(nam) \
4964         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4965 #endif
4966
4967
4968 /* rms_erase
4969  * The CRTL for 8.3 and later can create symbolic links in any mode,
4970  * however in 8.3 the unlink/remove/delete routines will only properly handle
4971  * them if one of the PCP modes is active.
4972  */
4973 static int
4974 rms_erase(const char * vmsname)
4975 {
4976   int status;
4977   struct FAB myfab = cc$rms_fab;
4978   rms_setup_nam(mynam);
4979
4980   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4981   rms_bind_fab_nam(myfab, mynam);
4982
4983 #ifdef NAML$M_OPEN_SPECIAL
4984   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4985 #endif
4986
4987   status = sys$erase(&myfab, 0, 0);
4988
4989   return status;
4990 }
4991
4992
4993 static int
4994 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4995                     const struct dsc$descriptor_s * vms_dst_dsc,
4996                     unsigned long flags)
4997 {
4998     /*  VMS and UNIX handle file permissions differently and the
4999      * the same ACL trick may be needed for renaming files,
5000      * especially if they are directories.
5001      */
5002
5003    /* todo: get kill_file and rename to share common code */
5004    /* I can not find online documentation for $change_acl
5005     * it appears to be replaced by $set_security some time ago */
5006
5007     const unsigned int access_mode = 0;
5008     $DESCRIPTOR(obj_file_dsc,"FILE");
5009     char *vmsname;
5010     char *rslt;
5011     unsigned long int jpicode = JPI$_UIC;
5012     int aclsts, fndsts, rnsts = -1;
5013     unsigned int ctx = 0;
5014     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5015     struct dsc$descriptor_s * clean_dsc;
5016
5017     struct myacedef {
5018         unsigned char myace$b_length;
5019         unsigned char myace$b_type;
5020         unsigned short int myace$w_flags;
5021         unsigned long int myace$l_access;
5022         unsigned long int myace$l_ident;
5023     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
5024              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
5025              0},
5026              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
5027
5028     struct item_list_3
5029         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
5030                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
5031                       {0,0,0,0}},
5032         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
5033         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
5034                      {0,0,0,0}};
5035
5036
5037     /* Expand the input spec using RMS, since we do not want to put
5038      * ACLs on the target of a symbolic link */
5039     vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
5040     if (vmsname == NULL)
5041         return SS$_INSFMEM;
5042
5043     rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
5044                         vmsname,
5045                         PERL_RMSEXPAND_M_SYMLINK);
5046     if (rslt == NULL) {
5047         PerlMem_free(vmsname);
5048         return SS$_INSFMEM;
5049     }
5050
5051     /* So we get our own UIC to use as a rights identifier,
5052      * and the insert an ACE at the head of the ACL which allows us
5053      * to delete the file.
5054      */
5055     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
5056
5057     fildsc.dsc$w_length = strlen(vmsname);
5058     fildsc.dsc$a_pointer = vmsname;
5059     ctx = 0;
5060     newace.myace$l_ident = oldace.myace$l_ident;
5061     rnsts = SS$_ABORT;
5062
5063     /* Grab any existing ACEs with this identifier in case we fail */
5064     clean_dsc = &fildsc;
5065     aclsts = fndsts = sys$get_security(&obj_file_dsc,
5066                                &fildsc,
5067                                NULL,
5068                                OSS$M_WLOCK,
5069                                findlst,
5070                                &ctx,
5071                                &access_mode);
5072
5073     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
5074         /* Add the new ACE . . . */
5075
5076         /* if the sys$get_security succeeded, then ctx is valid, and the
5077          * object/file descriptors will be ignored.  But otherwise they
5078          * are needed
5079          */
5080         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
5081                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
5082         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5083             set_errno(EVMSERR);
5084             set_vaxc_errno(aclsts);
5085             PerlMem_free(vmsname);
5086             return aclsts;
5087         }
5088
5089         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5090                                 NULL, NULL,
5091                                 &flags,
5092                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5093
5094         if ($VMS_STATUS_SUCCESS(rnsts)) {
5095             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5096         }
5097
5098         /* Put things back the way they were. */
5099         ctx = 0;
5100         aclsts = sys$get_security(&obj_file_dsc,
5101                                   clean_dsc,
5102                                   NULL,
5103                                   OSS$M_WLOCK,
5104                                   findlst,
5105                                   &ctx,
5106                                   &access_mode);
5107
5108         if ($VMS_STATUS_SUCCESS(aclsts)) {
5109         int sec_flags;
5110
5111             sec_flags = 0;
5112             if (!$VMS_STATUS_SUCCESS(fndsts))
5113                 sec_flags = OSS$M_RELCTX;
5114
5115             /* Get rid of the new ACE */
5116             aclsts = sys$set_security(NULL, NULL, NULL,
5117                                   sec_flags, dellst, &ctx, &access_mode);
5118
5119             /* If there was an old ACE, put it back */
5120             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5121                 addlst[0].bufadr = &oldace;
5122                 aclsts = sys$set_security(NULL, NULL, NULL,
5123                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
5124                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5125                     set_errno(EVMSERR);
5126                     set_vaxc_errno(aclsts);
5127                     rnsts = aclsts;
5128                 }
5129             } else {
5130             int aclsts2;
5131
5132                 /* Try to clear the lock on the ACL list */
5133                 aclsts2 = sys$set_security(NULL, NULL, NULL,
5134                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
5135
5136                 /* Rename errors are most important */
5137                 if (!$VMS_STATUS_SUCCESS(rnsts))
5138                     aclsts = rnsts;
5139                 set_errno(EVMSERR);
5140                 set_vaxc_errno(aclsts);
5141                 rnsts = aclsts;
5142             }
5143         }
5144         else {
5145             if (aclsts != SS$_ACLEMPTY)
5146                 rnsts = aclsts;
5147         }
5148     }
5149     else
5150         rnsts = fndsts;
5151
5152     PerlMem_free(vmsname);
5153     return rnsts;
5154 }
5155
5156
5157 /*{{{int rename(const char *, const char * */
5158 /* Not exactly what X/Open says to do, but doing it absolutely right
5159  * and efficiently would require a lot more work.  This should be close
5160  * enough to pass all but the most strict X/Open compliance test.
5161  */
5162 int
5163 Perl_rename(pTHX_ const char *src, const char * dst)
5164 {
5165     int retval;
5166     int pre_delete = 0;
5167     int src_sts;
5168     int dst_sts;
5169     Stat_t src_st;
5170     Stat_t dst_st;
5171
5172     /* Validate the source file */
5173     src_sts = flex_lstat(src, &src_st);
5174     if (src_sts != 0) {
5175
5176         /* No source file or other problem */
5177         return src_sts;
5178     }
5179     if (src_st.st_devnam[0] == 0)  {
5180         /* This may be possible so fail if it is seen. */
5181         errno = EIO;
5182         return -1;
5183     }
5184
5185     dst_sts = flex_lstat(dst, &dst_st);
5186     if (dst_sts == 0) {
5187
5188         if (dst_st.st_dev != src_st.st_dev) {
5189             /* Must be on the same device */
5190             errno = EXDEV;
5191             return -1;
5192         }
5193
5194         /* VMS_INO_T_COMPARE is true if the inodes are different
5195          * to match the output of memcmp
5196          */
5197
5198         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5199             /* That was easy, the files are the same! */
5200             return 0;
5201         }
5202
5203         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5204             /* If source is a directory, so must be dest */
5205                 errno = EISDIR;
5206                 return -1;
5207         }
5208
5209     }
5210
5211
5212     if ((dst_sts == 0) &&
5213         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5214
5215         /* We have issues here if vms_unlink_all_versions is set
5216          * If the destination exists, and is not a directory, then
5217          * we must delete in advance.
5218          *
5219          * If the src is a directory, then we must always pre-delete
5220          * the destination.
5221          *
5222          * If we successfully delete the dst in advance, and the rename fails
5223          * X/Open requires that errno be EIO.
5224          *
5225          */
5226
5227         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5228             int d_sts;
5229             d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam,
5230                                      S_ISDIR(dst_st.st_mode));
5231
5232            /* Need to delete all versions ? */
5233            if ((d_sts == 0) && (vms_unlink_all_versions == 1)) {
5234                 int i = 0;
5235
5236                 while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) {
5237                     d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 0);
5238                     if (d_sts != 0)
5239                         break;
5240                     i++;
5241
5242                     /* Make sure that we do not loop forever */
5243                     if (i > 32767) {
5244                         errno = EIO;
5245                         d_sts = -1;
5246                         break;
5247                     }
5248                 }
5249            }
5250
5251             if (d_sts != 0)
5252                 return d_sts;
5253
5254             /* We killed the destination, so only errno now is EIO */
5255             pre_delete = 1;
5256         }
5257     }
5258
5259     /* Originally the idea was to call the CRTL rename() and only
5260      * try the lib$rename_file if it failed.
5261      * It turns out that there are too many variants in what the
5262      * the CRTL rename might do, so only use lib$rename_file
5263      */
5264     retval = -1;
5265
5266     {
5267         /* Is the source and dest both in VMS format */
5268         /* if the source is a directory, then need to fileify */
5269         /*  and dest must be a directory or non-existent. */
5270
5271         char * vms_dst;
5272         int sts;
5273         char * ret_str;
5274         unsigned long flags;
5275         struct dsc$descriptor_s old_file_dsc;
5276         struct dsc$descriptor_s new_file_dsc;
5277
5278         /* We need to modify the src and dst depending
5279          * on if one or more of them are directories.
5280          */
5281
5282         vms_dst = (char *)PerlMem_malloc(VMS_MAXRSS);
5283         if (vms_dst == NULL)
5284             _ckvmssts_noperl(SS$_INSFMEM);
5285
5286         if (S_ISDIR(src_st.st_mode)) {
5287         char * ret_str;
5288         char * vms_dir_file;
5289
5290             vms_dir_file = (char *)PerlMem_malloc(VMS_MAXRSS);
5291             if (vms_dir_file == NULL)
5292                 _ckvmssts_noperl(SS$_INSFMEM);
5293
5294             /* If the dest is a directory, we must remove it */
5295             if (dst_sts == 0) {
5296                 int d_sts;
5297                 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1);
5298                 if (d_sts != 0) {
5299                     PerlMem_free(vms_dst);
5300                     errno = EIO;
5301                     return d_sts;
5302                 }
5303
5304                 pre_delete = 1;
5305             }
5306
5307            /* The dest must be a VMS file specification */
5308            ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5309            if (ret_str == NULL) {
5310                 PerlMem_free(vms_dst);
5311                 errno = EIO;
5312                 return -1;
5313            }
5314
5315             /* The source must be a file specification */
5316             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5317             if (ret_str == NULL) {
5318                 PerlMem_free(vms_dst);
5319                 PerlMem_free(vms_dir_file);
5320                 errno = EIO;
5321                 return -1;
5322             }
5323             PerlMem_free(vms_dst);
5324             vms_dst = vms_dir_file;
5325
5326         } else {
5327             /* File to file or file to new dir */
5328
5329             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5330                 /* VMS pathify a dir target */
5331                 ret_str = int_tovmspath(dst, vms_dst, NULL);
5332                 if (ret_str == NULL) {
5333                     PerlMem_free(vms_dst);
5334                     errno = EIO;
5335                     return -1;
5336                 }
5337             } else {
5338                 char * v_spec, * r_spec, * d_spec, * n_spec;
5339                 char * e_spec, * vs_spec;
5340                 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5341
5342                 /* fileify a target VMS file specification */
5343                 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5344                 if (ret_str == NULL) {
5345                     PerlMem_free(vms_dst);
5346                     errno = EIO;
5347                     return -1;
5348                 }
5349
5350                 sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len,
5351                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5352                              &e_len, &vs_spec, &vs_len);
5353                 if (sts == 0) {
5354                      if (e_len == 0) {
5355                          /* Get rid of the version */
5356                          if (vs_len != 0) {
5357                              *vs_spec = '\0';
5358                          }
5359                          /* Need to specify a '.' so that the extension */
5360                          /* is not inherited */
5361                          strcat(vms_dst,".");
5362                      }
5363                 }
5364             }
5365         }
5366
5367         old_file_dsc.dsc$a_pointer = src_st.st_devnam;
5368         old_file_dsc.dsc$w_length = strlen(src_st.st_devnam);
5369         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5370         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5371
5372         new_file_dsc.dsc$a_pointer = vms_dst;
5373         new_file_dsc.dsc$w_length = strlen(vms_dst);
5374         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5375         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5376
5377         flags = 0;
5378 #if defined(NAML$C_MAXRSS)
5379         flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5380 #endif
5381
5382         sts = lib$rename_file(&old_file_dsc,
5383                               &new_file_dsc,
5384                               NULL, NULL,
5385                               &flags,
5386                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5387         if (!$VMS_STATUS_SUCCESS(sts)) {
5388
5389            /* We could have failed because VMS style permissions do not
5390             * permit renames that UNIX will allow.  Just like the hack
5391             * in for kill_file.
5392             */
5393            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5394         }
5395
5396         PerlMem_free(vms_dst);
5397         if (!$VMS_STATUS_SUCCESS(sts)) {
5398             errno = EIO;
5399             return -1;
5400         }
5401         retval = 0;
5402     }
5403
5404     if (vms_unlink_all_versions) {
5405         /* Now get rid of any previous versions of the source file that
5406          * might still exist
5407          */
5408         int i = 0;
5409         dSAVEDERRNO;
5410         SAVE_ERRNO;
5411         src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5412                                    S_ISDIR(src_st.st_mode));
5413         while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) {
5414              src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5415                                        S_ISDIR(src_st.st_mode));
5416              if (src_sts != 0)
5417                  break;
5418              i++;
5419
5420              /* Make sure that we do not loop forever */
5421              if (i > 32767) {
5422                  src_sts = -1;
5423                  break;
5424              }
5425         }
5426         RESTORE_ERRNO;
5427     }
5428
5429     /* We deleted the destination, so must force the error to be EIO */
5430     if ((retval != 0) && (pre_delete != 0))
5431         errno = EIO;
5432
5433     return retval;
5434 }
5435 /*}}}*/
5436
5437
5438 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5439 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5440  * to expand file specification.  Allows for a single default file
5441  * specification and a simple mask of options.  If outbuf is non-NULL,
5442  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5443  * the resultant file specification is placed.  If outbuf is NULL, the
5444  * resultant file specification is placed into a static buffer.
5445  * The third argument, if non-NULL, is taken to be a default file
5446  * specification string.  The fourth argument is unused at present.
5447  * rmesexpand() returns the address of the resultant string if
5448  * successful, and NULL on error.
5449  *
5450  * New functionality for previously unused opts value:
5451  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5452  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5453  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5454  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5455  */
5456 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5457
5458 static char *
5459 int_rmsexpand
5460    (const char *filespec,
5461     char *outbuf,
5462     const char *defspec,
5463     unsigned opts,
5464     int * fs_utf8,
5465     int * dfs_utf8)
5466 {
5467   char * ret_spec;
5468   const char * in_spec;
5469   char * spec_buf;
5470   const char * def_spec;
5471   char * vmsfspec, *vmsdefspec;
5472   char * esa;
5473   char * esal = NULL;
5474   char * outbufl;
5475   struct FAB myfab = cc$rms_fab;
5476   rms_setup_nam(mynam);
5477   STRLEN speclen;
5478   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5479   int sts;
5480
5481   /* temp hack until UTF8 is actually implemented */
5482   if (fs_utf8 != NULL)
5483     *fs_utf8 = 0;
5484
5485   if (!filespec || !*filespec) {
5486     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5487     return NULL;
5488   }
5489
5490   vmsfspec = NULL;
5491   vmsdefspec = NULL;
5492   outbufl = NULL;
5493
5494   in_spec = filespec;
5495   isunix = 0;
5496   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5497       char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5498       int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5499
5500       /* If this is a UNIX file spec, convert it to VMS */
5501       sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5502                            &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5503                            &e_len, &vs_spec, &vs_len);
5504       if (sts != 0) {
5505           isunix = 1;
5506           char * ret_spec;
5507
5508           vmsfspec = (char *)PerlMem_malloc(VMS_MAXRSS);
5509           if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5510           ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5511           if (ret_spec == NULL) {
5512               PerlMem_free(vmsfspec);
5513               return NULL;
5514           }
5515           in_spec = (const char *)vmsfspec;
5516
5517           /* Unless we are forcing to VMS format, a UNIX input means
5518            * UNIX output, and that requires long names to be used
5519            */
5520           if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5521 #if defined(NAML$C_MAXRSS)
5522               opts |= PERL_RMSEXPAND_M_LONG;
5523 #else
5524               NOOP;
5525 #endif
5526           else
5527               isunix = 0;
5528       }
5529
5530   }
5531
5532   rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
5533   rms_bind_fab_nam(myfab, mynam);
5534
5535   /* Process the default file specification if present */
5536   def_spec = defspec;
5537   if (defspec && *defspec) {
5538     int t_isunix;
5539     t_isunix = is_unix_filespec(defspec);
5540     if (t_isunix) {
5541       vmsdefspec = (char *)PerlMem_malloc(VMS_MAXRSS);
5542       if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5543       ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5544
5545       if (ret_spec == NULL) {
5546           /* Clean up and bail */
5547           PerlMem_free(vmsdefspec);
5548           if (vmsfspec != NULL)
5549               PerlMem_free(vmsfspec);
5550               return NULL;
5551           }
5552           def_spec = (const char *)vmsdefspec;
5553       }
5554       rms_set_dna(myfab, mynam,
5555                   (char *)def_spec, strlen(def_spec)); /* cast ok */
5556   }
5557
5558   /* Now we need the expansion buffers */
5559   esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
5560   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5561 #if defined(NAML$C_MAXRSS)
5562   esal = (char *)PerlMem_malloc(VMS_MAXRSS);
5563   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5564 #endif
5565   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5566
5567   /* If a NAML block is used RMS always writes to the long and short
5568    * addresses unless you suppress the short name.
5569    */
5570 #if defined(NAML$C_MAXRSS)
5571   outbufl = (char *)PerlMem_malloc(VMS_MAXRSS);
5572   if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5573 #endif
5574    rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5575
5576 #ifdef NAM$M_NO_SHORT_UPCASE
5577   if (decc_efs_case_preserve)
5578     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5579 #endif
5580
5581    /* We may not want to follow symbolic links */
5582 #ifdef NAML$M_OPEN_SPECIAL
5583   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5584     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5585 #endif
5586
5587   /* First attempt to parse as an existing file */
5588   retsts = sys$parse(&myfab,0,0);
5589   if (!(retsts & STS$K_SUCCESS)) {
5590
5591     /* Could not find the file, try as syntax only if error is not fatal */
5592     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5593     if (retsts == RMS$_DNF ||
5594         retsts == RMS$_DIR ||
5595         retsts == RMS$_DEV ||
5596         retsts == RMS$_PRV) {
5597       retsts = sys$parse(&myfab,0,0);
5598       if (retsts & STS$K_SUCCESS) goto int_expanded;
5599     }
5600
5601      /* Still could not parse the file specification */
5602     /*----------------------------------------------*/
5603     sts = rms_free_search_context(&myfab); /* Free search context */
5604     if (vmsdefspec != NULL)
5605         PerlMem_free(vmsdefspec);
5606     if (vmsfspec != NULL)
5607         PerlMem_free(vmsfspec);
5608     if (outbufl != NULL)
5609         PerlMem_free(outbufl);
5610     PerlMem_free(esa);
5611     if (esal != NULL)
5612         PerlMem_free(esal);
5613     set_vaxc_errno(retsts);
5614     if      (retsts == RMS$_PRV) set_errno(EACCES);
5615     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5616     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5617     else                         set_errno(EVMSERR);
5618     return NULL;
5619   }
5620   retsts = sys$search(&myfab,0,0);
5621   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5622     sts = rms_free_search_context(&myfab); /* Free search context */
5623     if (vmsdefspec != NULL)
5624         PerlMem_free(vmsdefspec);
5625     if (vmsfspec != NULL)
5626         PerlMem_free(vmsfspec);
5627     if (outbufl != NULL)
5628         PerlMem_free(outbufl);
5629     PerlMem_free(esa);
5630     if (esal != NULL)
5631         PerlMem_free(esal);
5632     set_vaxc_errno(retsts);
5633     if      (retsts == RMS$_PRV) set_errno(EACCES);
5634     else                         set_errno(EVMSERR);
5635     return NULL;
5636   }
5637
5638   /* If the input filespec contained any lowercase characters,
5639    * downcase the result for compatibility with Unix-minded code. */
5640 int_expanded:
5641   if (!decc_efs_case_preserve) {
5642     char * tbuf;
5643     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5644       if (islower(*tbuf)) { haslower = 1; break; }
5645   }
5646
5647    /* Is a long or a short name expected */
5648   /*------------------------------------*/
5649   spec_buf = NULL;
5650 #if defined(NAML$C_MAXRSS)
5651   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5652     if (rms_nam_rsll(mynam)) {
5653         spec_buf = outbufl;
5654         speclen = rms_nam_rsll(mynam);
5655     }
5656     else {
5657         spec_buf = esal; /* Not esa */
5658         speclen = rms_nam_esll(mynam);
5659     }
5660   }
5661   else {
5662 #endif
5663     if (rms_nam_rsl(mynam)) {
5664         spec_buf = outbuf;
5665         speclen = rms_nam_rsl(mynam);
5666     }
5667     else {
5668         spec_buf = esa; /* Not esal */
5669         speclen = rms_nam_esl(mynam);
5670     }
5671 #if defined(NAML$C_MAXRSS)
5672   }
5673 #endif
5674   spec_buf[speclen] = '\0';
5675
5676   /* Trim off null fields added by $PARSE
5677    * If type > 1 char, must have been specified in original or default spec
5678    * (not true for version; $SEARCH may have added version of existing file).
5679    */
5680   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5681   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5682     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5683              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5684   }
5685   else {
5686     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5687              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5688   }
5689   if (trimver || trimtype) {
5690     if (defspec && *defspec) {
5691       char *defesal = NULL;
5692       char *defesa = NULL;
5693       defesa = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5694       if (defesa != NULL) {
5695         struct FAB deffab = cc$rms_fab;
5696 #if defined(NAML$C_MAXRSS)
5697         defesal = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5698         if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5699 #endif
5700         rms_setup_nam(defnam);
5701
5702         rms_bind_fab_nam(deffab, defnam);
5703
5704         /* Cast ok */
5705         rms_set_fna
5706             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5707
5708         /* RMS needs the esa/esal as a work area if wildcards are involved */
5709         rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5710
5711         rms_clear_nam_nop(defnam);
5712         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5713 #ifdef NAM$M_NO_SHORT_UPCASE
5714         if (decc_efs_case_preserve)
5715           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5716 #endif
5717 #ifdef NAML$M_OPEN_SPECIAL
5718         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5719           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5720 #endif
5721         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5722           if (trimver) {
5723              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5724           }
5725           if (trimtype) {
5726             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5727           }
5728         }
5729         if (defesal != NULL)
5730             PerlMem_free(defesal);
5731         PerlMem_free(defesa);
5732       } else {
5733           _ckvmssts_noperl(SS$_INSFMEM);
5734       }
5735     }
5736     if (trimver) {
5737       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5738         if (*(rms_nam_verl(mynam)) != '\"')
5739           speclen = rms_nam_verl(mynam) - spec_buf;
5740       }
5741       else {
5742         if (*(rms_nam_ver(mynam)) != '\"')
5743           speclen = rms_nam_ver(mynam) - spec_buf;
5744       }
5745     }
5746     if (trimtype) {
5747       /* If we didn't already trim version, copy down */
5748       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5749         if (speclen > rms_nam_verl(mynam) - spec_buf)
5750           memmove
5751            (rms_nam_typel(mynam),
5752             rms_nam_verl(mynam),
5753             speclen - (rms_nam_verl(mynam) - spec_buf));
5754           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5755       }
5756       else {
5757         if (speclen > rms_nam_ver(mynam) - spec_buf)
5758           memmove
5759            (rms_nam_type(mynam),
5760             rms_nam_ver(mynam),
5761             speclen - (rms_nam_ver(mynam) - spec_buf));
5762           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5763       }
5764     }
5765   }
5766
5767    /* Done with these copies of the input files */
5768   /*-------------------------------------------*/
5769   if (vmsfspec != NULL)
5770         PerlMem_free(vmsfspec);
5771   if (vmsdefspec != NULL)
5772         PerlMem_free(vmsdefspec);
5773
5774   /* If we just had a directory spec on input, $PARSE "helpfully"
5775    * adds an empty name and type for us */
5776 #if defined(NAML$C_MAXRSS)
5777   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5778     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5779         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5780         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5781       speclen = rms_nam_namel(mynam) - spec_buf;
5782   }
5783   else
5784 #endif
5785   {
5786     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5787         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5788         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5789       speclen = rms_nam_name(mynam) - spec_buf;
5790   }
5791
5792   /* Posix format specifications must have matching quotes */
5793   if (speclen < (VMS_MAXRSS - 1)) {
5794     if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5795       if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5796         spec_buf[speclen] = '\"';
5797         speclen++;
5798       }
5799     }
5800   }
5801   spec_buf[speclen] = '\0';
5802   if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
5803
5804   /* Have we been working with an expanded, but not resultant, spec? */
5805   /* Also, convert back to Unix syntax if necessary. */
5806   {
5807   int rsl;
5808
5809 #if defined(NAML$C_MAXRSS)
5810     if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5811       rsl = rms_nam_rsll(mynam);
5812     } else
5813 #endif
5814     {
5815       rsl = rms_nam_rsl(mynam);
5816     }
5817     if (!rsl) {
5818       /* rsl is not present, it means that spec_buf is either */
5819       /* esa or esal, and needs to be copied to outbuf */
5820       /* convert to Unix if desired */
5821       if (isunix) {
5822         ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5823       } else {
5824         /* VMS file specs are not in UTF-8 */
5825         if (fs_utf8 != NULL)
5826             *fs_utf8 = 0;
5827         my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
5828         ret_spec = outbuf;
5829       }
5830     }
5831     else {
5832       /* Now spec_buf is either outbuf or outbufl */
5833       /* We need the result into outbuf */
5834       if (isunix) {
5835            /* If we need this in UNIX, then we need another buffer */
5836            /* to keep things in order */
5837            char * src;
5838            char * new_src = NULL;
5839            if (spec_buf == outbuf) {
5840                new_src = (char *)PerlMem_malloc(VMS_MAXRSS);
5841                my_strlcpy(new_src, spec_buf, VMS_MAXRSS);
5842            } else {
5843                src = spec_buf;
5844            }
5845            ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5846            if (new_src) {
5847                PerlMem_free(new_src);
5848            }
5849       } else {
5850            /* VMS file specs are not in UTF-8 */
5851            if (fs_utf8 != NULL)
5852                *fs_utf8 = 0;
5853
5854            /* Copy the buffer if needed */
5855            if (outbuf != spec_buf)
5856                my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
5857            ret_spec = outbuf;
5858       }
5859     }
5860   }
5861
5862   /* Need to clean up the search context */
5863   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5864   sts = rms_free_search_context(&myfab); /* Free search context */
5865
5866   /* Clean up the extra buffers */
5867   if (esal != NULL)
5868       PerlMem_free(esal);
5869   PerlMem_free(esa);
5870   if (outbufl != NULL)
5871      PerlMem_free(outbufl);
5872
5873   /* Return the result */
5874   return ret_spec;
5875 }
5876
5877 /* Common simple case - Expand an already VMS spec */
5878 static char *
5879 int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5880     opts |= PERL_RMSEXPAND_M_VMS_IN;
5881     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5882 }
5883
5884 /* Common simple case - Expand to a VMS spec */
5885 static char *
5886 int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5887     opts |= PERL_RMSEXPAND_M_VMS;
5888     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5889 }
5890
5891
5892 /* Entry point used by perl routines */
5893 static char *
5894 mp_do_rmsexpand
5895    (pTHX_ const char *filespec,
5896     char *outbuf,
5897     int ts,
5898     const char *defspec,
5899     unsigned opts,
5900     int * fs_utf8,
5901     int * dfs_utf8)
5902 {
5903     static char __rmsexpand_retbuf[VMS_MAXRSS];
5904     char * expanded, *ret_spec, *ret_buf;
5905
5906     expanded = NULL;
5907     ret_buf = outbuf;
5908     if (ret_buf == NULL) {
5909         if (ts) {
5910             Newx(expanded, VMS_MAXRSS, char);
5911             if (expanded == NULL)
5912                 _ckvmssts(SS$_INSFMEM);
5913             ret_buf = expanded;
5914         } else {
5915             ret_buf = __rmsexpand_retbuf;
5916         }
5917     }
5918
5919
5920     ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
5921                              opts, fs_utf8,  dfs_utf8);
5922
5923     if (ret_spec == NULL) {
5924        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
5925        if (expanded)
5926            Safefree(expanded);
5927     }
5928
5929     return ret_spec;
5930 }
5931 /*}}}*/
5932 /* External entry points */
5933 char *
5934 Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5935 {
5936     return do_rmsexpand(spec, buf, 0, def, opt, NULL, NULL);
5937 }
5938
5939 char *
5940 Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5941 {
5942     return do_rmsexpand(spec, buf, 1, def, opt, NULL, NULL);
5943 }
5944
5945 char *
5946 Perl_rmsexpand_utf8(pTHX_ const char *spec, char *buf, const char *def,
5947                     unsigned opt, int * fs_utf8, int * dfs_utf8)
5948 {
5949     return do_rmsexpand(spec, buf, 0, def, opt, fs_utf8, dfs_utf8);
5950 }
5951
5952 char *
5953 Perl_rmsexpand_utf8_ts(pTHX_ const char *spec, char *buf, const char *def,
5954                        unsigned opt, int * fs_utf8, int * dfs_utf8)
5955 {
5956     return do_rmsexpand(spec, buf, 1, def, opt, fs_utf8, dfs_utf8);
5957 }
5958
5959
5960 /*
5961 ** The following routines are provided to make life easier when
5962 ** converting among VMS-style and Unix-style directory specifications.
5963 ** All will take input specifications in either VMS or Unix syntax. On
5964 ** failure, all return NULL.  If successful, the routines listed below
5965 ** return a pointer to a buffer containing the appropriately
5966 ** reformatted spec (and, therefore, subsequent calls to that routine
5967 ** will clobber the result), while the routines of the same names with
5968 ** a _ts suffix appended will return a pointer to a mallocd string
5969 ** containing the appropriately reformatted spec.
5970 ** In all cases, only explicit syntax is altered; no check is made that
5971 ** the resulting string is valid or that the directory in question
5972 ** actually exists.
5973 **
5974 **   fileify_dirspec() - convert a directory spec into the name of the
5975 **     directory file (i.e. what you can stat() to see if it's a dir).
5976 **     The style (VMS or Unix) of the result is the same as the style
5977 **     of the parameter passed in.
5978 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5979 **     what you prepend to a filename to indicate what directory it's in).
5980 **     The style (VMS or Unix) of the result is the same as the style
5981 **     of the parameter passed in.
5982 **   tounixpath() - convert a directory spec into a Unix-style path.
5983 **   tovmspath() - convert a directory spec into a VMS-style path.
5984 **   tounixspec() - convert any file spec into a Unix-style file spec.
5985 **   tovmsspec() - convert any file spec into a VMS-style spec.
5986 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5987 **
5988 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5989 ** Permission is given to distribute this code as part of the Perl
5990 ** standard distribution under the terms of the GNU General Public
5991 ** License or the Perl Artistic License.  Copies of each may be
5992 ** found in the Perl standard distribution.
5993  */
5994
5995 /*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5996 static char *
5997 int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
5998 {
5999     unsigned long int dirlen, retlen, hasfilename = 0;
6000     char *cp1, *cp2, *lastdir;
6001     char *trndir, *vmsdir;
6002     unsigned short int trnlnm_iter_count;
6003     int sts;
6004     if (utf8_fl != NULL)
6005         *utf8_fl = 0;
6006
6007     if (!dir || !*dir) {
6008       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6009     }
6010     dirlen = strlen(dir);
6011     while (dirlen && dir[dirlen-1] == '/') --dirlen;
6012     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
6013       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
6014         dir = "/sys$disk";
6015         dirlen = 9;
6016       }
6017       else
6018         dirlen = 1;
6019     }
6020     if (dirlen > (VMS_MAXRSS - 1)) {
6021       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
6022       return NULL;
6023     }
6024     trndir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
6025     if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6026     if (!strpbrk(dir+1,"/]>:")  &&
6027         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
6028       strcpy(trndir,*dir == '/' ? dir + 1: dir);
6029       trnlnm_iter_count = 0;
6030       while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
6031         trnlnm_iter_count++;
6032         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6033       }
6034       dirlen = strlen(trndir);
6035     }
6036     else {
6037       memcpy(trndir, dir, dirlen);
6038       trndir[dirlen] = '\0';
6039     }
6040
6041     /* At this point we are done with *dir and use *trndir which is a
6042      * copy that can be modified.  *dir must not be modified.
6043      */
6044
6045     /* If we were handed a rooted logical name or spec, treat it like a
6046      * simple directory, so that
6047      *    $ Define myroot dev:[dir.]
6048      *    ... do_fileify_dirspec("myroot",buf,1) ...
6049      * does something useful.
6050      */
6051     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
6052       trndir[--dirlen] = '\0';
6053       trndir[dirlen-1] = ']';
6054     }
6055     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
6056       trndir[--dirlen] = '\0';
6057       trndir[dirlen-1] = '>';
6058     }
6059
6060     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
6061       /* If we've got an explicit filename, we can just shuffle the string. */
6062       if (*(cp1+1)) hasfilename = 1;
6063       /* Similarly, we can just back up a level if we've got multiple levels
6064          of explicit directories in a VMS spec which ends with directories. */
6065       else {
6066         for (cp2 = cp1; cp2 > trndir; cp2--) {
6067           if (*cp2 == '.') {
6068             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
6069 /* fix-me, can not scan EFS file specs backward like this */
6070               *cp2 = *cp1; *cp1 = '\0';
6071               hasfilename = 1;
6072               break;
6073             }
6074           }
6075           if (*cp2 == '[' || *cp2 == '<') break;
6076         }
6077       }
6078     }
6079
6080     vmsdir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
6081     if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6082     cp1 = strpbrk(trndir,"]:>");
6083     if (cp1 && *(cp1+1) == ':')   /* DECNet node spec with :: */
6084         cp1 = strpbrk(cp1+2,"]:>");
6085
6086     if (hasfilename || !cp1) { /* filename present or not VMS */
6087
6088       if (trndir[0] == '.') {
6089         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
6090           PerlMem_free(trndir);
6091           PerlMem_free(vmsdir);
6092           return int_fileify_dirspec("[]", buf, NULL);
6093         }
6094         else if (trndir[1] == '.' &&
6095                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
6096           PerlMem_free(trndir);
6097           PerlMem_free(vmsdir);
6098           return int_fileify_dirspec("[-]", buf, NULL);
6099         }
6100       }
6101       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
6102         dirlen -= 1;                 /* to last element */
6103         lastdir = strrchr(trndir,'/');
6104       }
6105       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
6106         /* If we have "/." or "/..", VMSify it and let the VMS code
6107          * below expand it, rather than repeating the code to handle
6108          * relative components of a filespec here */
6109         do {
6110           if (*(cp1+2) == '.') cp1++;
6111           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
6112             char * ret_chr;
6113             if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
6114                 PerlMem_free(trndir);
6115                 PerlMem_free(vmsdir);
6116                 return NULL;
6117             }
6118             if (strchr(vmsdir,'/') != NULL) {
6119               /* If int_tovmsspec() returned it, it must have VMS syntax
6120                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
6121                * the time to check this here only so we avoid a recursion
6122                * loop; otherwise, gigo.
6123                */
6124               PerlMem_free(trndir);
6125               PerlMem_free(vmsdir);
6126               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
6127               return NULL;
6128             }
6129             if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6130                 PerlMem_free(trndir);
6131                 PerlMem_free(vmsdir);
6132                 return NULL;
6133             }
6134             ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6135             PerlMem_free(trndir);
6136             PerlMem_free(vmsdir);
6137             return ret_chr;
6138           }
6139           cp1++;
6140         } while ((cp1 = strstr(cp1,"/.")) != NULL);
6141         lastdir = strrchr(trndir,'/');
6142       }
6143       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
6144         char * ret_chr;
6145         /* Ditto for specs that end in an MFD -- let the VMS code
6146          * figure out whether it's a real device or a rooted logical. */
6147
6148         /* This should not happen any more.  Allowing the fake /000000
6149          * in a UNIX pathname causes all sorts of problems when trying
6150          * to run in UNIX emulation.  So the VMS to UNIX conversions
6151          * now remove the fake /000000 directories.
6152          */
6153
6154         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6155         if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6156             PerlMem_free(trndir);
6157             PerlMem_free(vmsdir);
6158             return NULL;
6159         }
6160         if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6161             PerlMem_free(trndir);
6162             PerlMem_free(vmsdir);
6163             return NULL;
6164         }
6165         ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6166         PerlMem_free(trndir);
6167         PerlMem_free(vmsdir);
6168         return ret_chr;
6169       }
6170       else {
6171
6172         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6173              !(lastdir = cp1 = strrchr(trndir,']')) &&
6174              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6175
6176         cp2 = strrchr(cp1,'.');
6177         if (cp2) {
6178             int e_len, vs_len = 0;
6179             int is_dir = 0;
6180             char * cp3;
6181             cp3 = strchr(cp2,';');
6182             e_len = strlen(cp2);
6183             if (cp3) {
6184                 vs_len = strlen(cp3);
6185                 e_len = e_len - vs_len;
6186             }
6187             is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6188             if (!is_dir) {
6189                 if (!decc_efs_charset) {
6190                     /* If this is not EFS, then not a directory */
6191                     PerlMem_free(trndir);
6192                     PerlMem_free(vmsdir);
6193                     set_errno(ENOTDIR);
6194                     set_vaxc_errno(RMS$_DIR);
6195                     return NULL;
6196                 }
6197             } else {
6198                 /* Ok, here we have an issue, technically if a .dir shows */
6199                 /* from inside a directory, then we should treat it as */
6200                 /* xxx^.dir.dir.  But we do not have that context at this */
6201                 /* point unless this is totally restructured, so we remove */
6202                 /* The .dir for now, and fix this better later */
6203                 dirlen = cp2 - trndir;
6204             }
6205             if (decc_efs_charset && !strchr(trndir,'/')) {
6206                 /* Dots are allowed in dir names, so escape them if input not in Unix syntax. */
6207                 char *cp4 = is_dir ? (cp2 - 1) : cp2;
6208
6209                 for (; cp4 > cp1; cp4--) {
6210                     if (*cp4 == '.') {
6211                         if ((cp4 - 1 > trndir) && (*(cp4 - 1) != '^')) {
6212                             memmove(cp4 + 1, cp4, trndir + dirlen - cp4 + 1);
6213                             *cp4 = '^';
6214                             dirlen++;
6215                         }
6216                     }
6217                 }
6218             }
6219         }
6220
6221       }
6222
6223       retlen = dirlen + 6;
6224       memcpy(buf, trndir, dirlen);
6225       buf[dirlen] = '\0';
6226
6227       /* We've picked up everything up to the directory file name.
6228          Now just add the type and version, and we're set. */
6229       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
6230           strcat(buf,".dir");
6231       else
6232           strcat(buf,".DIR");
6233       if (!decc_filename_unix_no_version)
6234           strcat(buf,";1");
6235       PerlMem_free(trndir);
6236       PerlMem_free(vmsdir);
6237       return buf;
6238     }
6239     else {  /* VMS-style directory spec */
6240
6241       char *esa, *esal, term, *cp;
6242       char *my_esa;
6243       int my_esa_len;
6244       unsigned long int cmplen, haslower = 0;
6245       struct FAB dirfab = cc$rms_fab;
6246       rms_setup_nam(savnam);
6247       rms_setup_nam(dirnam);
6248
6249       esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
6250       if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6251       esal = NULL;
6252 #if defined(NAML$C_MAXRSS)
6253       esal = (char *)PerlMem_malloc(VMS_MAXRSS);
6254       if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6255 #endif
6256       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6257       rms_bind_fab_nam(dirfab, dirnam);
6258       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6259       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6260 #ifdef NAM$M_NO_SHORT_UPCASE
6261       if (decc_efs_case_preserve)
6262         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6263 #endif
6264
6265       for (cp = trndir; *cp; cp++)
6266         if (islower(*cp)) { haslower = 1; break; }
6267       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6268         if ((dirfab.fab$l_sts == RMS$_DIR) ||
6269             (dirfab.fab$l_sts == RMS$_DNF) ||
6270             (dirfab.fab$l_sts == RMS$_PRV)) {
6271             rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6272             sts = sys$parse(&dirfab);
6273         }
6274         if (!sts) {
6275           PerlMem_free(esa);
6276           if (esal != NULL)
6277               PerlMem_free(esal);
6278           PerlMem_free(trndir);
6279           PerlMem_free(vmsdir);
6280           set_errno(EVMSERR);
6281           set_vaxc_errno(dirfab.fab$l_sts);
6282           return NULL;
6283         }
6284       }
6285       else {
6286         savnam = dirnam;
6287         /* Does the file really exist? */
6288         if (sys$search(&dirfab)& STS$K_SUCCESS) {
6289           /* Yes; fake the fnb bits so we'll check type below */
6290           rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6291         }
6292         else { /* No; just work with potential name */
6293           if (dirfab.fab$l_sts    == RMS$_FNF
6294               || dirfab.fab$l_sts == RMS$_DNF
6295               || dirfab.fab$l_sts == RMS$_FND)
6296                 dirnam = savnam;
6297           else {
6298             int fab_sts;
6299             fab_sts = dirfab.fab$l_sts;
6300             sts = rms_free_search_context(&dirfab);
6301             PerlMem_free(esa);
6302             if (esal != NULL)
6303                 PerlMem_free(esal);
6304             PerlMem_free(trndir);
6305             PerlMem_free(vmsdir);
6306             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
6307             return NULL;
6308           }
6309         }
6310       }
6311
6312       /* Make sure we are using the right buffer */
6313 #if defined(NAML$C_MAXRSS)
6314       if (esal != NULL) {
6315         my_esa = esal;
6316         my_esa_len = rms_nam_esll(dirnam);
6317       } else {
6318 #endif
6319         my_esa = esa;
6320         my_esa_len = rms_nam_esl(dirnam);
6321 #if defined(NAML$C_MAXRSS)
6322       }
6323 #endif
6324       my_esa[my_esa_len] = '\0';
6325       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6326         cp1 = strchr(my_esa,']');
6327         if (!cp1) cp1 = strchr(my_esa,'>');
6328         if (cp1) {  /* Should always be true */
6329           my_esa_len -= cp1 - my_esa - 1;
6330           memmove(my_esa, cp1 + 1, my_esa_len);
6331         }
6332       }
6333       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6334         /* Yep; check version while we're at it, if it's there. */
6335         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6336         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6337           /* Something other than .DIR[;1].  Bzzt. */
6338           sts = rms_free_search_context(&dirfab);
6339           PerlMem_free(esa);
6340           if (esal != NULL)
6341              PerlMem_free(esal);
6342           PerlMem_free(trndir);
6343           PerlMem_free(vmsdir);
6344           set_errno(ENOTDIR);
6345           set_vaxc_errno(RMS$_DIR);
6346           return NULL;
6347         }
6348       }
6349
6350       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6351         /* They provided at least the name; we added the type, if necessary, */
6352         my_strlcpy(buf, my_esa, VMS_MAXRSS);
6353         sts = rms_free_search_context(&dirfab);
6354         PerlMem_free(trndir);
6355         PerlMem_free(esa);
6356         if (esal != NULL)
6357             PerlMem_free(esal);
6358         PerlMem_free(vmsdir);
6359         return buf;
6360       }
6361       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6362         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6363         *cp1 = '\0';
6364         my_esa_len -= 9;
6365       }
6366       if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6367       if (cp1 == NULL) { /* should never happen */
6368         sts = rms_free_search_context(&dirfab);
6369         PerlMem_free(trndir);
6370         PerlMem_free(esa);
6371         if (esal != NULL)
6372             PerlMem_free(esal);
6373         PerlMem_free(vmsdir);
6374         return NULL;
6375       }
6376       term = *cp1;
6377       *cp1 = '\0';
6378       retlen = strlen(my_esa);
6379       cp1 = strrchr(my_esa,'.');
6380       /* ODS-5 directory specifications can have extra "." in them. */
6381       /* Fix-me, can not scan EFS file specifications backwards */
6382       while (cp1 != NULL) {
6383         if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6384           break;
6385         else {
6386            cp1--;
6387            while ((cp1 > my_esa) && (*cp1 != '.'))
6388              cp1--;
6389         }
6390         if (cp1 == my_esa)
6391           cp1 = NULL;
6392       }
6393
6394       if ((cp1) != NULL) {
6395         /* There's more than one directory in the path.  Just roll back. */
6396         *cp1 = term;
6397         my_strlcpy(buf, my_esa, VMS_MAXRSS);
6398       }
6399       else {
6400         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6401           /* Go back and expand rooted logical name */
6402           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6403 #ifdef NAM$M_NO_SHORT_UPCASE
6404           if (decc_efs_case_preserve)
6405             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6406 #endif
6407           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6408             sts = rms_free_search_context(&dirfab);
6409             PerlMem_free(esa);
6410             if (esal != NULL)
6411                 PerlMem_free(esal);
6412             PerlMem_free(trndir);
6413             PerlMem_free(vmsdir);
6414             set_errno(EVMSERR);
6415             set_vaxc_errno(dirfab.fab$l_sts);
6416             return NULL;
6417           }
6418
6419           /* This changes the length of the string of course */
6420           if (esal != NULL) {
6421               my_esa_len = rms_nam_esll(dirnam);
6422           } else {
6423               my_esa_len = rms_nam_esl(dirnam);
6424           }
6425
6426           retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6427           cp1 = strstr(my_esa,"][");
6428           if (!cp1) cp1 = strstr(my_esa,"]<");
6429           dirlen = cp1 - my_esa;
6430           memcpy(buf, my_esa, dirlen);
6431           if (!strncmp(cp1+2,"000000]",7)) {
6432             buf[dirlen-1] = '\0';
6433             /* fix-me Not full ODS-5, just extra dots in directories for now */
6434             cp1 = buf + dirlen - 1;
6435             while (cp1 > buf)
6436             {
6437               if (*cp1 == '[')
6438                 break;
6439               if (*cp1 == '.') {
6440                 if (*(cp1-1) != '^')
6441                   break;
6442               }
6443               cp1--;
6444             }
6445             if (*cp1 == '.') *cp1 = ']';
6446             else {
6447               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6448               memmove(cp1+1,"000000]",7);
6449             }
6450           }
6451           else {
6452             memmove(buf+dirlen, cp1+2, retlen-dirlen);
6453             buf[retlen] = '\0';
6454             /* Convert last '.' to ']' */
6455             cp1 = buf+retlen-1;
6456             while (*cp != '[') {
6457               cp1--;
6458               if (*cp1 == '.') {
6459                 /* Do not trip on extra dots in ODS-5 directories */
6460                 if ((cp1 == buf) || (*(cp1-1) != '^'))
6461                 break;
6462               }
6463             }
6464             if (*cp1 == '.') *cp1 = ']';
6465             else {
6466               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6467               memmove(cp1+1,"000000]",7);
6468             }
6469           }
6470         }
6471         else {  /* This is a top-level dir.  Add the MFD to the path. */
6472           cp1 = strrchr(my_esa, ':');
6473           assert(cp1);
6474           memmove(buf, my_esa, cp1 - my_esa + 1);
6475           memmove(buf + (cp1 - my_esa) + 1, "[000000]", 8);
6476           memmove(buf + (cp1 - my_esa) + 9, cp1 + 2, retlen - (cp1 - my_esa + 2));
6477           buf[retlen + 7] = '\0';  /* We've inserted '000000]' */
6478         }
6479       }
6480       sts = rms_free_search_context(&dirfab);
6481       /* We've set up the string up through the filename.  Add the
6482          type and version, and we're done. */
6483       strcat(buf,".DIR;1");
6484
6485       /* $PARSE may have upcased filespec, so convert output to lower
6486        * case if input contained any lowercase characters. */
6487       if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
6488       PerlMem_free(trndir);
6489       PerlMem_free(esa);
6490       if (esal != NULL)
6491         PerlMem_free(esal);
6492       PerlMem_free(vmsdir);
6493       return buf;
6494     }
6495 }  /* end of int_fileify_dirspec() */
6496
6497
6498 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6499 static char *
6500 mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
6501 {
6502     static char __fileify_retbuf[VMS_MAXRSS];
6503     char * fileified, *ret_spec, *ret_buf;
6504
6505     fileified = NULL;
6506     ret_buf = buf;
6507     if (ret_buf == NULL) {
6508         if (ts) {
6509             Newx(fileified, VMS_MAXRSS, char);
6510             if (fileified == NULL)
6511                 _ckvmssts(SS$_INSFMEM);
6512             ret_buf = fileified;
6513         } else {
6514             ret_buf = __fileify_retbuf;
6515         }
6516     }
6517
6518     ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6519
6520     if (ret_spec == NULL) {
6521        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6522        if (fileified)
6523            Safefree(fileified);
6524     }
6525
6526     return ret_spec;
6527 }  /* end of do_fileify_dirspec() */
6528 /*}}}*/
6529
6530 /* External entry points */
6531 char *
6532 Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6533 {
6534     return do_fileify_dirspec(dir, buf, 0, NULL);
6535 }
6536
6537 char *
6538 Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6539 {
6540     return do_fileify_dirspec(dir, buf, 1, NULL);
6541 }
6542
6543 char *
6544 Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6545 {
6546     return do_fileify_dirspec(dir, buf, 0, utf8_fl);
6547 }
6548
6549 char *
6550 Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6551 {
6552     return do_fileify_dirspec(dir, buf, 1, utf8_fl);
6553 }
6554
6555 static char *
6556 int_pathify_dirspec_simple(const char * dir, char * buf,
6557     char * v_spec, int v_len, char * r_spec, int r_len,
6558     char * d_spec, int d_len, char * n_spec, int n_len,
6559     char * e_spec, int e_len, char * vs_spec, int vs_len)
6560 {
6561
6562     /* VMS specification - Try to do this the simple way */
6563     if ((v_len + r_len > 0) || (d_len > 0)) {
6564         int is_dir;
6565
6566         /* No name or extension component, already a directory */
6567         if ((n_len + e_len + vs_len) == 0) {
6568             strcpy(buf, dir);
6569             return buf;
6570         }
6571
6572         /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6573         /* This results from catfile() being used instead of catdir() */
6574         /* So even though it should not work, we need to allow it */
6575
6576         /* If this is .DIR;1 then do a simple conversion */
6577         is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6578         if (is_dir || (e_len == 0) && (d_len > 0)) {
6579              int len;
6580              len = v_len + r_len + d_len - 1;
6581              char dclose = d_spec[d_len - 1];
6582              memcpy(buf, dir, len);
6583              buf[len] = '.';
6584              len++;
6585              memcpy(&buf[len], n_spec, n_len);
6586              len += n_len;
6587              buf[len] = dclose;
6588              buf[len + 1] = '\0';
6589              return buf;
6590         }
6591
6592 #ifdef HAS_SYMLINK
6593         else if (d_len > 0) {
6594             /* In the olden days, a directory needed to have a .DIR */
6595             /* extension to be a valid directory, but now it could  */
6596             /* be a symbolic link */
6597             int len;
6598             len = v_len + r_len + d_len - 1;
6599             char dclose = d_spec[d_len - 1];
6600             memcpy(buf, dir, len);
6601             buf[len] = '.';
6602             len++;
6603             memcpy(&buf[len], n_spec, n_len);
6604             len += n_len;
6605             if (e_len > 0) {
6606                 if (decc_efs_charset) {
6607                     if (e_len == 4
6608                         && (toupper(e_spec[1]) == 'D')
6609                         && (toupper(e_spec[2]) == 'I')
6610                         && (toupper(e_spec[3]) == 'R')) {
6611
6612                         /* Corner case: directory spec with invalid version.
6613                          * Valid would have followed is_dir path above.
6614                          */
6615                         SETERRNO(ENOTDIR, RMS$_DIR);
6616                         return NULL;
6617                     }
6618                     else {
6619                         buf[len] = '^';
6620                         len++;
6621                         memcpy(&buf[len], e_spec, e_len);
6622                         len += e_len;
6623                     }
6624                 }
6625                 else {
6626                     SETERRNO(ENOTDIR, RMS$_DIR);
6627                     return NULL;
6628                 }
6629             }
6630             buf[len] = dclose;
6631             buf[len + 1] = '\0';
6632             return buf;
6633         }
6634 #else
6635         else {
6636             set_vaxc_errno(RMS$_DIR);
6637             set_errno(ENOTDIR);
6638             return NULL;
6639         }
6640 #endif
6641     }
6642     set_vaxc_errno(RMS$_DIR);
6643     set_errno(ENOTDIR);
6644     return NULL;
6645 }
6646
6647
6648 /* Internal routine to make sure or convert a directory to be in a */
6649 /* path specification.  No utf8 flag because it is not changed or used */
6650 static char *
6651 int_pathify_dirspec(const char *dir, char *buf)
6652 {
6653     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6654     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6655     char * exp_spec, *ret_spec;
6656     char * trndir;
6657     unsigned short int trnlnm_iter_count;
6658     STRLEN trnlen;
6659     int need_to_lower;
6660
6661     if (vms_debug_fileify) {
6662         if (dir == NULL)
6663             fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6664         else
6665             fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6666     }
6667
6668     /* We may need to lower case the result if we translated  */
6669     /* a logical name or got the current working directory */
6670     need_to_lower = 0;
6671
6672     if (!dir || !*dir) {
6673       set_errno(EINVAL);
6674       set_vaxc_errno(SS$_BADPARAM);
6675       return NULL;
6676     }
6677
6678     trndir = (char *)PerlMem_malloc(VMS_MAXRSS);
6679     if (trndir == NULL)
6680         _ckvmssts_noperl(SS$_INSFMEM);
6681
6682     /* If no directory specified use the current default */
6683     if (*dir)
6684         my_strlcpy(trndir, dir, VMS_MAXRSS);
6685     else {
6686         getcwd(trndir, VMS_MAXRSS - 1);
6687         need_to_lower = 1;
6688     }
6689
6690     /* now deal with bare names that could be logical names */
6691     trnlnm_iter_count = 0;
6692     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6693            && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6694         trnlnm_iter_count++;
6695         need_to_lower = 1;
6696         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6697             break;
6698         trnlen = strlen(trndir);
6699
6700         /* Trap simple rooted lnms, and return lnm:[000000] */
6701         if (!strcmp(trndir+trnlen-2,".]")) {
6702             my_strlcpy(buf, dir, VMS_MAXRSS);
6703             strcat(buf, ":[000000]");
6704             PerlMem_free(trndir);
6705
6706             if (vms_debug_fileify) {
6707                 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6708             }
6709             return buf;
6710         }
6711     }
6712
6713     /* At this point we do not work with *dir, but the copy in  *trndir */
6714
6715     if (need_to_lower && !decc_efs_case_preserve) {
6716         /* Legacy mode, lower case the returned value */
6717         __mystrtolower(trndir);
6718     }
6719
6720
6721     /* Some special cases, '..', '.' */
6722     sts = 0;
6723     if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6724        /* Force UNIX filespec */
6725        sts = 1;
6726
6727     } else {
6728         /* Is this Unix or VMS format? */
6729         sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6730                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6731                              &e_len, &vs_spec, &vs_len);
6732         if (sts == 0) {
6733
6734             /* Just a filename? */
6735             if ((v_len + r_len + d_len) == 0) {
6736
6737                 /* Now we have a problem, this could be Unix or VMS */
6738                 /* We have to guess.  .DIR usually means VMS */
6739
6740                 /* In UNIX report mode, the .DIR extension is removed */
6741                 /* if one shows up, it is for a non-directory or a directory */
6742                 /* in EFS charset mode */
6743
6744                 /* So if we are in Unix report mode, assume that this */
6745                 /* is a relative Unix directory specification */
6746
6747                 sts = 1;
6748                 if (!decc_filename_unix_report && decc_efs_charset) {
6749                     int is_dir;
6750                     is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6751
6752                     if (is_dir) {
6753                         /* Traditional mode, assume .DIR is directory */
6754                         buf[0] = '[';
6755                         buf[1] = '.';
6756                         memcpy(&buf[2], n_spec, n_len);
6757                         buf[n_len + 2] = ']';
6758                         buf[n_len + 3] = '\0';
6759                         PerlMem_free(trndir);
6760                         if (vms_debug_fileify) {
6761                             fprintf(stderr,
6762                                     "int_pathify_dirspec: buf = %s\n",
6763                                     buf);
6764                         }
6765                         return buf;
6766                     }
6767                 }
6768             }
6769         }
6770     }
6771     if (sts == 0) {
6772         ret_spec = int_pathify_dirspec_simple(trndir, buf,
6773             v_spec, v_len, r_spec, r_len,
6774             d_spec, d_len, n_spec, n_len,
6775             e_spec, e_len, vs_spec, vs_len);
6776
6777         if (ret_spec != NULL) {
6778             PerlMem_free(trndir);
6779             if (vms_debug_fileify) {
6780                 fprintf(stderr,
6781                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6782             }
6783             return ret_spec;
6784         }
6785
6786         /* Simple way did not work, which means that a logical name */
6787         /* was present for the directory specification.             */
6788         /* Need to use an rmsexpand variant to decode it completely */
6789         exp_spec = (char *)PerlMem_malloc(VMS_MAXRSS);
6790         if (exp_spec == NULL)
6791             _ckvmssts_noperl(SS$_INSFMEM);
6792
6793         ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6794         if (ret_spec != NULL) {
6795             sts = vms_split_path(exp_spec, &v_spec, &v_len,
6796                                  &r_spec, &r_len, &d_spec, &d_len,
6797                                  &n_spec, &n_len, &e_spec,
6798                                  &e_len, &vs_spec, &vs_len);
6799             if (sts == 0) {
6800                 ret_spec = int_pathify_dirspec_simple(
6801                     exp_spec, buf, v_spec, v_len, r_spec, r_len,
6802                     d_spec, d_len, n_spec, n_len,
6803                     e_spec, e_len, vs_spec, vs_len);
6804
6805                 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6806                     /* Legacy mode, lower case the returned value */
6807                     __mystrtolower(ret_spec);
6808                 }
6809             } else {
6810                 set_vaxc_errno(RMS$_DIR);
6811                 set_errno(ENOTDIR);
6812                 ret_spec = NULL;
6813             }
6814         }
6815         PerlMem_free(exp_spec);
6816         PerlMem_free(trndir);
6817         if (vms_debug_fileify) {
6818             if (ret_spec == NULL)
6819                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6820             else
6821                 fprintf(stderr,
6822                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6823         }
6824         return ret_spec;
6825
6826     } else {
6827         /* Unix specification, Could be trivial conversion, */
6828         /* but have to deal with trailing '.dir' or extra '.' */
6829
6830         char * lastdot;
6831         char * lastslash;
6832         int is_dir;
6833         STRLEN dir_len = strlen(trndir);
6834
6835         lastslash = strrchr(trndir, '/');
6836         if (lastslash == NULL)
6837             lastslash = trndir;
6838         else
6839             lastslash++;
6840
6841         lastdot = NULL;
6842
6843         /* '..' or '.' are valid directory components */
6844         is_dir = 0;
6845         if (lastslash[0] == '.') {
6846             if (lastslash[1] == '\0') {
6847                is_dir = 1;
6848             } else if (lastslash[1] == '.') {
6849                 if (lastslash[2] == '\0') {
6850                     is_dir = 1;
6851                 } else {
6852                     /* And finally allow '...' */
6853                     if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
6854                         is_dir = 1;
6855                     }
6856                 }
6857             }
6858         }
6859
6860         if (!is_dir) {
6861            lastdot = strrchr(lastslash, '.');
6862         }
6863         if (lastdot != NULL) {
6864             STRLEN e_len;
6865              /* '.dir' is discarded, and any other '.' is invalid */
6866             e_len = strlen(lastdot);
6867
6868             is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
6869
6870             if (is_dir) {
6871                 dir_len = dir_len - 4;
6872             }
6873         }
6874
6875         my_strlcpy(buf, trndir, VMS_MAXRSS);
6876         if (buf[dir_len - 1] != '/') {
6877             buf[dir_len] = '/';
6878             buf[dir_len + 1] = '\0';
6879         }
6880
6881         /* Under ODS-2 rules, '.' becomes '_', so fix it up */
6882         if (!decc_efs_charset) {
6883              int dir_start = 0;
6884              char * str = buf;
6885              if (str[0] == '.') {
6886                  char * dots = str;
6887                  int cnt = 1;
6888                  while ((dots[cnt] == '.') && (cnt < 3))
6889                      cnt++;
6890                  if (cnt <= 3) {
6891                      if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
6892                          dir_start = 1;
6893                          str += cnt;
6894                      }
6895                  }
6896              }
6897              for (; *str; ++str) {
6898                  while (*str == '/') {
6899                      dir_start = 1;
6900                      *str++;
6901                  }
6902                  if (dir_start) {
6903
6904                      /* Have to skip up to three dots which could be */
6905                      /* directories, 3 dots being a VMS extension for Perl */
6906                      char * dots = str;
6907                      int cnt = 0;
6908                      while ((dots[cnt] == '.') && (cnt < 3)) {
6909                          cnt++;
6910                      }
6911                      if (dots[cnt] == '\0')
6912                          break;
6913                      if ((cnt > 1) && (dots[cnt] != '/')) {
6914                          dir_start = 0;
6915                      } else {
6916                          str += cnt;
6917                      }
6918
6919                      /* too many dots? */
6920                      if ((cnt == 0) || (cnt > 3)) {
6921                          dir_start = 0;
6922                      }
6923                  }
6924                  if (!dir_start && (*str == '.')) {
6925                      *str = '_';
6926                  }
6927              }
6928         }
6929         PerlMem_free(trndir);
6930         ret_spec = buf;
6931         if (vms_debug_fileify) {
6932             if (ret_spec == NULL)
6933                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6934             else
6935                 fprintf(stderr,
6936                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6937         }
6938         return ret_spec;
6939     }
6940 }
6941
6942 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6943 static char *
6944 mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6945 {
6946     static char __pathify_retbuf[VMS_MAXRSS];
6947     char * pathified, *ret_spec, *ret_buf;
6948
6949     pathified = NULL;
6950     ret_buf = buf;
6951     if (ret_buf == NULL) {
6952         if (ts) {
6953             Newx(pathified, VMS_MAXRSS, char);
6954             if (pathified == NULL)
6955                 _ckvmssts(SS$_INSFMEM);
6956             ret_buf = pathified;
6957         } else {
6958             ret_buf = __pathify_retbuf;
6959         }
6960     }
6961
6962     ret_spec = int_pathify_dirspec(dir, ret_buf);
6963
6964     if (ret_spec == NULL) {
6965        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6966        if (pathified)
6967            Safefree(pathified);
6968     }
6969
6970     return ret_spec;
6971
6972 }  /* end of do_pathify_dirspec() */
6973
6974
6975 /* External entry points */
6976 char *
6977 Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6978 {
6979     return do_pathify_dirspec(dir, buf, 0, NULL);
6980 }
6981
6982 char *
6983 Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6984 {
6985     return do_pathify_dirspec(dir, buf, 1, NULL);
6986 }
6987
6988 char *
6989 Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6990 {
6991     return do_pathify_dirspec(dir, buf, 0, utf8_fl);
6992 }
6993
6994 char *
6995 Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6996 {
6997     return do_pathify_dirspec(dir, buf, 1, utf8_fl);
6998 }
6999
7000 /* Internal tounixspec routine that does not use a thread context */
7001 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
7002 static char *
7003 int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
7004 {
7005   char *dirend, *cp1, *cp3, *tmp;
7006   const char *cp2;
7007   int dirlen;
7008   unsigned short int trnlnm_iter_count;
7009   int cmp_rslt, outchars_added;
7010   if (utf8_fl != NULL)
7011     *utf8_fl = 0;
7012
7013   if (vms_debug_fileify) {
7014       if (spec == NULL)
7015           fprintf(stderr, "int_tounixspec: spec = NULL\n");
7016       else
7017           fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
7018   }
7019
7020
7021   if (spec == NULL) {
7022       set_errno(EINVAL);
7023       set_vaxc_errno(SS$_BADPARAM);
7024       return NULL;
7025   }
7026   if (strlen(spec) > (VMS_MAXRSS-1)) {
7027       set_errno(E2BIG);
7028       set_vaxc_errno(SS$_BUFFEROVF);
7029       return NULL;
7030   }
7031
7032   /* New VMS specific format needs translation
7033    * glob passes filenames with trailing '\n' and expects this preserved.
7034    */
7035   if (decc_posix_compliant_pathnames) {
7036     if (strncmp(spec, "\"^UP^", 5) == 0) {
7037       char * uspec;
7038       char *tunix;
7039       int tunix_len;
7040       int nl_flag;
7041
7042       tunix = (char *)PerlMem_malloc(VMS_MAXRSS);
7043       if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7044       tunix_len = my_strlcpy(tunix, spec, VMS_MAXRSS);
7045       nl_flag = 0;
7046       if (tunix[tunix_len - 1] == '\n') {
7047         tunix[tunix_len - 1] = '\"';
7048         tunix[tunix_len] = '\0';
7049         tunix_len--;
7050         nl_flag = 1;
7051       }
7052       uspec = decc$translate_vms(tunix);
7053       PerlMem_free(tunix);
7054       if ((int)uspec > 0) {
7055         my_strlcpy(rslt, uspec, VMS_MAXRSS);
7056         if (nl_flag) {
7057           strcat(rslt,"\n");
7058         }
7059         else {
7060           /* If we can not translate it, makemaker wants as-is */
7061           my_strlcpy(rslt, spec, VMS_MAXRSS);
7062         }
7063         return rslt;
7064       }
7065     }
7066   }
7067
7068   cmp_rslt = 0; /* Presume VMS */
7069   cp1 = strchr(spec, '/');
7070   if (cp1 == NULL)
7071     cmp_rslt = 0;
7072
7073     /* Look for EFS ^/ */
7074     if (decc_efs_charset) {
7075       while (cp1 != NULL) {
7076         cp2 = cp1 - 1;
7077         if (*cp2 != '^') {
7078           /* Found illegal VMS, assume UNIX */
7079           cmp_rslt = 1;
7080           break;
7081         }
7082       cp1++;
7083       cp1 = strchr(cp1, '/');
7084     }
7085   }
7086
7087   /* Look for "." and ".." */
7088   if (decc_filename_unix_report) {
7089     if (spec[0] == '.') {
7090       if ((spec[1] == '\0') || (spec[1] == '\n')) {
7091         cmp_rslt = 1;
7092       }
7093       else {
7094         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
7095           cmp_rslt = 1;
7096         }
7097       }
7098     }
7099   }
7100
7101   cp1 = rslt;
7102   cp2 = spec;
7103
7104   /* This is already UNIX or at least nothing VMS understands,
7105    * so all we can reasonably do is unescape extended chars.
7106    */
7107   if (cmp_rslt) {
7108     while (*cp2) {
7109         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7110         cp1 += outchars_added;
7111     }
7112     *cp1 = '\0';
7113     if (vms_debug_fileify) {
7114         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7115     }
7116     return rslt;
7117   }
7118
7119   dirend = strrchr(spec,']');
7120   if (dirend == NULL) dirend = strrchr(spec,'>');
7121   if (dirend == NULL) dirend = strchr(spec,':');
7122   if (dirend == NULL) {
7123     while (*cp2) {
7124         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7125         cp1 += outchars_added;
7126     }
7127     *cp1 = '\0';
7128     if (vms_debug_fileify) {
7129         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7130     }
7131     return rslt;
7132   }
7133
7134   /* Special case 1 - sys$posix_root = / */
7135   if (!decc_disable_posix_root) {
7136     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
7137       *cp1 = '/';
7138       cp1++;
7139       cp2 = cp2 + 15;
7140       }
7141   }
7142
7143   /* Special case 2 - Convert NLA0: to /dev/null */
7144   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
7145   if (cmp_rslt == 0) {
7146     strcpy(rslt, "/dev/null");
7147     cp1 = cp1 + 9;
7148     cp2 = cp2 + 5;
7149     if (spec[6] != '\0') {
7150       cp1[9] = '/';
7151       cp1++;
7152       cp2++;
7153     }
7154   }
7155
7156    /* Also handle special case "SYS$SCRATCH:" */
7157   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
7158   tmp = (char *)PerlMem_malloc(VMS_MAXRSS);
7159   if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7160   if (cmp_rslt == 0) {
7161   int islnm;
7162
7163     islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
7164     if (!islnm) {
7165       strcpy(rslt, "/tmp");
7166       cp1 = cp1 + 4;
7167       cp2 = cp2 + 12;
7168       if (spec[12] != '\0') {
7169         cp1[4] = '/';
7170         cp1++;
7171         cp2++;
7172       }
7173     }
7174   }
7175
7176   if (*cp2 != '[' && *cp2 != '<') {
7177     *(cp1++) = '/';
7178   }
7179   else {  /* the VMS spec begins with directories */
7180     cp2++;
7181     if (*cp2 == ']' || *cp2 == '>') {
7182       *(cp1++) = '.';
7183       *(cp1++) = '/';
7184     }
7185     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
7186       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
7187         PerlMem_free(tmp);
7188         if (vms_debug_fileify) {
7189             fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7190         }
7191         return NULL;
7192       }
7193       trnlnm_iter_count = 0;
7194       do {
7195         cp3 = tmp;
7196         while (*cp3 != ':' && *cp3) cp3++;
7197         *(cp3++) = '\0';
7198         if (strchr(cp3,']') != NULL) break;
7199         trnlnm_iter_count++;
7200         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7201       } while (vmstrnenv(tmp,tmp,0,fildev,0));
7202       cp1 = rslt;
7203       cp3 = tmp;
7204       *(cp1++) = '/';
7205       while (*cp3) {
7206         *(cp1++) = *(cp3++);
7207         if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7208             PerlMem_free(tmp);
7209             set_errno(ENAMETOOLONG);
7210             set_vaxc_errno(SS$_BUFFEROVF);
7211             if (vms_debug_fileify) {
7212                 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7213             }
7214             return NULL; /* No room */
7215         }
7216       }
7217       *(cp1++) = '/';
7218     }
7219     if ((*cp2 == '^')) {
7220         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7221         cp1 += outchars_added;
7222     }
7223     else if ( *cp2 == '.') {
7224       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7225         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7226         cp2 += 3;
7227       }
7228       else cp2++;
7229     }
7230   }
7231   PerlMem_free(tmp);
7232   for (; cp2 <= dirend; cp2++) {
7233     if ((*cp2 == '^')) {
7234         /* EFS file escape -- unescape it. */
7235         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added) - 1;
7236         cp1 += outchars_added;
7237     }
7238     else if (*cp2 == ':') {
7239       *(cp1++) = '/';
7240       if (*(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7241     }
7242     else if (*cp2 == ']' || *cp2 == '>') {
7243       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7244     }
7245     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7246       *(cp1++) = '/';
7247       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7248         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7249                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7250         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7251             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7252       }
7253       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7254         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7255         cp2 += 2;
7256       }
7257     }
7258     else if (*cp2 == '-') {
7259       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7260         while (*cp2 == '-') {
7261           cp2++;
7262           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7263         }
7264         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7265                                                          /* filespecs like */
7266           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
7267           if (vms_debug_fileify) {
7268               fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7269           }
7270           return NULL;
7271         }
7272       }
7273       else *(cp1++) = *cp2;
7274     }
7275     else *(cp1++) = *cp2;
7276   }
7277   /* Translate the rest of the filename. */
7278   while (*cp2) {
7279       int dot_seen = 0;
7280       switch(*cp2) {
7281       /* Fixme - for compatibility with the CRTL we should be removing */
7282       /* spaces from the file specifications, but this may show that */
7283       /* some tests that were appearing to pass are not really passing */
7284       case '%':
7285           cp2++;
7286           *(cp1++) = '?';
7287           break;
7288       case '^':
7289           cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7290           cp1 += outchars_added;
7291           break;
7292       case ';':
7293           if (decc_filename_unix_no_version) {
7294               /* Easy, drop the version */
7295               while (*cp2)
7296                   cp2++;
7297               break;
7298           } else {
7299               /* Punt - passing the version as a dot will probably */
7300               /* break perl in weird ways, but so did passing */
7301               /* through the ; as a version.  Follow the CRTL and */
7302               /* hope for the best. */
7303               cp2++;
7304               *(cp1++) = '.';
7305           }
7306           break;
7307       case '.':
7308           if (dot_seen) {
7309               /* We will need to fix this properly later */
7310               /* As Perl may be installed on an ODS-5 volume, but not */
7311               /* have the EFS_CHARSET enabled, it still may encounter */
7312               /* filenames with extra dots in them, and a precedent got */
7313               /* set which allowed them to work, that we will uphold here */
7314               /* If extra dots are present in a name and no ^ is on them */
7315               /* VMS assumes that the first one is the extension delimiter */
7316               /* the rest have an implied ^. */
7317
7318               /* this is also a conflict as the . is also a version */
7319               /* delimiter in VMS, */
7320
7321               *(cp1++) = *(cp2++);
7322               break;
7323           }
7324           dot_seen = 1;
7325           /* This is an extension */
7326           if (decc_readdir_dropdotnotype) {
7327               cp2++;
7328               if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7329                   /* Drop the dot for the extension */
7330                   break;
7331               } else {
7332                   *(cp1++) = '.';
7333               }
7334               break;
7335           }
7336       default:
7337           *(cp1++) = *(cp2++);
7338       }
7339   }
7340   *cp1 = '\0';
7341
7342   /* This still leaves /000000/ when working with a
7343    * VMS device root or concealed root.
7344    */
7345   {
7346       int ulen;
7347       char * zeros;
7348
7349       ulen = strlen(rslt);
7350
7351       /* Get rid of "000000/ in rooted filespecs */
7352       if (ulen > 7) {
7353         zeros = strstr(rslt, "/000000/");
7354         if (zeros != NULL) {
7355           int mlen;
7356           mlen = ulen - (zeros - rslt) - 7;
7357           memmove(zeros, &zeros[7], mlen);
7358           ulen = ulen - 7;
7359           rslt[ulen] = '\0';
7360         }
7361       }
7362   }
7363
7364   if (vms_debug_fileify) {
7365       fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7366   }
7367   return rslt;
7368
7369 }  /* end of int_tounixspec() */
7370
7371
7372 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7373 static char *
7374 mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7375 {
7376     static char __tounixspec_retbuf[VMS_MAXRSS];
7377     char * unixspec, *ret_spec, *ret_buf;
7378
7379     unixspec = NULL;
7380     ret_buf = buf;
7381     if (ret_buf == NULL) {
7382         if (ts) {
7383             Newx(unixspec, VMS_MAXRSS, char);
7384             if (unixspec == NULL)
7385                 _ckvmssts(SS$_INSFMEM);
7386             ret_buf = unixspec;
7387         } else {
7388             ret_buf = __tounixspec_retbuf;
7389         }
7390     }
7391
7392     ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7393
7394     if (ret_spec == NULL) {
7395        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7396        if (unixspec)
7397            Safefree(unixspec);
7398     }
7399
7400     return ret_spec;
7401
7402 }  /* end of do_tounixspec() */
7403 /*}}}*/
7404 /* External entry points */
7405 char *
7406 Perl_tounixspec(pTHX_ const char *spec, char *buf)
7407 {
7408     return do_tounixspec(spec, buf, 0, NULL);
7409 }
7410
7411 char *
7412 Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7413 {
7414     return do_tounixspec(spec,buf,1, NULL);
7415 }
7416
7417 char *
7418 Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7419 {
7420     return do_tounixspec(spec,buf,0, utf8_fl);
7421 }
7422
7423 char *
7424 Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7425 {
7426     return do_tounixspec(spec,buf,1, utf8_fl);
7427 }
7428
7429 /*
7430  This procedure is used to identify if a path is based in either
7431  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7432  it returns the OpenVMS format directory for it.
7433
7434  It is expecting specifications of only '/' or '/xxxx/'
7435
7436  If a posix root does not exist, or 'xxxx' is not a directory
7437  in the posix root, it returns a failure.
7438
7439  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7440
7441  It is used only internally by posix_to_vmsspec_hardway().
7442  */
7443
7444 static int
7445 posix_root_to_vms(char *vmspath, int vmspath_len,
7446                   const char *unixpath, const int * utf8_fl)
7447 {
7448   int sts;
7449   struct FAB myfab = cc$rms_fab;
7450   rms_setup_nam(mynam);
7451   struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7452   struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7453   char * esa, * esal, * rsa, * rsal;
7454   int dir_flag;
7455   int unixlen;
7456
7457   dir_flag = 0;
7458   vmspath[0] = '\0';
7459   unixlen = strlen(unixpath);
7460   if (unixlen == 0) {
7461     return RMS$_FNF;
7462   }
7463
7464 #if __CRTL_VER >= 80200000
7465   /* If not a posix spec already, convert it */
7466   if (decc_posix_compliant_pathnames) {
7467     if (strncmp(unixpath,"\"^UP^",5) != 0) {
7468       sprintf(vmspath,"\"^UP^%s\"",unixpath);
7469     }
7470     else {
7471       /* This is already a VMS specification, no conversion */
7472       unixlen--;
7473       my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7474     }
7475   }
7476   else
7477 #endif
7478   {
7479      int path_len;
7480      int i,j;
7481
7482      /* Check to see if this is under the POSIX root */
7483      if (decc_disable_posix_root) {
7484         return RMS$_FNF;
7485      }
7486
7487      /* Skip leading / */
7488      if (unixpath[0] == '/') {
7489         unixpath++;
7490         unixlen--;
7491      }
7492
7493
7494      strcpy(vmspath,"SYS$POSIX_ROOT:");
7495
7496      /* If this is only the / , or blank, then... */
7497      if (unixpath[0] == '\0') {
7498         /* by definition, this is the answer */
7499         return SS$_NORMAL;
7500      }
7501
7502      /* Need to look up a directory */
7503      vmspath[15] = '[';
7504      vmspath[16] = '\0';
7505
7506      /* Copy and add '^' escape characters as needed */
7507      j = 16;
7508      i = 0;
7509      while (unixpath[i] != 0) {
7510      int k;
7511
7512         j += copy_expand_unix_filename_escape
7513             (&vmspath[j], &unixpath[i], &k, utf8_fl);
7514         i += k;
7515      }
7516
7517      path_len = strlen(vmspath);
7518      if (vmspath[path_len - 1] == '/')
7519         path_len--;
7520      vmspath[path_len] = ']';
7521      path_len++;
7522      vmspath[path_len] = '\0';
7523
7524   }
7525   vmspath[vmspath_len] = 0;
7526   if (unixpath[unixlen - 1] == '/')
7527   dir_flag = 1;
7528   esal = (char *)PerlMem_malloc(VMS_MAXRSS);
7529   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7530   esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
7531   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7532   rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
7533   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7534   rsa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
7535   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7536   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7537   rms_bind_fab_nam(myfab, mynam);
7538   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7539   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7540   if (decc_efs_case_preserve)
7541     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7542 #ifdef NAML$M_OPEN_SPECIAL
7543   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7544 #endif
7545
7546   /* Set up the remaining naml fields */
7547   sts = sys$parse(&myfab);
7548
7549   /* It failed! Try again as a UNIX filespec */
7550   if (!(sts & 1)) {
7551     PerlMem_free(esal);
7552     PerlMem_free(esa);
7553     PerlMem_free(rsal);
7554     PerlMem_free(rsa);
7555     return sts;
7556   }
7557
7558    /* get the Device ID and the FID */
7559    sts = sys$search(&myfab);
7560
7561    /* These are no longer needed */
7562    PerlMem_free(esa);
7563    PerlMem_free(rsal);
7564    PerlMem_free(rsa);
7565
7566    /* on any failure, returned the POSIX ^UP^ filespec */
7567    if (!(sts & 1)) {
7568       PerlMem_free(esal);
7569       return sts;
7570    }
7571    specdsc.dsc$a_pointer = vmspath;
7572    specdsc.dsc$w_length = vmspath_len;
7573
7574    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7575    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7576    sts = lib$fid_to_name
7577       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7578
7579   /* on any failure, returned the POSIX ^UP^ filespec */
7580   if (!(sts & 1)) {
7581      /* This can happen if user does not have permission to read directories */
7582      if (strncmp(unixpath,"\"^UP^",5) != 0)
7583        sprintf(vmspath,"\"^UP^%s\"",unixpath);
7584      else
7585        my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7586   }
7587   else {
7588     vmspath[specdsc.dsc$w_length] = 0;
7589
7590     /* Are we expecting a directory? */
7591     if (dir_flag != 0) {
7592     int i;
7593     char *eptr;
7594
7595       eptr = NULL;
7596
7597       i = specdsc.dsc$w_length - 1;
7598       while (i > 0) {
7599       int zercnt;
7600         zercnt = 0;
7601         /* Version must be '1' */
7602         if (vmspath[i--] != '1')
7603           break;
7604         /* Version delimiter is one of ".;" */
7605         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7606           break;
7607         i--;
7608         if (vmspath[i--] != 'R')
7609           break;
7610         if (vmspath[i--] != 'I')
7611           break;
7612         if (vmspath[i--] != 'D')
7613           break;
7614         if (vmspath[i--] != '.')
7615           break;
7616         eptr = &vmspath[i+1];
7617         while (i > 0) {
7618           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7619             if (vmspath[i-1] != '^') {
7620               if (zercnt != 6) {
7621                 *eptr = vmspath[i];
7622                 eptr[1] = '\0';
7623                 vmspath[i] = '.';
7624                 break;
7625               }
7626               else {
7627                 /* Get rid of 6 imaginary zero directory filename */
7628                 vmspath[i+1] = '\0';
7629               }
7630             }
7631           }
7632           if (vmspath[i] == '0')
7633             zercnt++;
7634           else
7635             zercnt = 10;
7636           i--;
7637         }
7638         break;
7639       }
7640     }
7641   }
7642   PerlMem_free(esal);
7643   return sts;
7644 }
7645
7646 /* /dev/mumble needs to be handled special.
7647    /dev/null becomes NLA0:, And there is the potential for other stuff
7648    like /dev/tty which may need to be mapped to something.
7649 */
7650
7651 static int
7652 slash_dev_special_to_vms(const char *unixptr, char *vmspath, int vmspath_len)
7653 {
7654     char * nextslash;
7655     int len;
7656     int cmp;
7657
7658     unixptr += 4;
7659     nextslash = strchr(unixptr, '/');
7660     len = strlen(unixptr);
7661     if (nextslash != NULL)
7662         len = nextslash - unixptr;
7663     cmp = strncmp("null", unixptr, 5);
7664     if (cmp == 0) {
7665         if (vmspath_len >= 6) {
7666             strcpy(vmspath, "_NLA0:");
7667             return SS$_NORMAL;
7668         }
7669     }
7670     return 0;
7671 }
7672
7673
7674 /* The built in routines do not understand perl's special needs, so
7675     doing a manual conversion from UNIX to VMS
7676
7677     If the utf8_fl is not null and points to a non-zero value, then
7678     treat 8 bit characters as UTF-8.
7679
7680     The sequence starting with '$(' and ending with ')' will be passed
7681     through with out interpretation instead of being escaped.
7682
7683   */
7684 static int
7685 posix_to_vmsspec_hardway(char *vmspath, int vmspath_len, const char *unixpath,
7686                          int dir_flag, int * utf8_fl)
7687 {
7688
7689   char *esa;
7690   const char *unixptr;
7691   const char *unixend;
7692   char *vmsptr;
7693   const char *lastslash;
7694   const char *lastdot;
7695   int unixlen;
7696   int vmslen;
7697   int dir_start;
7698   int dir_dot;
7699   int quoted;
7700   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7701   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7702
7703   if (utf8_fl != NULL)
7704     *utf8_fl = 0;
7705
7706   unixptr = unixpath;
7707   dir_dot = 0;
7708
7709   /* Ignore leading "/" characters */
7710   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7711     unixptr++;
7712   }
7713   unixlen = strlen(unixptr);
7714
7715   /* Do nothing with blank paths */
7716   if (unixlen == 0) {
7717     vmspath[0] = '\0';
7718     return SS$_NORMAL;
7719   }
7720
7721   quoted = 0;
7722   /* This could have a "^UP^ on the front */
7723   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7724     quoted = 1;
7725     unixptr+= 5;
7726     unixlen-= 5;
7727   }
7728
7729   lastslash = strrchr(unixptr,'/');
7730   lastdot = strrchr(unixptr,'.');
7731   unixend = strrchr(unixptr,'\"');
7732   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7733     unixend = unixptr + unixlen;
7734   }
7735
7736   /* last dot is last dot or past end of string */
7737   if (lastdot == NULL)
7738     lastdot = unixptr + unixlen;
7739
7740   /* if no directories, set last slash to beginning of string */
7741   if (lastslash == NULL) {
7742     lastslash = unixptr;
7743   }
7744   else {
7745     /* Watch out for trailing "." after last slash, still a directory */
7746     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7747       lastslash = unixptr + unixlen;
7748     }
7749
7750     /* Watch out for trailing ".." after last slash, still a directory */
7751     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7752       lastslash = unixptr + unixlen;
7753     }
7754
7755     /* dots in directories are aways escaped */
7756     if (lastdot < lastslash)
7757       lastdot = unixptr + unixlen;
7758   }
7759
7760   /* if (unixptr < lastslash) then we are in a directory */
7761
7762   dir_start = 0;
7763
7764   vmsptr = vmspath;
7765   vmslen = 0;
7766
7767   /* Start with the UNIX path */
7768   if (*unixptr != '/') {
7769     /* relative paths */
7770
7771     /* If allowing logical names on relative pathnames, then handle here */
7772     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7773         !decc_posix_compliant_pathnames) {
7774     char * nextslash;
7775     int seg_len;
7776     char * trn;
7777     int islnm;
7778
7779         /* Find the next slash */
7780         nextslash = strchr(unixptr,'/');
7781
7782         esa = (char *)PerlMem_malloc(vmspath_len);
7783         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7784
7785         trn = (char *)PerlMem_malloc(VMS_MAXRSS);
7786         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7787
7788         if (nextslash != NULL) {
7789
7790             seg_len = nextslash - unixptr;
7791             memcpy(esa, unixptr, seg_len);
7792             esa[seg_len] = 0;
7793         }
7794         else {
7795             seg_len = my_strlcpy(esa, unixptr, sizeof(esa));
7796         }
7797         /* trnlnm(section) */
7798         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7799
7800         if (islnm) {
7801             /* Now fix up the directory */
7802
7803             /* Split up the path to find the components */
7804             sts = vms_split_path
7805                   (trn,
7806                    &v_spec,
7807                    &v_len,
7808                    &r_spec,
7809                    &r_len,
7810                    &d_spec,
7811                    &d_len,
7812                    &n_spec,
7813                    &n_len,
7814                    &e_spec,
7815                    &e_len,
7816                    &vs_spec,
7817                    &vs_len);
7818
7819             while (sts == 0) {
7820             int cmp;
7821
7822                 /* A logical name must be a directory  or the full
7823                    specification.  It is only a full specification if
7824                    it is the only component */
7825                 if ((unixptr[seg_len] == '\0') ||
7826                     (unixptr[seg_len+1] == '\0')) {
7827
7828                     /* Is a directory being required? */
7829                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7830                         /* Not a logical name */
7831                         break;
7832                     }
7833
7834
7835                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7836                         /* This must be a directory */
7837                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7838                             vmslen = my_strlcpy(vmsptr, esa, vmspath_len - 1);
7839                             vmsptr[vmslen] = ':';
7840                             vmslen++;
7841                             vmsptr[vmslen] = '\0';
7842                             return SS$_NORMAL;
7843                         }
7844                     }
7845
7846                 }
7847
7848
7849                 /* must be dev/directory - ignore version */
7850                 if ((n_len + e_len) != 0)
7851                     break;
7852
7853                 /* transfer the volume */
7854                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7855                     memcpy(vmsptr, v_spec, v_len);
7856                     vmsptr += v_len;
7857                     vmsptr[0] = '\0';
7858                     vmslen += v_len;
7859                 }
7860
7861                 /* unroot the rooted directory */
7862                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7863                     r_spec[0] = '[';
7864                     r_spec[r_len - 1] = ']';
7865
7866                     /* This should not be there, but nothing is perfect */
7867                     if (r_len > 9) {
7868                         cmp = strcmp(&r_spec[1], "000000.");
7869                         if (cmp == 0) {
7870                             r_spec += 7;
7871                             r_spec[7] = '[';
7872                             r_len -= 7;
7873                             if (r_len == 2)
7874                                 r_len = 0;
7875                         }
7876                     }
7877                     if (r_len > 0) {
7878                         memcpy(vmsptr, r_spec, r_len);
7879                         vmsptr += r_len;
7880                         vmslen += r_len;
7881                         vmsptr[0] = '\0';
7882                     }
7883                 }
7884                 /* Bring over the directory. */
7885                 if ((d_len > 0) &&
7886                     ((d_len + vmslen) < vmspath_len)) {
7887                     d_spec[0] = '[';
7888                     d_spec[d_len - 1] = ']';
7889                     if (d_len > 9) {
7890                         cmp = strcmp(&d_spec[1], "000000.");
7891                         if (cmp == 0) {
7892                             d_spec += 7;
7893                             d_spec[7] = '[';
7894                             d_len -= 7;
7895                             if (d_len == 2)
7896                                 d_len = 0;
7897                         }
7898                     }
7899
7900                     if (r_len > 0) {
7901                         /* Remove the redundant root */
7902                         if (r_len > 0) {
7903                             /* remove the ][ */
7904                             vmsptr--;
7905                             vmslen--;
7906                             d_spec++;
7907                             d_len--;
7908                         }
7909                         memcpy(vmsptr, d_spec, d_len);
7910                             vmsptr += d_len;
7911                             vmslen += d_len;
7912                             vmsptr[0] = '\0';
7913                     }
7914                 }
7915                 break;
7916             }
7917         }
7918
7919         PerlMem_free(esa);
7920         PerlMem_free(trn);
7921     }
7922
7923     if (lastslash > unixptr) {
7924     int dotdir_seen;
7925
7926       /* skip leading ./ */
7927       dotdir_seen = 0;
7928       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7929         dotdir_seen = 1;
7930         unixptr++;
7931         unixptr++;
7932       }
7933
7934       /* Are we still in a directory? */
7935       if (unixptr <= lastslash) {
7936         *vmsptr++ = '[';
7937         vmslen = 1;
7938         dir_start = 1;
7939
7940         /* if not backing up, then it is relative forward. */
7941         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7942               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7943           *vmsptr++ = '.';
7944           vmslen++;
7945           dir_dot = 1;
7946           }
7947        }
7948        else {
7949          if (dotdir_seen) {
7950            /* Perl wants an empty directory here to tell the difference
7951             * between a DCL command and a filename
7952             */
7953           *vmsptr++ = '[';
7954           *vmsptr++ = ']';
7955           vmslen = 2;
7956         }
7957       }
7958     }
7959     else {
7960       /* Handle two special files . and .. */
7961       if (unixptr[0] == '.') {
7962         if (&unixptr[1] == unixend) {
7963           *vmsptr++ = '[';
7964           *vmsptr++ = ']';
7965           vmslen += 2;
7966           *vmsptr++ = '\0';
7967           return SS$_NORMAL;
7968         }
7969         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7970           *vmsptr++ = '[';
7971           *vmsptr++ = '-';
7972           *vmsptr++ = ']';
7973           vmslen += 3;
7974           *vmsptr++ = '\0';
7975           return SS$_NORMAL;
7976         }
7977       }
7978     }
7979   }
7980   else {        /* Absolute PATH handling */
7981   int sts;
7982   char * nextslash;
7983   int seg_len;
7984     /* Need to find out where root is */
7985
7986     /* In theory, this procedure should never get an absolute POSIX pathname
7987      * that can not be found on the POSIX root.
7988      * In practice, that can not be relied on, and things will show up
7989      * here that are a VMS device name or concealed logical name instead.
7990      * So to make things work, this procedure must be tolerant.
7991      */
7992     esa = (char *)PerlMem_malloc(vmspath_len);
7993     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7994
7995     sts = SS$_NORMAL;
7996     nextslash = strchr(&unixptr[1],'/');
7997     seg_len = 0;
7998     if (nextslash != NULL) {
7999       int cmp;
8000       seg_len = nextslash - &unixptr[1];
8001       my_strlcpy(vmspath, unixptr, seg_len + 2);
8002       cmp = 1;
8003       if (seg_len == 3) {
8004         cmp = strncmp(vmspath, "dev", 4);
8005         if (cmp == 0) {
8006             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
8007             if (sts == SS$_NORMAL)
8008                 return SS$_NORMAL;
8009         }
8010       }
8011       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
8012     }
8013
8014     if ($VMS_STATUS_SUCCESS(sts)) {
8015       /* This is verified to be a real path */
8016
8017       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
8018       if ($VMS_STATUS_SUCCESS(sts)) {
8019         vmslen = my_strlcpy(vmspath, esa, vmspath_len + 1);
8020         vmsptr = vmspath + vmslen;
8021         unixptr++;
8022         if (unixptr < lastslash) {
8023         char * rptr;
8024           vmsptr--;
8025           *vmsptr++ = '.';
8026           dir_start = 1;
8027           dir_dot = 1;
8028           if (vmslen > 7) {
8029           int cmp;
8030             rptr = vmsptr - 7;
8031             cmp = strcmp(rptr,"000000.");
8032             if (cmp == 0) {
8033               vmslen -= 7;
8034               vmsptr -= 7;
8035               vmsptr[1] = '\0';
8036             } /* removing 6 zeros */
8037           } /* vmslen < 7, no 6 zeros possible */
8038         } /* Not in a directory */
8039       } /* Posix root found */
8040       else {
8041         /* No posix root, fall back to default directory */
8042         strcpy(vmspath, "SYS$DISK:[");
8043         vmsptr = &vmspath[10];
8044         vmslen = 10;
8045         if (unixptr > lastslash) {
8046            *vmsptr = ']';
8047            vmsptr++;
8048            vmslen++;
8049         }
8050         else {
8051            dir_start = 1;
8052         }
8053       }
8054     } /* end of verified real path handling */
8055     else {
8056     int add_6zero;
8057     int islnm;
8058
8059       /* Ok, we have a device or a concealed root that is not in POSIX
8060        * or we have garbage.  Make the best of it.
8061        */
8062
8063       /* Posix to VMS destroyed this, so copy it again */
8064       my_strlcpy(vmspath, &unixptr[1], seg_len + 1);
8065       vmslen = strlen(vmspath); /* We know we're truncating. */
8066       vmsptr = &vmsptr[vmslen];
8067       islnm = 0;
8068
8069       /* Now do we need to add the fake 6 zero directory to it? */
8070       add_6zero = 1;
8071       if ((*lastslash == '/') && (nextslash < lastslash)) {
8072         /* No there is another directory */
8073         add_6zero = 0;
8074       }
8075       else {
8076       int trnend;
8077       int cmp;
8078
8079         /* now we have foo:bar or foo:[000000]bar to decide from */
8080         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
8081
8082         if (!islnm && !decc_posix_compliant_pathnames) {
8083
8084             cmp = strncmp("bin", vmspath, 4);
8085             if (cmp == 0) {
8086                 /* bin => SYS$SYSTEM: */
8087                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
8088             }
8089             else {
8090                 /* tmp => SYS$SCRATCH: */
8091                 cmp = strncmp("tmp", vmspath, 4);
8092                 if (cmp == 0) {
8093                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
8094                 }
8095             }
8096         }
8097
8098         trnend = islnm ? islnm - 1 : 0;
8099
8100         /* if this was a logical name, ']' or '>' must be present */
8101         /* if not a logical name, then assume a device and hope. */
8102         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
8103
8104         /* if log name and trailing '.' then rooted - treat as device */
8105         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
8106
8107         /* Fix me, if not a logical name, a device lookup should be
8108          * done to see if the device is file structured.  If the device
8109          * is not file structured, the 6 zeros should not be put on.
8110          *
8111          * As it is, perl is occasionally looking for dev:[000000]tty.
8112          * which looks a little strange.
8113          *
8114          * Not that easy to detect as "/dev" may be file structured with
8115          * special device files.
8116          */
8117
8118         if (!islnm && (add_6zero == 0) && (*nextslash == '/') &&
8119             (&nextslash[1] == unixend)) {
8120           /* No real directory present */
8121           add_6zero = 1;
8122         }
8123       }
8124
8125       /* Put the device delimiter on */
8126       *vmsptr++ = ':';
8127       vmslen++;
8128       unixptr = nextslash;
8129       unixptr++;
8130
8131       /* Start directory if needed */
8132       if (!islnm || add_6zero) {
8133         *vmsptr++ = '[';
8134         vmslen++;
8135         dir_start = 1;
8136       }
8137
8138       /* add fake 000000] if needed */
8139       if (add_6zero) {
8140         *vmsptr++ = '0';
8141         *vmsptr++ = '0';
8142         *vmsptr++ = '0';
8143         *vmsptr++ = '0';
8144         *vmsptr++ = '0';
8145         *vmsptr++ = '0';
8146         *vmsptr++ = ']';
8147         vmslen += 7;
8148         dir_start = 0;
8149       }
8150
8151     } /* non-POSIX translation */
8152     PerlMem_free(esa);
8153   } /* End of relative/absolute path handling */
8154
8155   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
8156     int dash_flag;
8157     int in_cnt;
8158     int out_cnt;
8159
8160     dash_flag = 0;
8161
8162     if (dir_start != 0) {
8163
8164       /* First characters in a directory are handled special */
8165       while ((*unixptr == '/') ||
8166              ((*unixptr == '.') &&
8167               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8168                 (&unixptr[1]==unixend)))) {
8169       int loop_flag;
8170
8171         loop_flag = 0;
8172
8173         /* Skip redundant / in specification */
8174         while ((*unixptr == '/') && (dir_start != 0)) {
8175           loop_flag = 1;
8176           unixptr++;
8177           if (unixptr == lastslash)
8178             break;
8179         }
8180         if (unixptr == lastslash)
8181           break;
8182
8183         /* Skip redundant ./ characters */
8184         while ((*unixptr == '.') &&
8185                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8186           loop_flag = 1;
8187           unixptr++;
8188           if (unixptr == lastslash)
8189             break;
8190           if (*unixptr == '/')
8191             unixptr++;
8192         }
8193         if (unixptr == lastslash)
8194           break;
8195
8196         /* Skip redundant ../ characters */
8197         while ((*unixptr == '.') && (unixptr[1] == '.') &&
8198              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8199           /* Set the backing up flag */
8200           loop_flag = 1;
8201           dir_dot = 0;
8202           dash_flag = 1;
8203           *vmsptr++ = '-';
8204           vmslen++;
8205           unixptr++; /* first . */
8206           unixptr++; /* second . */
8207           if (unixptr == lastslash)
8208             break;
8209           if (*unixptr == '/') /* The slash */
8210             unixptr++;
8211         }
8212         if (unixptr == lastslash)
8213           break;
8214
8215         /* To do: Perl expects /.../ to be translated to [...] on VMS */
8216         /* Not needed when VMS is pretending to be UNIX. */
8217
8218         /* Is this loop stuck because of too many dots? */
8219         if (loop_flag == 0) {
8220           /* Exit the loop and pass the rest through */
8221           break;
8222         }
8223       }
8224
8225       /* Are we done with directories yet? */
8226       if (unixptr >= lastslash) {
8227
8228         /* Watch out for trailing dots */
8229         if (dir_dot != 0) {
8230             vmslen --;
8231             vmsptr--;
8232         }
8233         *vmsptr++ = ']';
8234         vmslen++;
8235         dash_flag = 0;
8236         dir_start = 0;
8237         if (*unixptr == '/')
8238           unixptr++;
8239       }
8240       else {
8241         /* Have we stopped backing up? */
8242         if (dash_flag) {
8243           *vmsptr++ = '.';
8244           vmslen++;
8245           dash_flag = 0;
8246           /* dir_start continues to be = 1 */
8247         }
8248         if (*unixptr == '-') {
8249           *vmsptr++ = '^';
8250           *vmsptr++ = *unixptr++;
8251           vmslen += 2;
8252           dir_start = 0;
8253
8254           /* Now are we done with directories yet? */
8255           if (unixptr >= lastslash) {
8256
8257             /* Watch out for trailing dots */
8258             if (dir_dot != 0) {
8259               vmslen --;
8260               vmsptr--;
8261             }
8262
8263             *vmsptr++ = ']';
8264             vmslen++;
8265             dash_flag = 0;
8266             dir_start = 0;
8267           }
8268         }
8269       }
8270     }
8271
8272     /* All done? */
8273     if (unixptr >= unixend)
8274       break;
8275
8276     /* Normal characters - More EFS work probably needed */
8277     dir_start = 0;
8278     dir_dot = 0;
8279
8280     switch(*unixptr) {
8281     case '/':
8282         /* remove multiple / */
8283         while (unixptr[1] == '/') {
8284            unixptr++;
8285         }
8286         if (unixptr == lastslash) {
8287           /* Watch out for trailing dots */
8288           if (dir_dot != 0) {
8289             vmslen --;
8290             vmsptr--;
8291           }
8292           *vmsptr++ = ']';
8293         }
8294         else {
8295           dir_start = 1;
8296           *vmsptr++ = '.';
8297           dir_dot = 1;
8298
8299           /* To do: Perl expects /.../ to be translated to [...] on VMS */
8300           /* Not needed when VMS is pretending to be UNIX. */
8301
8302         }
8303         dash_flag = 0;
8304         if (unixptr != unixend)
8305           unixptr++;
8306         vmslen++;
8307         break;
8308     case '.':
8309         if ((unixptr < lastdot) || (unixptr < lastslash) ||
8310             (&unixptr[1] == unixend)) {
8311           *vmsptr++ = '^';
8312           *vmsptr++ = '.';
8313           vmslen += 2;
8314           unixptr++;
8315
8316           /* trailing dot ==> '^..' on VMS */
8317           if (unixptr == unixend) {
8318             *vmsptr++ = '.';
8319             vmslen++;
8320             unixptr++;
8321           }
8322           break;
8323         }
8324
8325         *vmsptr++ = *unixptr++;
8326         vmslen ++;
8327         break;
8328     case '"':
8329         if (quoted && (&unixptr[1] == unixend)) {
8330             unixptr++;
8331             break;
8332         }
8333         in_cnt = copy_expand_unix_filename_escape
8334                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8335         vmsptr += out_cnt;
8336         unixptr += in_cnt;
8337         break;
8338     case '~':
8339     case ';':
8340     case '\\':
8341     case '?':
8342     case ' ':
8343     default:
8344         in_cnt = copy_expand_unix_filename_escape
8345                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8346         vmsptr += out_cnt;
8347         unixptr += in_cnt;
8348         break;
8349     }
8350   }
8351
8352   /* Make sure directory is closed */
8353   if (unixptr == lastslash) {
8354     char *vmsptr2;
8355     vmsptr2 = vmsptr - 1;
8356
8357     if (*vmsptr2 != ']') {
8358       *vmsptr2--;
8359
8360       /* directories do not end in a dot bracket */
8361       if (*vmsptr2 == '.') {
8362         vmsptr2--;
8363
8364         /* ^. is allowed */
8365         if (*vmsptr2 != '^') {
8366           vmsptr--; /* back up over the dot */
8367         }
8368       }
8369       *vmsptr++ = ']';
8370     }
8371   }
8372   else {
8373     char *vmsptr2;
8374     /* Add a trailing dot if a file with no extension */
8375     vmsptr2 = vmsptr - 1;
8376     if ((vmslen > 1) &&
8377         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8378         (*vmsptr2 != ')') && (*lastdot != '.') && (*vmsptr2 != ':')) {
8379         *vmsptr++ = '.';
8380         vmslen++;
8381     }
8382   }
8383
8384   *vmsptr = '\0';
8385   return SS$_NORMAL;
8386 }
8387
8388 /* A convenience macro for copying dots in filenames and escaping
8389  * them when they haven't already been escaped, with guards to
8390  * avoid checking before the start of the buffer or advancing
8391  * beyond the end of it (allowing room for the NUL terminator).
8392  */
8393 #define VMSEFS_DOT_WITH_ESCAPE(vmsefsdot,vmsefsbuf,vmsefsbufsiz) STMT_START { \
8394     if ( ((vmsefsdot) > (vmsefsbuf) && *((vmsefsdot) - 1) != '^' \
8395           || ((vmsefsdot) == (vmsefsbuf))) \
8396          && (vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 3 \
8397        ) { \
8398         *((vmsefsdot)++) = '^'; \
8399     } \
8400     if ((vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 2) \
8401         *((vmsefsdot)++) = '.'; \
8402 } STMT_END
8403
8404 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8405 static char *
8406 int_tovmsspec(const char *path, char *rslt, int dir_flag, int * utf8_flag)
8407 {
8408   char *dirend;
8409   char *lastdot;
8410   char *cp1;
8411   const char *cp2;
8412   unsigned long int infront = 0, hasdir = 1;
8413   int rslt_len;
8414   int no_type_seen;
8415   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8416   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8417
8418   if (vms_debug_fileify) {
8419       if (path == NULL)
8420           fprintf(stderr, "int_tovmsspec: path = NULL\n");
8421       else
8422           fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8423   }
8424
8425   if (path == NULL) {
8426       /* If we fail, we should be setting errno */
8427       set_errno(EINVAL);
8428       set_vaxc_errno(SS$_BADPARAM);
8429       return NULL;
8430   }
8431   rslt_len = VMS_MAXRSS-1;
8432
8433   /* '.' and '..' are "[]" and "[-]" for a quick check */
8434   if (path[0] == '.') {
8435     if (path[1] == '\0') {
8436       strcpy(rslt,"[]");
8437       if (utf8_flag != NULL)
8438         *utf8_flag = 0;
8439       return rslt;
8440     }
8441     else {
8442       if (path[1] == '.' && path[2] == '\0') {
8443         strcpy(rslt,"[-]");
8444         if (utf8_flag != NULL)
8445            *utf8_flag = 0;
8446         return rslt;
8447       }
8448     }
8449   }
8450
8451    /* Posix specifications are now a native VMS format */
8452   /*--------------------------------------------------*/
8453 #if __CRTL_VER >= 80200000
8454   if (decc_posix_compliant_pathnames) {
8455     if (strncmp(path,"\"^UP^",5) == 0) {
8456       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8457       return rslt;
8458     }
8459   }
8460 #endif
8461
8462   /* This is really the only way to see if this is already in VMS format */
8463   sts = vms_split_path
8464        (path,
8465         &v_spec,
8466         &v_len,
8467         &r_spec,
8468         &r_len,
8469         &d_spec,
8470         &d_len,
8471         &n_spec,
8472         &n_len,
8473         &e_spec,
8474         &e_len,
8475         &vs_spec,
8476         &vs_len);
8477   if (sts == 0) {
8478     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8479        replacement, because the above parse just took care of most of
8480        what is needed to do vmspath when the specification is already
8481        in VMS format.
8482
8483        And if it is not already, it is easier to do the conversion as
8484        part of this routine than to call this routine and then work on
8485        the result.
8486      */
8487
8488     /* If VMS punctuation was found, it is already VMS format */
8489     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8490       if (utf8_flag != NULL)
8491         *utf8_flag = 0;
8492       my_strlcpy(rslt, path, VMS_MAXRSS);
8493       if (vms_debug_fileify) {
8494           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8495       }
8496       return rslt;
8497     }
8498     /* Now, what to do with trailing "." cases where there is no
8499        extension?  If this is a UNIX specification, and EFS characters
8500        are enabled, then the trailing "." should be converted to a "^.".
8501        But if this was already a VMS specification, then it should be
8502        left alone.
8503
8504        So in the case of ambiguity, leave the specification alone.
8505      */
8506
8507
8508     /* If there is a possibility of UTF8, then if any UTF8 characters
8509         are present, then they must be converted to VTF-7
8510      */
8511     if (utf8_flag != NULL)
8512       *utf8_flag = 0;
8513     my_strlcpy(rslt, path, VMS_MAXRSS);
8514     if (vms_debug_fileify) {
8515         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8516     }
8517     return rslt;
8518   }
8519
8520   dirend = strrchr(path,'/');
8521
8522   if (dirend == NULL) {
8523      /* If we get here with no Unix directory delimiters, then this is an
8524       * ambiguous file specification, such as a Unix glob specification, a
8525       * shell or make macro, or a filespec that would be valid except for
8526       * unescaped extended characters.  The safest thing if it's a macro
8527       * is to pass it through as-is.
8528       */
8529       if (strstr(path, "$(")) {
8530           my_strlcpy(rslt, path, VMS_MAXRSS);
8531           if (vms_debug_fileify) {
8532               fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8533           }
8534           return rslt;
8535       }
8536       hasdir = 0;
8537   }
8538   else if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
8539     if (!*(dirend+2)) dirend +=2;
8540     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8541     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8542   }
8543
8544   cp1 = rslt;
8545   cp2 = path;
8546   lastdot = strrchr(cp2,'.');
8547   if (*cp2 == '/') {
8548     char *trndev;
8549     int islnm, rooted;
8550     STRLEN trnend;
8551
8552     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8553     if (!*(cp2+1)) {
8554       if (decc_disable_posix_root) {
8555         strcpy(rslt,"sys$disk:[000000]");
8556       }
8557       else {
8558         strcpy(rslt,"sys$posix_root:[000000]");
8559       }
8560       if (utf8_flag != NULL)
8561         *utf8_flag = 0;
8562       if (vms_debug_fileify) {
8563           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8564       }
8565       return rslt;
8566     }
8567     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8568     *cp1 = '\0';
8569     trndev = (char *)PerlMem_malloc(VMS_MAXRSS);
8570     if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8571     islnm =  simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8572
8573      /* DECC special handling */
8574     if (!islnm) {
8575       if (strcmp(rslt,"bin") == 0) {
8576         strcpy(rslt,"sys$system");
8577         cp1 = rslt + 10;
8578         *cp1 = 0;
8579         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8580       }
8581       else if (strcmp(rslt,"tmp") == 0) {
8582         strcpy(rslt,"sys$scratch");
8583         cp1 = rslt + 11;
8584         *cp1 = 0;
8585         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8586       }
8587       else if (!decc_disable_posix_root) {
8588         strcpy(rslt, "sys$posix_root");
8589         cp1 = rslt + 14;
8590         *cp1 = 0;
8591         cp2 = path;
8592         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8593         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8594       }
8595       else if (strcmp(rslt,"dev") == 0) {
8596         if (strncmp(cp2,"/null", 5) == 0) {
8597           if ((cp2[5] == 0) || (cp2[5] == '/')) {
8598             strcpy(rslt,"NLA0");
8599             cp1 = rslt + 4;
8600             *cp1 = 0;
8601             cp2 = cp2 + 5;
8602             islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8603           }
8604         }
8605       }
8606     }
8607
8608     trnend = islnm ? strlen(trndev) - 1 : 0;
8609     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8610     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8611     /* If the first element of the path is a logical name, determine
8612      * whether it has to be translated so we can add more directories. */
8613     if (!islnm || rooted) {
8614       *(cp1++) = ':';
8615       *(cp1++) = '[';
8616       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8617       else cp2++;
8618     }
8619     else {
8620       if (cp2 != dirend) {
8621         my_strlcpy(rslt, trndev, VMS_MAXRSS);
8622         cp1 = rslt + trnend;
8623         if (*cp2 != 0) {
8624           *(cp1++) = '.';
8625           cp2++;
8626         }
8627       }
8628       else {
8629         if (decc_disable_posix_root) {
8630           *(cp1++) = ':';
8631           hasdir = 0;
8632         }
8633       }
8634     }
8635     PerlMem_free(trndev);
8636   }
8637   else if (hasdir) {
8638     *(cp1++) = '[';
8639     if (*cp2 == '.') {
8640       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8641         cp2 += 2;         /* skip over "./" - it's redundant */
8642         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8643       }
8644       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8645         *(cp1++) = '-';                                 /* "../" --> "-" */
8646         cp2 += 3;
8647       }
8648       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8649                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8650         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8651         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8652         cp2 += 4;
8653       }
8654       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8655         /* Escape the extra dots in EFS file specifications */
8656         *(cp1++) = '^';
8657       }
8658       if (cp2 > dirend) cp2 = dirend;
8659     }
8660     else *(cp1++) = '.';
8661   }
8662   for (; cp2 < dirend; cp2++) {
8663     if (*cp2 == '/') {
8664       if (*(cp2-1) == '/') continue;
8665       if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.';
8666       infront = 0;
8667     }
8668     else if (!infront && *cp2 == '.') {
8669       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8670       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8671       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8672         if (cp1 > rslt && (*(cp1-1) == '-' || *(cp1-1) == '[')) *(cp1++) = '-'; /* handle "../" */
8673         else if (cp1 > rslt + 1 && *(cp1-2) == '[') *(cp1-1) = '-';
8674         else {
8675           *(cp1++) = '-';
8676         }
8677         cp2 += 2;
8678         if (cp2 == dirend) break;
8679       }
8680       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8681                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8682         if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8683         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8684         if (!*(cp2+3)) {
8685           *(cp1++) = '.';  /* Simulate trailing '/' */
8686           cp2 += 2;  /* for loop will incr this to == dirend */
8687         }
8688         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8689       }
8690       else {
8691         if (decc_efs_charset == 0) {
8692           if (cp1 > rslt && *(cp1-1) == '^')
8693             cp1--;         /* remove the escape, if any */
8694           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8695         }
8696         else {
8697           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8698         }
8699       }
8700     }
8701     else {
8702       if (!infront && cp1 > rslt && *(cp1-1) == '-')  *(cp1++) = '.';
8703       if (*cp2 == '.') {
8704         if (decc_efs_charset == 0) {
8705           if (cp1 > rslt && *(cp1-1) == '^')
8706             cp1--;         /* remove the escape, if any */
8707           *(cp1++) = '_';
8708         }
8709         else {
8710           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8711         }
8712       }
8713       else {
8714         int out_cnt;
8715         cp2 += copy_expand_unix_filename_escape(cp1, cp2, &out_cnt, utf8_flag);
8716         cp2--; /* we're in a loop that will increment this */
8717         cp1 += out_cnt;
8718       }
8719       infront = 1;
8720     }
8721   }
8722   if (cp1 > rslt && *(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8723   if (hasdir) *(cp1++) = ']';
8724   if (*cp2 && *cp2 == '/') cp2++;  /* check in case we ended with trailing '/' */
8725   no_type_seen = 0;
8726   if (cp2 > lastdot)
8727     no_type_seen = 1;
8728   while (*cp2) {
8729     switch(*cp2) {
8730     case '?':
8731         if (decc_efs_charset == 0)
8732           *(cp1++) = '%';
8733         else
8734           *(cp1++) = '?';
8735         cp2++;
8736     case ' ':
8737         if (cp2 >= path && (cp2 == path || *(cp2-1) != '^')) /* not previously escaped */
8738             *(cp1)++ = '^';
8739         *(cp1)++ = '_';
8740         cp2++;
8741         break;
8742     case '.':
8743         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8744             decc_readdir_dropdotnotype) {
8745           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8746           cp2++;
8747
8748           /* trailing dot ==> '^..' on VMS */
8749           if (*cp2 == '\0') {
8750             *(cp1++) = '.';
8751             no_type_seen = 0;
8752           }
8753         }
8754         else {
8755           *(cp1++) = *(cp2++);
8756           no_type_seen = 0;
8757         }
8758         break;
8759     case '$':
8760          /* This could be a macro to be passed through */
8761         *(cp1++) = *(cp2++);
8762         if (*cp2 == '(') {
8763         const char * save_cp2;
8764         char * save_cp1;
8765         int is_macro;
8766
8767             /* paranoid check */
8768             save_cp2 = cp2;
8769             save_cp1 = cp1;
8770             is_macro = 0;
8771
8772             /* Test through */
8773             *(cp1++) = *(cp2++);
8774             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8775                 *(cp1++) = *(cp2++);
8776                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8777                     *(cp1++) = *(cp2++);
8778                 }
8779                 if (*cp2 == ')') {
8780                     *(cp1++) = *(cp2++);
8781                     is_macro = 1;
8782                 }
8783             }
8784             if (is_macro == 0) {
8785                 /* Not really a macro - never mind */
8786                 cp2 = save_cp2;
8787                 cp1 = save_cp1;
8788             }
8789         }
8790         break;
8791     case '\"':
8792     case '~':
8793     case '`':
8794     case '!':
8795     case '#':
8796     case '%':
8797     case '^':
8798         /* Don't escape again if following character is
8799          * already something we escape.
8800          */
8801         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8802             *(cp1++) = *(cp2++);
8803             break;
8804         }
8805         /* But otherwise fall through and escape it. */
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     case '<':
8821     case '>':
8822         if (cp2 >= path && *(cp2-1) != '^') /* not previously escaped */
8823             *(cp1++) = '^';
8824         *(cp1++) = *(cp2++);
8825         break;
8826     case ';':
8827         /* If it doesn't look like the beginning of a version number,
8828          * or we've been promised there are no version numbers, then
8829          * escape it.
8830          */
8831         if (decc_filename_unix_no_version) {
8832           *(cp1++) = '^';
8833         }
8834         else {
8835           size_t all_nums = strspn(cp2+1, "0123456789");
8836           if (all_nums > 5 || *(cp2 + all_nums + 1) != '\0')
8837             *(cp1++) = '^';
8838         }
8839         *(cp1++) = *(cp2++);
8840         break;
8841     default:
8842         *(cp1++) = *(cp2++);
8843     }
8844   }
8845   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8846   char *lcp1;
8847     lcp1 = cp1;
8848     lcp1--;
8849      /* Fix me for "^]", but that requires making sure that you do
8850       * not back up past the start of the filename
8851       */
8852     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8853       *cp1++ = '.';
8854   }
8855   *cp1 = '\0';
8856
8857   if (utf8_flag != NULL)
8858     *utf8_flag = 0;
8859   if (vms_debug_fileify) {
8860       fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8861   }
8862   return rslt;
8863
8864 }  /* end of int_tovmsspec() */
8865
8866
8867 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8868 static char *
8869 mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag)
8870 {
8871     static char __tovmsspec_retbuf[VMS_MAXRSS];
8872     char * vmsspec, *ret_spec, *ret_buf;
8873
8874     vmsspec = NULL;
8875     ret_buf = buf;
8876     if (ret_buf == NULL) {
8877         if (ts) {
8878             Newx(vmsspec, VMS_MAXRSS, char);
8879             if (vmsspec == NULL)
8880                 _ckvmssts(SS$_INSFMEM);
8881             ret_buf = vmsspec;
8882         } else {
8883             ret_buf = __tovmsspec_retbuf;
8884         }
8885     }
8886
8887     ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
8888
8889     if (ret_spec == NULL) {
8890        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
8891        if (vmsspec)
8892            Safefree(vmsspec);
8893     }
8894
8895     return ret_spec;
8896
8897 }  /* end of mp_do_tovmsspec() */
8898 /*}}}*/
8899 /* External entry points */
8900 char *
8901 Perl_tovmsspec(pTHX_ const char *path, char *buf)
8902 {
8903     return do_tovmsspec(path, buf, 0, NULL);
8904 }
8905
8906 char *
8907 Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8908 {
8909     return do_tovmsspec(path, buf, 1, NULL);
8910 }
8911
8912 char *
8913 Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8914 {
8915     return do_tovmsspec(path, buf, 0, utf8_fl);
8916 }
8917
8918 char *
8919 Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8920 {
8921     return do_tovmsspec(path, buf, 1, utf8_fl);
8922 }
8923
8924 /*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
8925 /* Internal routine for use with out an explicit context present */
8926 static char *
8927 int_tovmspath(const char *path, char *buf, int * utf8_fl)
8928 {
8929     char * ret_spec, *pathified;
8930
8931     if (path == NULL)
8932         return NULL;
8933
8934     pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8935     if (pathified == NULL)
8936         _ckvmssts_noperl(SS$_INSFMEM);
8937
8938     ret_spec = int_pathify_dirspec(path, pathified);
8939
8940     if (ret_spec == NULL) {
8941         PerlMem_free(pathified);
8942         return NULL;
8943     }
8944
8945     ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
8946
8947     PerlMem_free(pathified);
8948     return ret_spec;
8949
8950 }
8951
8952 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8953 static char *
8954 mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl)
8955 {
8956   static char __tovmspath_retbuf[VMS_MAXRSS];
8957   int vmslen;
8958   char *pathified, *vmsified, *cp;
8959
8960   if (path == NULL) return NULL;
8961   pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8962   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8963   if (int_pathify_dirspec(path, pathified) == NULL) {
8964     PerlMem_free(pathified);
8965     return NULL;
8966   }
8967
8968   vmsified = NULL;
8969   if (buf == NULL)
8970      Newx(vmsified, VMS_MAXRSS, char);
8971   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8972     PerlMem_free(pathified);
8973     if (vmsified) Safefree(vmsified);
8974     return NULL;
8975   }
8976   PerlMem_free(pathified);
8977   if (buf) {
8978     return buf;
8979   }
8980   else if (ts) {
8981     vmslen = strlen(vmsified);
8982     Newx(cp,vmslen+1,char);
8983     memcpy(cp,vmsified,vmslen);
8984     cp[vmslen] = '\0';
8985     Safefree(vmsified);
8986     return cp;
8987   }
8988   else {
8989     my_strlcpy(__tovmspath_retbuf, vmsified, sizeof(__tovmspath_retbuf));
8990     Safefree(vmsified);
8991     return __tovmspath_retbuf;
8992   }
8993
8994 }  /* end of do_tovmspath() */
8995 /*}}}*/
8996 /* External entry points */
8997 char *
8998 Perl_tovmspath(pTHX_ const char *path, char *buf)
8999 {
9000     return do_tovmspath(path, buf, 0, NULL);
9001 }
9002
9003 char *
9004 Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
9005 {
9006     return do_tovmspath(path, buf, 1, NULL);
9007 }
9008
9009 char *
9010 Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
9011 {
9012     return do_tovmspath(path, buf, 0, utf8_fl);
9013 }
9014
9015 char *
9016 Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
9017 {
9018     return do_tovmspath(path, buf, 1, utf8_fl);
9019 }
9020
9021
9022 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
9023 static char *
9024 mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl)
9025 {
9026   static char __tounixpath_retbuf[VMS_MAXRSS];
9027   int unixlen;
9028   char *pathified, *unixified, *cp;
9029
9030   if (path == NULL) return NULL;
9031   pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
9032   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
9033   if (int_pathify_dirspec(path, pathified) == NULL) {
9034     PerlMem_free(pathified);
9035     return NULL;
9036   }
9037
9038   unixified = NULL;
9039   if (buf == NULL) {
9040       Newx(unixified, VMS_MAXRSS, char);
9041   }
9042   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
9043     PerlMem_free(pathified);
9044     if (unixified) Safefree(unixified);
9045     return NULL;
9046   }
9047   PerlMem_free(pathified);
9048   if (buf) {
9049     return buf;
9050   }
9051   else if (ts) {
9052     unixlen = strlen(unixified);
9053     Newx(cp,unixlen+1,char);
9054     memcpy(cp,unixified,unixlen);
9055     cp[unixlen] = '\0';
9056     Safefree(unixified);
9057     return cp;
9058   }
9059   else {
9060     my_strlcpy(__tounixpath_retbuf, unixified, sizeof(__tounixpath_retbuf));
9061     Safefree(unixified);
9062     return __tounixpath_retbuf;
9063   }
9064
9065 }  /* end of do_tounixpath() */
9066 /*}}}*/
9067 /* External entry points */
9068 char *
9069 Perl_tounixpath(pTHX_ const char *path, char *buf)
9070 {
9071     return do_tounixpath(path, buf, 0, NULL);
9072 }
9073
9074 char *
9075 Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
9076 {
9077     return do_tounixpath(path, buf, 1, NULL);
9078 }
9079
9080 char *
9081 Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9082 {
9083     return do_tounixpath(path, buf, 0, utf8_fl);
9084 }
9085
9086 char *
9087 Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9088 {
9089     return do_tounixpath(path, buf, 1, utf8_fl);
9090 }
9091
9092 /*
9093  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
9094  *
9095  *****************************************************************************
9096  *                                                                           *
9097  *  Copyright (C) 1989-1994, 2007 by                                         *
9098  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
9099  *                                                                           *
9100  *  Permission is hereby granted for the reproduction of this software       *
9101  *  on condition that this copyright notice is included in source            *
9102  *  distributions of the software.  The code may be modified and             *
9103  *  distributed under the same terms as Perl itself.                         *
9104  *                                                                           *
9105  *  27-Aug-1994 Modified for inclusion in perl5                              *
9106  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
9107  *****************************************************************************
9108  */
9109
9110 /*
9111  * getredirection() is intended to aid in porting C programs
9112  * to VMS (Vax-11 C).  The native VMS environment does not support
9113  * '>' and '<' I/O redirection, or command line wild card expansion,
9114  * or a command line pipe mechanism using the '|' AND background
9115  * command execution '&'.  All of these capabilities are provided to any
9116  * C program which calls this procedure as the first thing in the
9117  * main program.
9118  * The piping mechanism will probably work with almost any 'filter' type
9119  * of program.  With suitable modification, it may useful for other
9120  * portability problems as well.
9121  *
9122  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
9123  */
9124 struct list_item
9125     {
9126     struct list_item *next;
9127     char *value;
9128     };
9129
9130 static void add_item(struct list_item **head,
9131                      struct list_item **tail,
9132                      char *value,
9133                      int *count);
9134
9135 static void mp_expand_wild_cards(pTHX_ char *item,
9136                                 struct list_item **head,
9137                                 struct list_item **tail,
9138                                 int *count);
9139
9140 static int background_process(pTHX_ int argc, char **argv);
9141
9142 static void pipe_and_fork(pTHX_ char **cmargv);
9143
9144 /*{{{ void getredirection(int *ac, char ***av)*/
9145 static void
9146 mp_getredirection(pTHX_ int *ac, char ***av)
9147 /*
9148  * Process vms redirection arg's.  Exit if any error is seen.
9149  * If getredirection() processes an argument, it is erased
9150  * from the vector.  getredirection() returns a new argc and argv value.
9151  * In the event that a background command is requested (by a trailing "&"),
9152  * this routine creates a background subprocess, and simply exits the program.
9153  *
9154  * Warning: do not try to simplify the code for vms.  The code
9155  * presupposes that getredirection() is called before any data is
9156  * read from stdin or written to stdout.
9157  *
9158  * Normal usage is as follows:
9159  *
9160  *      main(argc, argv)
9161  *      int             argc;
9162  *      char            *argv[];
9163  *      {
9164  *              getredirection(&argc, &argv);
9165  *      }
9166  */
9167 {
9168     int                 argc = *ac;     /* Argument Count         */
9169     char                **argv = *av;   /* Argument Vector        */
9170     char                *ap;            /* Argument pointer       */
9171     int                 j;              /* argv[] index           */
9172     int                 item_count = 0; /* Count of Items in List */
9173     struct list_item    *list_head = 0; /* First Item in List       */
9174     struct list_item    *list_tail;     /* Last Item in List        */
9175     char                *in = NULL;     /* Input File Name          */
9176     char                *out = NULL;    /* Output File Name         */
9177     char                *outmode = "w"; /* Mode to Open Output File */
9178     char                *err = NULL;    /* Error File Name          */
9179     char                *errmode = "w"; /* Mode to Open Error File  */
9180     int                 cmargc = 0;     /* Piped Command Arg Count  */
9181     char                **cmargv = NULL;/* Piped Command Arg Vector */
9182
9183     /*
9184      * First handle the case where the last thing on the line ends with
9185      * a '&'.  This indicates the desire for the command to be run in a
9186      * subprocess, so we satisfy that desire.
9187      */
9188     ap = argv[argc-1];
9189     if (0 == strcmp("&", ap))
9190        exit(background_process(aTHX_ --argc, argv));
9191     if (*ap && '&' == ap[strlen(ap)-1])
9192         {
9193         ap[strlen(ap)-1] = '\0';
9194        exit(background_process(aTHX_ argc, argv));
9195         }
9196     /*
9197      * Now we handle the general redirection cases that involve '>', '>>',
9198      * '<', and pipes '|'.
9199      */
9200     for (j = 0; j < argc; ++j)
9201         {
9202         if (0 == strcmp("<", argv[j]))
9203             {
9204             if (j+1 >= argc)
9205                 {
9206                 fprintf(stderr,"No input file after < on command line");
9207                 exit(LIB$_WRONUMARG);
9208                 }
9209             in = argv[++j];
9210             continue;
9211             }
9212         if ('<' == *(ap = argv[j]))
9213             {
9214             in = 1 + ap;
9215             continue;
9216             }
9217         if (0 == strcmp(">", ap))
9218             {
9219             if (j+1 >= argc)
9220                 {
9221                 fprintf(stderr,"No output file after > on command line");
9222                 exit(LIB$_WRONUMARG);
9223                 }
9224             out = argv[++j];
9225             continue;
9226             }
9227         if ('>' == *ap)
9228             {
9229             if ('>' == ap[1])
9230                 {
9231                 outmode = "a";
9232                 if ('\0' == ap[2])
9233                     out = argv[++j];
9234                 else
9235                     out = 2 + ap;
9236                 }
9237             else
9238                 out = 1 + ap;
9239             if (j >= argc)
9240                 {
9241                 fprintf(stderr,"No output file after > or >> on command line");
9242                 exit(LIB$_WRONUMARG);
9243                 }
9244             continue;
9245             }
9246         if (('2' == *ap) && ('>' == ap[1]))
9247             {
9248             if ('>' == ap[2])
9249                 {
9250                 errmode = "a";
9251                 if ('\0' == ap[3])
9252                     err = argv[++j];
9253                 else
9254                     err = 3 + ap;
9255                 }
9256             else
9257                 if ('\0' == ap[2])
9258                     err = argv[++j];
9259                 else
9260                     err = 2 + ap;
9261             if (j >= argc)
9262                 {
9263                 fprintf(stderr,"No output file after 2> or 2>> on command line");
9264                 exit(LIB$_WRONUMARG);
9265                 }
9266             continue;
9267             }
9268         if (0 == strcmp("|", argv[j]))
9269             {
9270             if (j+1 >= argc)
9271                 {
9272                 fprintf(stderr,"No command into which to pipe on command line");
9273                 exit(LIB$_WRONUMARG);
9274                 }
9275             cmargc = argc-(j+1);
9276             cmargv = &argv[j+1];
9277             argc = j;
9278             continue;
9279             }
9280         if ('|' == *(ap = argv[j]))
9281             {
9282             ++argv[j];
9283             cmargc = argc-j;
9284             cmargv = &argv[j];
9285             argc = j;
9286             continue;
9287             }
9288         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9289         }
9290     /*
9291      * Allocate and fill in the new argument vector, Some Unix's terminate
9292      * the list with an extra null pointer.
9293      */
9294     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9295     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9296     *av = argv;
9297     for (j = 0; j < item_count; ++j, list_head = list_head->next)
9298         argv[j] = list_head->value;
9299     *ac = item_count;
9300     if (cmargv != NULL)
9301         {
9302         if (out != NULL)
9303             {
9304             fprintf(stderr,"'|' and '>' may not both be specified on command line");
9305             exit(LIB$_INVARGORD);
9306             }
9307         pipe_and_fork(aTHX_ cmargv);
9308         }
9309
9310     /* Check for input from a pipe (mailbox) */
9311
9312     if (in == NULL && 1 == isapipe(0))
9313         {
9314         char mbxname[L_tmpnam];
9315         long int bufsize;
9316         long int dvi_item = DVI$_DEVBUFSIZ;
9317         $DESCRIPTOR(mbxnam, "");
9318         $DESCRIPTOR(mbxdevnam, "");
9319
9320         /* Input from a pipe, reopen it in binary mode to disable       */
9321         /* carriage control processing.                                 */
9322
9323         fgetname(stdin, mbxname, 1);
9324         mbxnam.dsc$a_pointer = mbxname;
9325         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9326         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9327         mbxdevnam.dsc$a_pointer = mbxname;
9328         mbxdevnam.dsc$w_length = sizeof(mbxname);
9329         dvi_item = DVI$_DEVNAM;
9330         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9331         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9332         set_errno(0);
9333         set_vaxc_errno(1);
9334         freopen(mbxname, "rb", stdin);
9335         if (errno != 0)
9336             {
9337             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9338             exit(vaxc$errno);
9339             }
9340         }
9341     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9342         {
9343         fprintf(stderr,"Can't open input file %s as stdin",in);
9344         exit(vaxc$errno);
9345         }
9346     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9347         {
9348         fprintf(stderr,"Can't open output file %s as stdout",out);
9349         exit(vaxc$errno);
9350         }
9351         if (out != NULL) vmssetuserlnm("SYS$OUTPUT", out);
9352
9353     if (err != NULL) {
9354         if (strcmp(err,"&1") == 0) {
9355             dup2(fileno(stdout), fileno(stderr));
9356             vmssetuserlnm("SYS$ERROR", "SYS$OUTPUT");
9357         } else {
9358         FILE *tmperr;
9359         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9360             {
9361             fprintf(stderr,"Can't open error file %s as stderr",err);
9362             exit(vaxc$errno);
9363             }
9364             fclose(tmperr);
9365            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9366                 {
9367                 exit(vaxc$errno);
9368                 }
9369             vmssetuserlnm("SYS$ERROR", err);
9370         }
9371         }
9372 #ifdef ARGPROC_DEBUG
9373     PerlIO_printf(Perl_debug_log, "Arglist:\n");
9374     for (j = 0; j < *ac;  ++j)
9375         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9376 #endif
9377    /* Clear errors we may have hit expanding wildcards, so they don't
9378       show up in Perl's $! later */
9379    set_errno(0); set_vaxc_errno(1);
9380 }  /* end of getredirection() */
9381 /*}}}*/
9382
9383 static void
9384 add_item(struct list_item **head, struct list_item **tail, char *value, int *count)
9385 {
9386     if (*head == 0)
9387         {
9388         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9389         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9390         *tail = *head;
9391         }
9392     else {
9393         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9394         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9395         *tail = (*tail)->next;
9396         }
9397     (*tail)->value = value;
9398     ++(*count);
9399 }
9400
9401 static void
9402 mp_expand_wild_cards(pTHX_ char *item, struct list_item **head,
9403                      struct list_item **tail, int *count)
9404 {
9405     int expcount = 0;
9406     unsigned long int context = 0;
9407     int isunix = 0;
9408     int item_len = 0;
9409     char *had_version;
9410     char *had_device;
9411     int had_directory;
9412     char *devdir,*cp;
9413     char *vmsspec;
9414     $DESCRIPTOR(filespec, "");
9415     $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9416     $DESCRIPTOR(resultspec, "");
9417     unsigned long int lff_flags = 0;
9418     int sts;
9419     int rms_sts;
9420
9421 #ifdef VMS_LONGNAME_SUPPORT
9422     lff_flags = LIB$M_FIL_LONG_NAMES;
9423 #endif
9424
9425     for (cp = item; *cp; cp++) {
9426         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9427         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9428     }
9429     if (!*cp || isspace(*cp))
9430         {
9431         add_item(head, tail, item, count);
9432         return;
9433         }
9434     else
9435         {
9436      /* "double quoted" wild card expressions pass as is */
9437      /* From DCL that means using e.g.:                  */
9438      /* perl program """perl.*"""                        */
9439      item_len = strlen(item);
9440      if ( '"' == *item && '"' == item[item_len-1] )
9441        {
9442        item++;
9443        item[item_len-2] = '\0';
9444        add_item(head, tail, item, count);
9445        return;
9446        }
9447      }
9448     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9449     resultspec.dsc$b_class = DSC$K_CLASS_D;
9450     resultspec.dsc$a_pointer = NULL;
9451     vmsspec = (char *)PerlMem_malloc(VMS_MAXRSS);
9452     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9453     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9454       filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9455     if (!isunix || !filespec.dsc$a_pointer)
9456       filespec.dsc$a_pointer = item;
9457     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9458     /*
9459      * Only return version specs, if the caller specified a version
9460      */
9461     had_version = strchr(item, ';');
9462     /*
9463      * Only return device and directory specs, if the caller specified either.
9464      */
9465     had_device = strchr(item, ':');
9466     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9467
9468     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9469                                  (&filespec, &resultspec, &context,
9470                                   &defaultspec, 0, &rms_sts, &lff_flags)))
9471         {
9472         char *string;
9473         char *c;
9474
9475         string = (char *)PerlMem_malloc(resultspec.dsc$w_length+1);
9476         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9477         my_strlcpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length+1);
9478         if (NULL == had_version)
9479             *(strrchr(string, ';')) = '\0';
9480         if ((!had_directory) && (had_device == NULL))
9481             {
9482             if (NULL == (devdir = strrchr(string, ']')))
9483                 devdir = strrchr(string, '>');
9484             my_strlcpy(string, devdir + 1, resultspec.dsc$w_length+1);
9485             }
9486         /*
9487          * Be consistent with what the C RTL has already done to the rest of
9488          * the argv items and lowercase all of these names.
9489          */
9490         if (!decc_efs_case_preserve) {
9491             for (c = string; *c; ++c)
9492             if (isupper(*c))
9493                 *c = tolower(*c);
9494         }
9495         if (isunix) trim_unixpath(string,item,1);
9496         add_item(head, tail, string, count);
9497         ++expcount;
9498     }
9499     PerlMem_free(vmsspec);
9500     if (sts != RMS$_NMF)
9501         {
9502         set_vaxc_errno(sts);
9503         switch (sts)
9504             {
9505             case RMS$_FNF: case RMS$_DNF:
9506                 set_errno(ENOENT); break;
9507             case RMS$_DIR:
9508                 set_errno(ENOTDIR); break;
9509             case RMS$_DEV:
9510                 set_errno(ENODEV); break;
9511             case RMS$_FNM: case RMS$_SYN:
9512                 set_errno(EINVAL); break;
9513             case RMS$_PRV:
9514                 set_errno(EACCES); break;
9515             default:
9516                 _ckvmssts_noperl(sts);
9517             }
9518         }
9519     if (expcount == 0)
9520         add_item(head, tail, item, count);
9521     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9522     _ckvmssts_noperl(lib$find_file_end(&context));
9523 }
9524
9525
9526 static void
9527 pipe_and_fork(pTHX_ char **cmargv)
9528 {
9529     PerlIO *fp;
9530     struct dsc$descriptor_s *vmscmd;
9531     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9532     int sts, j, l, ismcr, quote, tquote = 0;
9533
9534     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9535     vms_execfree(vmscmd);
9536
9537     j = l = 0;
9538     p = subcmd;
9539     q = cmargv[0];
9540     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
9541               && toupper(*(q+2)) == 'R' && !*(q+3);
9542
9543     while (q && l < MAX_DCL_LINE_LENGTH) {
9544         if (!*q) {
9545             if (j > 0 && quote) {
9546                 *p++ = '"';
9547                 l++;
9548             }
9549             q = cmargv[++j];
9550             if (q) {
9551                 if (ismcr && j > 1) quote = 1;
9552                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
9553                 *p++ = ' ';
9554                 l++;
9555                 if (quote || tquote) {
9556                     *p++ = '"';
9557                     l++;
9558                 }
9559             }
9560         } else {
9561             if ((quote||tquote) && *q == '"') {
9562                 *p++ = '"';
9563                 l++;
9564             }
9565             *p++ = *q++;
9566             l++;
9567         }
9568     }
9569     *p = '\0';
9570
9571     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9572     if (fp == NULL) {
9573         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9574     }
9575 }
9576
9577 static int
9578 background_process(pTHX_ int argc, char **argv)
9579 {
9580     char command[MAX_DCL_SYMBOL + 1] = "$";
9581     $DESCRIPTOR(value, "");
9582     static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9583     static $DESCRIPTOR(null, "NLA0:");
9584     static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9585     char pidstring[80];
9586     $DESCRIPTOR(pidstr, "");
9587     int pid;
9588     unsigned long int flags = 17, one = 1, retsts;
9589     int len;
9590
9591     len = my_strlcat(command, argv[0], sizeof(command));
9592     while (--argc && (len < MAX_DCL_SYMBOL))
9593         {
9594         my_strlcat(command, " \"", sizeof(command));
9595         my_strlcat(command, *(++argv), sizeof(command));
9596         len = my_strlcat(command, "\"", sizeof(command));
9597         }
9598     value.dsc$a_pointer = command;
9599     value.dsc$w_length = strlen(value.dsc$a_pointer);
9600     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9601     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9602     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9603         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9604     }
9605     else {
9606         _ckvmssts_noperl(retsts);
9607     }
9608 #ifdef ARGPROC_DEBUG
9609     PerlIO_printf(Perl_debug_log, "%s\n", command);
9610 #endif
9611     sprintf(pidstring, "%08X", pid);
9612     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9613     pidstr.dsc$a_pointer = pidstring;
9614     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9615     lib$set_symbol(&pidsymbol, &pidstr);
9616     return(SS$_NORMAL);
9617 }
9618 /*}}}*/
9619 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9620
9621
9622 /* OS-specific initialization at image activation (not thread startup) */
9623 /* Older VAXC header files lack these constants */
9624 #ifndef JPI$_RIGHTS_SIZE
9625 #  define JPI$_RIGHTS_SIZE 817
9626 #endif
9627 #ifndef KGB$M_SUBSYSTEM
9628 #  define KGB$M_SUBSYSTEM 0x8
9629 #endif
9630
9631 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9632
9633 /*{{{void vms_image_init(int *, char ***)*/
9634 void
9635 vms_image_init(int *argcp, char ***argvp)
9636 {
9637   int status;
9638   char eqv[LNM$C_NAMLENGTH+1] = "";
9639   unsigned int len, tabct = 8, tabidx = 0;
9640   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9641   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9642   unsigned short int dummy, rlen;
9643   struct dsc$descriptor_s **tabvec;
9644 #if defined(PERL_IMPLICIT_CONTEXT)
9645   pTHX = NULL;
9646 #endif
9647   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
9648                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
9649                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9650                                  {          0,                0,    0,      0} };
9651
9652 #ifdef KILL_BY_SIGPRC
9653     Perl_csighandler_init();
9654 #endif
9655
9656     /* This was moved from the pre-image init handler because on threaded */
9657     /* Perl it was always returning 0 for the default value. */
9658     status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9659     if (status > 0) {
9660         int s;
9661         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9662         if (s > 0) {
9663             int initial;
9664             initial = decc$feature_get_value(s, 4);
9665             if (initial > 0) {
9666                 /* initial is: 0 if nothing has set the feature */
9667                 /*            -1 if initialized to default */
9668                 /*             1 if set by logical name */
9669                 /*             2 if set by decc$feature_set_value */
9670                 decc_disable_posix_root = decc$feature_get_value(s, 1);
9671
9672                 /* If the value is not valid, force the feature off */
9673                 if (decc_disable_posix_root < 0) {
9674                     decc$feature_set_value(s, 1, 1);
9675                     decc_disable_posix_root = 1;
9676                 }
9677             }
9678             else {
9679                 /* Nothing has asked for it explicitly, so use our own default. */
9680                 decc_disable_posix_root = 1;
9681                 decc$feature_set_value(s, 1, 1);
9682             }
9683         }
9684     }
9685
9686   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9687   _ckvmssts_noperl(iosb[0]);
9688   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9689     if (iprv[i]) {           /* Running image installed with privs? */
9690       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
9691       will_taint = TRUE;
9692       break;
9693     }
9694   }
9695   /* Rights identifiers might trigger tainting as well. */
9696   if (!will_taint && (rlen || rsz)) {
9697     while (rlen < rsz) {
9698       /* We didn't get all the identifiers on the first pass.  Allocate a
9699        * buffer much larger than $GETJPI wants (rsz is size in bytes that
9700        * were needed to hold all identifiers at time of last call; we'll
9701        * allocate that many unsigned long ints), and go back and get 'em.
9702        * If it gave us less than it wanted to despite ample buffer space,
9703        * something's broken.  Is your system missing a system identifier?
9704        */
9705       if (rsz <= jpilist[1].buflen) {
9706          /* Perl_croak accvios when used this early in startup. */
9707          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9708                          rsz, (unsigned long) jpilist[1].buflen,
9709                          "Check your rights database for corruption.\n");
9710          exit(SS$_ABORT);
9711       }
9712       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9713       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9714       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9715       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9716       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9717       _ckvmssts_noperl(iosb[0]);
9718     }
9719     mask = (unsigned long int *)jpilist[1].bufadr;
9720     /* Check attribute flags for each identifier (2nd longword); protected
9721      * subsystem identifiers trigger tainting.
9722      */
9723     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9724       if (mask[i] & KGB$M_SUBSYSTEM) {
9725         will_taint = TRUE;
9726         break;
9727       }
9728     }
9729     if (mask != rlst) PerlMem_free(mask);
9730   }
9731
9732   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9733    * logical, some versions of the CRTL will add a phanthom /000000/
9734    * directory.  This needs to be removed.
9735    */
9736   if (decc_filename_unix_report) {
9737     char * zeros;
9738     int ulen;
9739     ulen = strlen(argvp[0][0]);
9740     if (ulen > 7) {
9741       zeros = strstr(argvp[0][0], "/000000/");
9742       if (zeros != NULL) {
9743         int mlen;
9744         mlen = ulen - (zeros - argvp[0][0]) - 7;
9745         memmove(zeros, &zeros[7], mlen);
9746         ulen = ulen - 7;
9747         argvp[0][0][ulen] = '\0';
9748       }
9749     }
9750     /* It also may have a trailing dot that needs to be removed otherwise
9751      * it will be converted to VMS mode incorrectly.
9752      */
9753     ulen--;
9754     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9755       argvp[0][0][ulen] = '\0';
9756   }
9757
9758   /* We need to use this hack to tell Perl it should run with tainting,
9759    * since its tainting flag may be part of the PL_curinterp struct, which
9760    * hasn't been allocated when vms_image_init() is called.
9761    */
9762   if (will_taint) {
9763     char **newargv, **oldargv;
9764     oldargv = *argvp;
9765     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9766     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9767     newargv[0] = oldargv[0];
9768     newargv[1] = (char *)PerlMem_malloc(3 * sizeof(char));
9769     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9770     strcpy(newargv[1], "-T");
9771     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9772     (*argcp)++;
9773     newargv[*argcp] = NULL;
9774     /* We orphan the old argv, since we don't know where it's come from,
9775      * so we don't know how to free it.
9776      */
9777     *argvp = newargv;
9778   }
9779   else {  /* Did user explicitly request tainting? */
9780     int i;
9781     char *cp, **av = *argvp;
9782     for (i = 1; i < *argcp; i++) {
9783       if (*av[i] != '-') break;
9784       for (cp = av[i]+1; *cp; cp++) {
9785         if (*cp == 'T') { will_taint = 1; break; }
9786         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9787                   strchr("DFIiMmx",*cp)) break;
9788       }
9789       if (will_taint) break;
9790     }
9791   }
9792
9793   for (tabidx = 0;
9794        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9795        tabidx++) {
9796     if (!tabidx) {
9797       tabvec = (struct dsc$descriptor_s **)
9798             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9799       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9800     }
9801     else if (tabidx >= tabct) {
9802       tabct += 8;
9803       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9804       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9805     }
9806     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9807     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9808     tabvec[tabidx]->dsc$w_length  = len;
9809     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9810     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_S;
9811     tabvec[tabidx]->dsc$a_pointer = (char *)PerlMem_malloc(len + 1);
9812     if (tabvec[tabidx]->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9813     my_strlcpy(tabvec[tabidx]->dsc$a_pointer, eqv, len + 1);
9814   }
9815   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9816
9817   getredirection(argcp,argvp);
9818 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9819   {
9820 # include <reentrancy.h>
9821   decc$set_reentrancy(C$C_MULTITHREAD);
9822   }
9823 #endif
9824   return;
9825 }
9826 /*}}}*/
9827
9828
9829 /* trim_unixpath()
9830  * Trim Unix-style prefix off filespec, so it looks like what a shell
9831  * glob expansion would return (i.e. from specified prefix on, not
9832  * full path).  Note that returned filespec is Unix-style, regardless
9833  * of whether input filespec was VMS-style or Unix-style.
9834  *
9835  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9836  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9837  * vector of options; at present, only bit 0 is used, and if set tells
9838  * trim unixpath to try the current default directory as a prefix when
9839  * presented with a possibly ambiguous ... wildcard.
9840  *
9841  * Returns !=0 on success, with trimmed filespec replacing contents of
9842  * fspec, and 0 on failure, with contents of fpsec unchanged.
9843  */
9844 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9845 int
9846 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9847 {
9848   char *unixified, *unixwild, *tplate, *base, *end, *cp1, *cp2;
9849   int tmplen, reslen = 0, dirs = 0;
9850
9851   if (!wildspec || !fspec) return 0;
9852
9853   unixwild = (char *)PerlMem_malloc(VMS_MAXRSS);
9854   if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9855   tplate = unixwild;
9856   if (strpbrk(wildspec,"]>:") != NULL) {
9857     if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
9858         PerlMem_free(unixwild);
9859         return 0;
9860     }
9861   }
9862   else {
9863     my_strlcpy(unixwild, wildspec, VMS_MAXRSS);
9864   }
9865   unixified = (char *)PerlMem_malloc(VMS_MAXRSS);
9866   if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9867   if (strpbrk(fspec,"]>:") != NULL) {
9868     if (int_tounixspec(fspec, unixified, NULL) == NULL) {
9869         PerlMem_free(unixwild);
9870         PerlMem_free(unixified);
9871         return 0;
9872     }
9873     else base = unixified;
9874     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9875      * check to see that final result fits into (isn't longer than) fspec */
9876     reslen = strlen(fspec);
9877   }
9878   else base = fspec;
9879
9880   /* No prefix or absolute path on wildcard, so nothing to remove */
9881   if (!*tplate || *tplate == '/') {
9882     PerlMem_free(unixwild);
9883     if (base == fspec) {
9884         PerlMem_free(unixified);
9885         return 1;
9886     }
9887     tmplen = strlen(unixified);
9888     if (tmplen > reslen) {
9889         PerlMem_free(unixified);
9890         return 0;  /* not enough space */
9891     }
9892     /* Copy unixified resultant, including trailing NUL */
9893     memmove(fspec,unixified,tmplen+1);
9894     PerlMem_free(unixified);
9895     return 1;
9896   }
9897
9898   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
9899   if ((cp1 = strstr(tplate,".../")) == NULL) { /* No ...; just count elts */
9900     for (cp1 = tplate; *cp1; cp1++) if (*cp1 == '/') dirs++;
9901     for (cp1 = end ;cp1 >= base; cp1--)
9902       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9903         { cp1++; break; }
9904     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9905     PerlMem_free(unixified);
9906     PerlMem_free(unixwild);
9907     return 1;
9908   }
9909   else {
9910     char *tpl, *lcres;
9911     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9912     int ells = 1, totells, segdirs, match;
9913     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9914                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9915
9916     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9917     totells = ells;
9918     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9919     tpl = (char *)PerlMem_malloc(VMS_MAXRSS);
9920     if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9921     if (ellipsis == tplate && opts & 1) {
9922       /* Template begins with an ellipsis.  Since we can't tell how many
9923        * directory names at the front of the resultant to keep for an
9924        * arbitrary starting point, we arbitrarily choose the current
9925        * default directory as a starting point.  If it's there as a prefix,
9926        * clip it off.  If not, fall through and act as if the leading
9927        * ellipsis weren't there (i.e. return shortest possible path that
9928        * could match template).
9929        */
9930       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9931           PerlMem_free(tpl);
9932           PerlMem_free(unixified);
9933           PerlMem_free(unixwild);
9934           return 0;
9935       }
9936       if (!decc_efs_case_preserve) {
9937         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9938           if (_tolower(*cp1) != _tolower(*cp2)) break;
9939       }
9940       segdirs = dirs - totells;  /* Min # of dirs we must have left */
9941       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9942       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9943         memmove(fspec,cp2+1,end - cp2);
9944         PerlMem_free(tpl);
9945         PerlMem_free(unixified);
9946         PerlMem_free(unixwild);
9947         return 1;
9948       }
9949     }
9950     /* First off, back up over constant elements at end of path */
9951     if (dirs) {
9952       for (front = end ; front >= base; front--)
9953          if (*front == '/' && !dirs--) { front++; break; }
9954     }
9955     lcres = (char *)PerlMem_malloc(VMS_MAXRSS);
9956     if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9957     for (cp1=tplate,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9958          cp1++,cp2++) {
9959             if (!decc_efs_case_preserve) {
9960                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
9961             }
9962             else {
9963                 *cp2 = *cp1;
9964             }
9965     }
9966     if (cp1 != '\0') {
9967         PerlMem_free(tpl);
9968         PerlMem_free(unixified);
9969         PerlMem_free(unixwild);
9970         PerlMem_free(lcres);
9971         return 0;  /* Path too long. */
9972     }
9973     lcend = cp2;
9974     *cp2 = '\0';  /* Pick up with memcpy later */
9975     lcfront = lcres + (front - base);
9976     /* Now skip over each ellipsis and try to match the path in front of it. */
9977     while (ells--) {
9978       for (cp1 = ellipsis - 2; cp1 >= tplate; cp1--)
9979         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
9980             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
9981       if (cp1 < tplate) break; /* template started with an ellipsis */
9982       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9983         ellipsis = cp1; continue;
9984       }
9985       wilddsc.dsc$a_pointer = tpl;
9986       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9987       nextell = cp1;
9988       for (segdirs = 0, cp2 = tpl;
9989            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9990            cp1++, cp2++) {
9991          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9992          else {
9993             if (!decc_efs_case_preserve) {
9994               *cp2 = _tolower(*cp1);  /* else lowercase for match */
9995             }
9996             else {
9997               *cp2 = *cp1;  /* else preserve case for match */
9998             }
9999          }
10000          if (*cp2 == '/') segdirs++;
10001       }
10002       if (cp1 != ellipsis - 1) {
10003           PerlMem_free(tpl);
10004           PerlMem_free(unixified);
10005           PerlMem_free(unixwild);
10006           PerlMem_free(lcres);
10007           return 0; /* Path too long */
10008       }
10009       /* Back up at least as many dirs as in template before matching */
10010       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
10011         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
10012       for (match = 0; cp1 > lcres;) {
10013         resdsc.dsc$a_pointer = cp1;
10014         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
10015           match++;
10016           if (match == 1) lcfront = cp1;
10017         }
10018         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
10019       }
10020       if (!match) {
10021         PerlMem_free(tpl);
10022         PerlMem_free(unixified);
10023         PerlMem_free(unixwild);
10024         PerlMem_free(lcres);
10025         return 0;  /* Can't find prefix ??? */
10026       }
10027       if (match > 1 && opts & 1) {
10028         /* This ... wildcard could cover more than one set of dirs (i.e.
10029          * a set of similar dir names is repeated).  If the template
10030          * contains more than 1 ..., upstream elements could resolve the
10031          * ambiguity, but it's not worth a full backtracking setup here.
10032          * As a quick heuristic, clip off the current default directory
10033          * if it's present to find the trimmed spec, else use the
10034          * shortest string that this ... could cover.
10035          */
10036         char def[NAM$C_MAXRSS+1], *st;
10037
10038         if (getcwd(def, sizeof def,0) == NULL) {
10039             PerlMem_free(unixified);
10040             PerlMem_free(unixwild);
10041             PerlMem_free(lcres);
10042             PerlMem_free(tpl);
10043             return 0;
10044         }
10045         if (!decc_efs_case_preserve) {
10046           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
10047             if (_tolower(*cp1) != _tolower(*cp2)) break;
10048         }
10049         segdirs = dirs - totells;  /* Min # of dirs we must have left */
10050         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
10051         if (*cp1 == '\0' && *cp2 == '/') {
10052           memmove(fspec,cp2+1,end - cp2);
10053           PerlMem_free(tpl);
10054           PerlMem_free(unixified);
10055           PerlMem_free(unixwild);
10056           PerlMem_free(lcres);
10057           return 1;
10058         }
10059         /* Nope -- stick with lcfront from above and keep going. */
10060       }
10061     }
10062     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
10063     PerlMem_free(tpl);
10064     PerlMem_free(unixified);
10065     PerlMem_free(unixwild);
10066     PerlMem_free(lcres);
10067     return 1;
10068   }
10069
10070 }  /* end of trim_unixpath() */
10071 /*}}}*/
10072
10073
10074 /*
10075  *  VMS readdir() routines.
10076  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
10077  *
10078  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
10079  *  Minor modifications to original routines.
10080  */
10081
10082 /* readdir may have been redefined by reentr.h, so make sure we get
10083  * the local version for what we do here.
10084  */
10085 #ifdef readdir
10086 # undef readdir
10087 #endif
10088 #if !defined(PERL_IMPLICIT_CONTEXT)
10089 # define readdir Perl_readdir
10090 #else
10091 # define readdir(a) Perl_readdir(aTHX_ a)
10092 #endif
10093
10094     /* Number of elements in vms_versions array */
10095 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
10096
10097 /*
10098  *  Open a directory, return a handle for later use.
10099  */
10100 /*{{{ DIR *opendir(char*name) */
10101 DIR *
10102 Perl_opendir(pTHX_ const char *name)
10103 {
10104     DIR *dd;
10105     char *dir;
10106     Stat_t sb;
10107
10108     Newx(dir, VMS_MAXRSS, char);
10109     if (int_tovmspath(name, dir, NULL) == NULL) {
10110       Safefree(dir);
10111       return NULL;
10112     }
10113     /* Check access before stat; otherwise stat does not
10114      * accurately report whether it's a directory.
10115      */
10116     if (!strstr(dir, "::") /* sys$check_access doesn't do remotes */
10117         && !cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
10118       /* cando_by_name has already set errno */
10119       Safefree(dir);
10120       return NULL;
10121     }
10122     if (flex_stat(dir,&sb) == -1) return NULL;
10123     if (!S_ISDIR(sb.st_mode)) {
10124       Safefree(dir);
10125       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
10126       return NULL;
10127     }
10128     /* Get memory for the handle, and the pattern. */
10129     Newx(dd,1,DIR);
10130     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
10131
10132     /* Fill in the fields; mainly playing with the descriptor. */
10133     sprintf(dd->pattern, "%s*.*",dir);
10134     Safefree(dir);
10135     dd->context = 0;
10136     dd->count = 0;
10137     dd->flags = 0;
10138     /* By saying we want the result of readdir() in unix format, we are really
10139      * saying we want all the escapes removed, translating characters that
10140      * must be escaped in a VMS-format name to their unescaped form, which is
10141      * presumably allowed in a Unix-format name.
10142      */
10143     dd->flags = decc_filename_unix_report ? PERL_VMSDIR_M_UNIXSPECS : 0;
10144     dd->pat.dsc$a_pointer = dd->pattern;
10145     dd->pat.dsc$w_length = strlen(dd->pattern);
10146     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
10147     dd->pat.dsc$b_class = DSC$K_CLASS_S;
10148 #if defined(USE_ITHREADS)
10149     Newx(dd->mutex,1,perl_mutex);
10150     MUTEX_INIT( (perl_mutex *) dd->mutex );
10151 #else
10152     dd->mutex = NULL;
10153 #endif
10154
10155     return dd;
10156 }  /* end of opendir() */
10157 /*}}}*/
10158
10159 /*
10160  *  Set the flag to indicate we want versions or not.
10161  */
10162 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10163 void
10164 vmsreaddirversions(DIR *dd, int flag)
10165 {
10166     if (flag)
10167         dd->flags |= PERL_VMSDIR_M_VERSIONS;
10168     else
10169         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10170 }
10171 /*}}}*/
10172
10173 /*
10174  *  Free up an opened directory.
10175  */
10176 /*{{{ void closedir(DIR *dd)*/
10177 void
10178 Perl_closedir(DIR *dd)
10179 {
10180     int sts;
10181
10182     sts = lib$find_file_end(&dd->context);
10183     Safefree(dd->pattern);
10184 #if defined(USE_ITHREADS)
10185     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10186     Safefree(dd->mutex);
10187 #endif
10188     Safefree(dd);
10189 }
10190 /*}}}*/
10191
10192 /*
10193  *  Collect all the version numbers for the current file.
10194  */
10195 static void
10196 collectversions(pTHX_ DIR *dd)
10197 {
10198     struct dsc$descriptor_s     pat;
10199     struct dsc$descriptor_s     res;
10200     struct dirent *e;
10201     char *p, *text, *buff;
10202     int i;
10203     unsigned long context, tmpsts;
10204
10205     /* Convenient shorthand. */
10206     e = &dd->entry;
10207
10208     /* Add the version wildcard, ignoring the "*.*" put on before */
10209     i = strlen(dd->pattern);
10210     Newx(text,i + e->d_namlen + 3,char);
10211     my_strlcpy(text, dd->pattern, i + 1);
10212     sprintf(&text[i - 3], "%s;*", e->d_name);
10213
10214     /* Set up the pattern descriptor. */
10215     pat.dsc$a_pointer = text;
10216     pat.dsc$w_length = i + e->d_namlen - 1;
10217     pat.dsc$b_dtype = DSC$K_DTYPE_T;
10218     pat.dsc$b_class = DSC$K_CLASS_S;
10219
10220     /* Set up result descriptor. */
10221     Newx(buff, VMS_MAXRSS, char);
10222     res.dsc$a_pointer = buff;
10223     res.dsc$w_length = VMS_MAXRSS - 1;
10224     res.dsc$b_dtype = DSC$K_DTYPE_T;
10225     res.dsc$b_class = DSC$K_CLASS_S;
10226
10227     /* Read files, collecting versions. */
10228     for (context = 0, e->vms_verscount = 0;
10229          e->vms_verscount < VERSIZE(e);
10230          e->vms_verscount++) {
10231         unsigned long rsts;
10232         unsigned long flags = 0;
10233
10234 #ifdef VMS_LONGNAME_SUPPORT
10235         flags = LIB$M_FIL_LONG_NAMES;
10236 #endif
10237         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10238         if (tmpsts == RMS$_NMF || context == 0) break;
10239         _ckvmssts(tmpsts);
10240         buff[VMS_MAXRSS - 1] = '\0';
10241         if ((p = strchr(buff, ';')))
10242             e->vms_versions[e->vms_verscount] = atoi(p + 1);
10243         else
10244             e->vms_versions[e->vms_verscount] = -1;
10245     }
10246
10247     _ckvmssts(lib$find_file_end(&context));
10248     Safefree(text);
10249     Safefree(buff);
10250
10251 }  /* end of collectversions() */
10252
10253 /*
10254  *  Read the next entry from the directory.
10255  */
10256 /*{{{ struct dirent *readdir(DIR *dd)*/
10257 struct dirent *
10258 Perl_readdir(pTHX_ DIR *dd)
10259 {
10260     struct dsc$descriptor_s     res;
10261     char *p, *buff;
10262     unsigned long int tmpsts;
10263     unsigned long rsts;
10264     unsigned long flags = 0;
10265     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10266     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10267
10268     /* Set up result descriptor, and get next file. */
10269     Newx(buff, VMS_MAXRSS, char);
10270     res.dsc$a_pointer = buff;
10271     res.dsc$w_length = VMS_MAXRSS - 1;
10272     res.dsc$b_dtype = DSC$K_DTYPE_T;
10273     res.dsc$b_class = DSC$K_CLASS_S;
10274
10275 #ifdef VMS_LONGNAME_SUPPORT
10276     flags = LIB$M_FIL_LONG_NAMES;
10277 #endif
10278
10279     tmpsts = lib$find_file
10280         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10281     if (dd->context == 0)
10282         tmpsts = RMS$_NMF;  /* None left. (should be set, but make sure) */
10283
10284     if (!(tmpsts & 1)) {
10285       switch (tmpsts) {
10286         case RMS$_NMF:
10287           break;  /* no more files considered success */
10288         case RMS$_PRV:
10289           SETERRNO(EACCES, tmpsts); break;
10290         case RMS$_DEV:
10291           SETERRNO(ENODEV, tmpsts); break;
10292         case RMS$_DIR:
10293           SETERRNO(ENOTDIR, tmpsts); break;
10294         case RMS$_FNF: case RMS$_DNF:
10295           SETERRNO(ENOENT, tmpsts); break;
10296         default:
10297           SETERRNO(EVMSERR, tmpsts);
10298       }
10299       Safefree(buff);
10300       return NULL;
10301     }
10302     dd->count++;
10303     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10304     buff[res.dsc$w_length] = '\0';
10305     p = buff + res.dsc$w_length;
10306     while (--p >= buff) if (!isspace(*p)) break;
10307     *p = '\0';
10308     if (!decc_efs_case_preserve) {
10309       for (p = buff; *p; p++) *p = _tolower(*p);
10310     }
10311
10312     /* Skip any directory component and just copy the name. */
10313     sts = vms_split_path
10314        (buff,
10315         &v_spec,
10316         &v_len,
10317         &r_spec,
10318         &r_len,
10319         &d_spec,
10320         &d_len,
10321         &n_spec,
10322         &n_len,
10323         &e_spec,
10324         &e_len,
10325         &vs_spec,
10326         &vs_len);
10327
10328     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10329
10330         /* In Unix report mode, remove the ".dir;1" from the name */
10331         /* if it is a real directory. */
10332         if (decc_filename_unix_report && decc_efs_charset) {
10333             if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
10334                 Stat_t statbuf;
10335                 int ret_sts;
10336
10337                 ret_sts = flex_lstat(buff, &statbuf);
10338                 if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10339                     e_len = 0;
10340                     e_spec[0] = 0;
10341                 }
10342             }
10343         }
10344
10345         /* Drop NULL extensions on UNIX file specification */
10346         if ((e_len == 1) && decc_readdir_dropdotnotype) {
10347             e_len = 0;
10348             e_spec[0] = '\0';
10349         }
10350     }
10351
10352     memcpy(dd->entry.d_name, n_spec, n_len + e_len);
10353     dd->entry.d_name[n_len + e_len] = '\0';
10354     dd->entry.d_namlen = n_len + e_len;
10355
10356     /* Convert the filename to UNIX format if needed */
10357     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10358
10359         /* Translate the encoded characters. */
10360         /* Fixme: Unicode handling could result in embedded 0 characters */
10361         if (strchr(dd->entry.d_name, '^') != NULL) {
10362             char new_name[256];
10363             char * q;
10364             p = dd->entry.d_name;
10365             q = new_name;
10366             while (*p != 0) {
10367                 int inchars_read, outchars_added;
10368                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10369                 p += inchars_read;
10370                 q += outchars_added;
10371                 /* fix-me */
10372                 /* if outchars_added > 1, then this is a wide file specification */
10373                 /* Wide file specifications need to be passed in Perl */
10374                 /* counted strings apparently with a Unicode flag */
10375             }
10376             *q = 0;
10377             dd->entry.d_namlen = my_strlcpy(dd->entry.d_name, new_name, sizeof(dd->entry.d_name));
10378         }
10379     }
10380
10381     dd->entry.vms_verscount = 0;
10382     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10383     Safefree(buff);
10384     return &dd->entry;
10385
10386 }  /* end of readdir() */
10387 /*}}}*/
10388
10389 /*
10390  *  Read the next entry from the directory -- thread-safe version.
10391  */
10392 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10393 int
10394 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10395 {
10396     int retval;
10397
10398     MUTEX_LOCK( (perl_mutex *) dd->mutex );
10399
10400     entry = readdir(dd);
10401     *result = entry;
10402     retval = ( *result == NULL ? errno : 0 );
10403
10404     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10405
10406     return retval;
10407
10408 }  /* end of readdir_r() */
10409 /*}}}*/
10410
10411 /*
10412  *  Return something that can be used in a seekdir later.
10413  */
10414 /*{{{ long telldir(DIR *dd)*/
10415 long
10416 Perl_telldir(DIR *dd)
10417 {
10418     return dd->count;
10419 }
10420 /*}}}*/
10421
10422 /*
10423  *  Return to a spot where we used to be.  Brute force.
10424  */
10425 /*{{{ void seekdir(DIR *dd,long count)*/
10426 void
10427 Perl_seekdir(pTHX_ DIR *dd, long count)
10428 {
10429     int old_flags;
10430
10431     /* If we haven't done anything yet... */
10432     if (dd->count == 0)
10433         return;
10434
10435     /* Remember some state, and clear it. */
10436     old_flags = dd->flags;
10437     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10438     _ckvmssts(lib$find_file_end(&dd->context));
10439     dd->context = 0;
10440
10441     /* The increment is in readdir(). */
10442     for (dd->count = 0; dd->count < count; )
10443         readdir(dd);
10444
10445     dd->flags = old_flags;
10446
10447 }  /* end of seekdir() */
10448 /*}}}*/
10449
10450 /* VMS subprocess management
10451  *
10452  * my_vfork() - just a vfork(), after setting a flag to record that
10453  * the current script is trying a Unix-style fork/exec.
10454  *
10455  * vms_do_aexec() and vms_do_exec() are called in response to the
10456  * perl 'exec' function.  If this follows a vfork call, then they
10457  * call out the regular perl routines in doio.c which do an
10458  * execvp (for those who really want to try this under VMS).
10459  * Otherwise, they do exactly what the perl docs say exec should
10460  * do - terminate the current script and invoke a new command
10461  * (See below for notes on command syntax.)
10462  *
10463  * do_aspawn() and do_spawn() implement the VMS side of the perl
10464  * 'system' function.
10465  *
10466  * Note on command arguments to perl 'exec' and 'system': When handled
10467  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10468  * are concatenated to form a DCL command string.  If the first non-numeric
10469  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10470  * the command string is handed off to DCL directly.  Otherwise,
10471  * the first token of the command is taken as the filespec of an image
10472  * to run.  The filespec is expanded using a default type of '.EXE' and
10473  * the process defaults for device, directory, etc., and if found, the resultant
10474  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10475  * the command string as parameters.  This is perhaps a bit complicated,
10476  * but I hope it will form a happy medium between what VMS folks expect
10477  * from lib$spawn and what Unix folks expect from exec.
10478  */
10479
10480 static int vfork_called;
10481
10482 /*{{{int my_vfork(void)*/
10483 int
10484 my_vfork(void)
10485 {
10486   vfork_called++;
10487   return vfork();
10488 }
10489 /*}}}*/
10490
10491
10492 static void
10493 vms_execfree(struct dsc$descriptor_s *vmscmd)
10494 {
10495   if (vmscmd) {
10496       if (vmscmd->dsc$a_pointer) {
10497           PerlMem_free(vmscmd->dsc$a_pointer);
10498       }
10499       PerlMem_free(vmscmd);
10500   }
10501 }
10502
10503 static char *
10504 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10505 {
10506   char *junk, *tmps = NULL;
10507   size_t cmdlen = 0;
10508   size_t rlen;
10509   SV **idx;
10510   STRLEN n_a;
10511
10512   idx = mark;
10513   if (really) {
10514     tmps = SvPV(really,rlen);
10515     if (*tmps) {
10516       cmdlen += rlen + 1;
10517       idx++;
10518     }
10519   }
10520
10521   for (idx++; idx <= sp; idx++) {
10522     if (*idx) {
10523       junk = SvPVx(*idx,rlen);
10524       cmdlen += rlen ? rlen + 1 : 0;
10525     }
10526   }
10527   Newx(PL_Cmd, cmdlen+1, char);
10528
10529   if (tmps && *tmps) {
10530     my_strlcpy(PL_Cmd, tmps, cmdlen + 1);
10531     mark++;
10532   }
10533   else *PL_Cmd = '\0';
10534   while (++mark <= sp) {
10535     if (*mark) {
10536       char *s = SvPVx(*mark,n_a);
10537       if (!*s) continue;
10538       if (*PL_Cmd) my_strlcat(PL_Cmd, " ", cmdlen+1);
10539       my_strlcat(PL_Cmd, s, cmdlen+1);
10540     }
10541   }
10542   return PL_Cmd;
10543
10544 }  /* end of setup_argstr() */
10545
10546
10547 static unsigned long int
10548 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10549                    struct dsc$descriptor_s **pvmscmd)
10550 {
10551   char * vmsspec;
10552   char * resspec;
10553   char image_name[NAM$C_MAXRSS+1];
10554   char image_argv[NAM$C_MAXRSS+1];
10555   $DESCRIPTOR(defdsc,".EXE");
10556   $DESCRIPTOR(defdsc2,".");
10557   struct dsc$descriptor_s resdsc;
10558   struct dsc$descriptor_s *vmscmd;
10559   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10560   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10561   char *s, *rest, *cp, *wordbreak;
10562   char * cmd;
10563   int cmdlen;
10564   int isdcl;
10565
10566   vmscmd = (struct dsc$descriptor_s *)PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10567   if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10568
10569   /* vmsspec is a DCL command buffer, not just a filename */
10570   vmsspec = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10571   if (vmsspec == NULL)
10572       _ckvmssts_noperl(SS$_INSFMEM);
10573
10574   resspec = (char *)PerlMem_malloc(VMS_MAXRSS);
10575   if (resspec == NULL)
10576       _ckvmssts_noperl(SS$_INSFMEM);
10577
10578   /* Make a copy for modification */
10579   cmdlen = strlen(incmd);
10580   cmd = (char *)PerlMem_malloc(cmdlen+1);
10581   if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10582   my_strlcpy(cmd, incmd, cmdlen + 1);
10583   image_name[0] = 0;
10584   image_argv[0] = 0;
10585
10586   resdsc.dsc$a_pointer = resspec;
10587   resdsc.dsc$b_dtype  = DSC$K_DTYPE_T;
10588   resdsc.dsc$b_class  = DSC$K_CLASS_S;
10589   resdsc.dsc$w_length = VMS_MAXRSS - 1;
10590
10591   vmscmd->dsc$a_pointer = NULL;
10592   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
10593   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
10594   vmscmd->dsc$w_length = 0;
10595   if (pvmscmd) *pvmscmd = vmscmd;
10596
10597   if (suggest_quote) *suggest_quote = 0;
10598
10599   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10600     PerlMem_free(cmd);
10601     PerlMem_free(vmsspec);
10602     PerlMem_free(resspec);
10603     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
10604   }
10605
10606   s = cmd;
10607
10608   while (*s && isspace(*s)) s++;
10609
10610   if (*s == '@' || *s == '$') {
10611     vmsspec[0] = *s;  rest = s + 1;
10612     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10613   }
10614   else { cp = vmsspec; rest = s; }
10615
10616   /* If the first word is quoted, then we need to unquote it and
10617    * escape spaces within it.  We'll expand into the resspec buffer,
10618    * then copy back into the cmd buffer, expanding the latter if
10619    * necessary.
10620    */
10621   if (*rest == '"') {
10622     char *cp2;
10623     char *r = rest;
10624     bool in_quote = 0;
10625     int clen = cmdlen;
10626     int soff = s - cmd;
10627
10628     for (cp2 = resspec;
10629          *rest && cp2 - resspec < (VMS_MAXRSS - 1);
10630          rest++) {
10631
10632       if (*rest == ' ') {    /* Escape ' ' to '^_'. */
10633         *cp2 = '^';
10634         *(++cp2) = '_';
10635         cp2++;
10636         clen++;
10637       }
10638       else if (*rest == '"') {
10639         clen--;
10640         if (in_quote) {     /* Must be closing quote. */
10641           rest++;
10642           break;
10643         }
10644         in_quote = 1;
10645       }
10646       else {
10647         *cp2 = *rest;
10648         cp2++;
10649       }
10650     }
10651     *cp2 = '\0';
10652
10653     /* Expand the command buffer if necessary. */
10654     if (clen > cmdlen) {
10655       cmd = (char *)PerlMem_realloc(cmd, clen);
10656       if (cmd == NULL)
10657         _ckvmssts_noperl(SS$_INSFMEM);
10658       /* Where we are may have changed, so recompute offsets */
10659       r = cmd + (r - s - soff);
10660       rest = cmd + (rest - s - soff);
10661       s = cmd + soff;
10662     }
10663
10664     /* Shift the non-verb portion of the command (if any) up or
10665      * down as necessary.
10666      */
10667     if (*rest)
10668       memmove(rest + clen - cmdlen, rest, s - soff + cmdlen - rest);
10669
10670     /* Copy the unquoted and escaped command verb into place. */
10671     memcpy(r, resspec, cp2 - resspec);
10672     cmd[clen] = '\0';
10673     cmdlen = clen;
10674     rest = r;         /* Rewind for subsequent operations. */
10675   }
10676
10677   if (*rest == '.' || *rest == '/') {
10678     char *cp2;
10679     for (cp2 = resspec;
10680          *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10681          rest++, cp2++) *cp2 = *rest;
10682     *cp2 = '\0';
10683     if (int_tovmsspec(resspec, cp, 0, NULL)) {
10684       s = vmsspec;
10685
10686       /* When a UNIX spec with no file type is translated to VMS, */
10687       /* A trailing '.' is appended under ODS-5 rules.            */
10688       /* Here we do not want that trailing "." as it prevents     */
10689       /* Looking for a implied ".exe" type. */
10690       if (decc_efs_charset) {
10691           int i;
10692           i = strlen(vmsspec);
10693           if (vmsspec[i-1] == '.') {
10694               vmsspec[i-1] = '\0';
10695           }
10696       }
10697
10698       if (*rest) {
10699         for (cp2 = vmsspec + strlen(vmsspec);
10700              *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10701              rest++, cp2++) *cp2 = *rest;
10702         *cp2 = '\0';
10703       }
10704     }
10705   }
10706   /* Intuit whether verb (first word of cmd) is a DCL command:
10707    *   - if first nonspace char is '@', it's a DCL indirection
10708    * otherwise
10709    *   - if verb contains a filespec separator, it's not a DCL command
10710    *   - if it doesn't, caller tells us whether to default to a DCL
10711    *     command, or to a local image unless told it's DCL (by leading '$')
10712    */
10713   if (*s == '@') {
10714       isdcl = 1;
10715       if (suggest_quote) *suggest_quote = 1;
10716   } else {
10717     char *filespec = strpbrk(s,":<[.;");
10718     rest = wordbreak = strpbrk(s," \"\t/");
10719     if (!wordbreak) wordbreak = s + strlen(s);
10720     if (*s == '$') check_img = 0;
10721     if (filespec && (filespec < wordbreak)) isdcl = 0;
10722     else isdcl = !check_img;
10723   }
10724
10725   if (!isdcl) {
10726     int rsts;
10727     imgdsc.dsc$a_pointer = s;
10728     imgdsc.dsc$w_length = wordbreak - s;
10729     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10730     if (!(retsts&1)) {
10731         _ckvmssts_noperl(lib$find_file_end(&cxt));
10732         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10733       if (!(retsts & 1) && *s == '$') {
10734         _ckvmssts_noperl(lib$find_file_end(&cxt));
10735         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10736         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10737         if (!(retsts&1)) {
10738           _ckvmssts_noperl(lib$find_file_end(&cxt));
10739           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10740         }
10741       }
10742     }
10743     _ckvmssts_noperl(lib$find_file_end(&cxt));
10744
10745     if (retsts & 1) {
10746       FILE *fp;
10747       s = resspec;
10748       while (*s && !isspace(*s)) s++;
10749       *s = '\0';
10750
10751       /* check that it's really not DCL with no file extension */
10752       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10753       if (fp) {
10754         char b[256] = {0,0,0,0};
10755         read(fileno(fp), b, 256);
10756         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10757         if (isdcl) {
10758           int shebang_len;
10759
10760           /* Check for script */
10761           shebang_len = 0;
10762           if ((b[0] == '#') && (b[1] == '!'))
10763              shebang_len = 2;
10764 #ifdef ALTERNATE_SHEBANG
10765           else {
10766             shebang_len = strlen(ALTERNATE_SHEBANG);
10767             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10768               char * perlstr;
10769                 perlstr = strstr("perl",b);
10770                 if (perlstr == NULL)
10771                   shebang_len = 0;
10772             }
10773             else
10774               shebang_len = 0;
10775           }
10776 #endif
10777
10778           if (shebang_len > 0) {
10779           int i;
10780           int j;
10781           char tmpspec[NAM$C_MAXRSS + 1];
10782
10783             i = shebang_len;
10784              /* Image is following after white space */
10785             /*--------------------------------------*/
10786             while (isprint(b[i]) && isspace(b[i]))
10787                 i++;
10788
10789             j = 0;
10790             while (isprint(b[i]) && !isspace(b[i])) {
10791                 tmpspec[j++] = b[i++];
10792                 if (j >= NAM$C_MAXRSS)
10793                    break;
10794             }
10795             tmpspec[j] = '\0';
10796
10797              /* There may be some default parameters to the image */
10798             /*---------------------------------------------------*/
10799             j = 0;
10800             while (isprint(b[i])) {
10801                 image_argv[j++] = b[i++];
10802                 if (j >= NAM$C_MAXRSS)
10803                    break;
10804             }
10805             while ((j > 0) && !isprint(image_argv[j-1]))
10806                 j--;
10807             image_argv[j] = 0;
10808
10809             /* It will need to be converted to VMS format and validated */
10810             if (tmpspec[0] != '\0') {
10811               char * iname;
10812
10813                /* Try to find the exact program requested to be run */
10814               /*---------------------------------------------------*/
10815               iname = int_rmsexpand
10816                  (tmpspec, image_name, ".exe",
10817                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10818               if (iname != NULL) {
10819                 if (cando_by_name_int
10820                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10821                   /* MCR prefix needed */
10822                   isdcl = 0;
10823                 }
10824                 else {
10825                    /* Try again with a null type */
10826                   /*----------------------------*/
10827                   iname = int_rmsexpand
10828                     (tmpspec, image_name, ".",
10829                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10830                   if (iname != NULL) {
10831                     if (cando_by_name_int
10832                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10833                       /* MCR prefix needed */
10834                       isdcl = 0;
10835                     }
10836                   }
10837                 }
10838
10839                  /* Did we find the image to run the script? */
10840                 /*------------------------------------------*/
10841                 if (isdcl) {
10842                   char *tchr;
10843
10844                    /* Assume DCL or foreign command exists */
10845                   /*--------------------------------------*/
10846                   tchr = strrchr(tmpspec, '/');
10847                   if (tchr != NULL) {
10848                     tchr++;
10849                   }
10850                   else {
10851                     tchr = tmpspec;
10852                   }
10853                   my_strlcpy(image_name, tchr, sizeof(image_name));
10854                 }
10855               }
10856             }
10857           }
10858         }
10859         fclose(fp);
10860       }
10861       if (check_img && isdcl) {
10862           PerlMem_free(cmd);
10863           PerlMem_free(resspec);
10864           PerlMem_free(vmsspec);
10865           return RMS$_FNF;
10866       }
10867
10868       if (cando_by_name(S_IXUSR,0,resspec)) {
10869         vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10870         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10871         if (!isdcl) {
10872             my_strlcpy(vmscmd->dsc$a_pointer,"$ MCR ", MAX_DCL_LINE_LENGTH);
10873             if (image_name[0] != 0) {
10874                 my_strlcat(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10875                 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10876             }
10877         } else if (image_name[0] != 0) {
10878             my_strlcpy(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10879             my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10880         } else {
10881             my_strlcpy(vmscmd->dsc$a_pointer, "@", MAX_DCL_LINE_LENGTH);
10882         }
10883         if (suggest_quote) *suggest_quote = 1;
10884
10885         /* If there is an image name, use original command */
10886         if (image_name[0] == 0)
10887             my_strlcat(vmscmd->dsc$a_pointer, resspec, MAX_DCL_LINE_LENGTH);
10888         else {
10889             rest = cmd;
10890             while (*rest && isspace(*rest)) rest++;
10891         }
10892
10893         if (image_argv[0] != 0) {
10894           my_strlcat(vmscmd->dsc$a_pointer, image_argv, MAX_DCL_LINE_LENGTH);
10895           my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10896         }
10897         if (rest) {
10898            int rest_len;
10899            int vmscmd_len;
10900
10901            rest_len = strlen(rest);
10902            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10903            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10904               my_strlcat(vmscmd->dsc$a_pointer, rest, MAX_DCL_LINE_LENGTH);
10905            else
10906              retsts = CLI$_BUFOVF;
10907         }
10908         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10909         PerlMem_free(cmd);
10910         PerlMem_free(vmsspec);
10911         PerlMem_free(resspec);
10912         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10913       }
10914       else
10915         retsts = RMS$_PRV;
10916     }
10917   }
10918   /* It's either a DCL command or we couldn't find a suitable image */
10919   vmscmd->dsc$w_length = strlen(cmd);
10920
10921   vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(vmscmd->dsc$w_length + 1);
10922   my_strlcpy(vmscmd->dsc$a_pointer, cmd, vmscmd->dsc$w_length + 1);
10923
10924   PerlMem_free(cmd);
10925   PerlMem_free(resspec);
10926   PerlMem_free(vmsspec);
10927
10928   /* check if it's a symbol (for quoting purposes) */
10929   if (suggest_quote && !*suggest_quote) {
10930     int iss;
10931     char equiv[LNM$C_NAMLENGTH];
10932     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10933     eqvdsc.dsc$a_pointer = equiv;
10934
10935     iss = lib$get_symbol(vmscmd,&eqvdsc);
10936     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10937   }
10938   if (!(retsts & 1)) {
10939     /* just hand off status values likely to be due to user error */
10940     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10941         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10942        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10943     else { _ckvmssts_noperl(retsts); }
10944   }
10945
10946   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10947
10948 }  /* end of setup_cmddsc() */
10949
10950
10951 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10952 bool
10953 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10954 {
10955   bool exec_sts;
10956   char * cmd;
10957
10958   if (sp > mark) {
10959     if (vfork_called) {           /* this follows a vfork - act Unixish */
10960       vfork_called--;
10961       if (vfork_called < 0) {
10962         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10963         vfork_called = 0;
10964       }
10965       else return do_aexec(really,mark,sp);
10966     }
10967                                            /* no vfork - act VMSish */
10968     cmd = setup_argstr(aTHX_ really,mark,sp);
10969     exec_sts = vms_do_exec(cmd);
10970     Safefree(cmd);  /* Clean up from setup_argstr() */
10971     return exec_sts;
10972   }
10973
10974   return FALSE;
10975 }  /* end of vms_do_aexec() */
10976 /*}}}*/
10977
10978 /* {{{bool vms_do_exec(char *cmd) */
10979 bool
10980 Perl_vms_do_exec(pTHX_ const char *cmd)
10981 {
10982   struct dsc$descriptor_s *vmscmd;
10983
10984   if (vfork_called) {             /* this follows a vfork - act Unixish */
10985     vfork_called--;
10986     if (vfork_called < 0) {
10987       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10988       vfork_called = 0;
10989     }
10990     else return do_exec(cmd);
10991   }
10992
10993   {                               /* no vfork - act VMSish */
10994     unsigned long int retsts;
10995
10996     TAINT_ENV();
10997     TAINT_PROPER("exec");
10998     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10999       retsts = lib$do_command(vmscmd);
11000
11001     switch (retsts) {
11002       case RMS$_FNF: case RMS$_DNF:
11003         set_errno(ENOENT); break;
11004       case RMS$_DIR:
11005         set_errno(ENOTDIR); break;
11006       case RMS$_DEV:
11007         set_errno(ENODEV); break;
11008       case RMS$_PRV:
11009         set_errno(EACCES); break;
11010       case RMS$_SYN:
11011         set_errno(EINVAL); break;
11012       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11013         set_errno(E2BIG); break;
11014       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11015         _ckvmssts_noperl(retsts); /* fall through */
11016       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11017         set_errno(EVMSERR);
11018     }
11019     set_vaxc_errno(retsts);
11020     if (ckWARN(WARN_EXEC)) {
11021       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
11022              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
11023     }
11024     vms_execfree(vmscmd);
11025   }
11026
11027   return FALSE;
11028
11029 }  /* end of vms_do_exec() */
11030 /*}}}*/
11031
11032 int do_spawn2(pTHX_ const char *, int);
11033
11034 int
11035 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
11036 {
11037   unsigned long int sts;
11038   char * cmd;
11039   int flags = 0;
11040
11041   if (sp > mark) {
11042
11043     /* We'll copy the (undocumented?) Win32 behavior and allow a
11044      * numeric first argument.  But the only value we'll support
11045      * through do_aspawn is a value of 1, which means spawn without
11046      * waiting for completion -- other values are ignored.
11047      */
11048     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
11049         ++mark;
11050         flags = SvIVx(*mark);
11051     }
11052
11053     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
11054         flags = CLI$M_NOWAIT;
11055     else
11056         flags = 0;
11057
11058     cmd = setup_argstr(aTHX_ really, mark, sp);
11059     sts = do_spawn2(aTHX_ cmd, flags);
11060     /* pp_sys will clean up cmd */
11061     return sts;
11062   }
11063   return SS$_ABORT;
11064 }  /* end of do_aspawn() */
11065 /*}}}*/
11066
11067
11068 /* {{{int do_spawn(char* cmd) */
11069 int
11070 Perl_do_spawn(pTHX_ char* cmd)
11071 {
11072     PERL_ARGS_ASSERT_DO_SPAWN;
11073
11074     return do_spawn2(aTHX_ cmd, 0);
11075 }
11076 /*}}}*/
11077
11078 /* {{{int do_spawn_nowait(char* cmd) */
11079 int
11080 Perl_do_spawn_nowait(pTHX_ char* cmd)
11081 {
11082     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
11083
11084     return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
11085 }
11086 /*}}}*/
11087
11088 /* {{{int do_spawn2(char *cmd) */
11089 int
11090 do_spawn2(pTHX_ const char *cmd, int flags)
11091 {
11092   unsigned long int sts, substs;
11093
11094   /* The caller of this routine expects to Safefree(PL_Cmd) */
11095   Newx(PL_Cmd,10,char);
11096
11097   TAINT_ENV();
11098   TAINT_PROPER("spawn");
11099   if (!cmd || !*cmd) {
11100     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
11101     if (!(sts & 1)) {
11102       switch (sts) {
11103         case RMS$_FNF:  case RMS$_DNF:
11104           set_errno(ENOENT); break;
11105         case RMS$_DIR:
11106           set_errno(ENOTDIR); break;
11107         case RMS$_DEV:
11108           set_errno(ENODEV); break;
11109         case RMS$_PRV:
11110           set_errno(EACCES); break;
11111         case RMS$_SYN:
11112           set_errno(EINVAL); break;
11113         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11114           set_errno(E2BIG); break;
11115         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11116           _ckvmssts_noperl(sts); /* fall through */
11117         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11118           set_errno(EVMSERR);
11119       }
11120       set_vaxc_errno(sts);
11121       if (ckWARN(WARN_EXEC)) {
11122         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
11123                     Strerror(errno));
11124       }
11125     }
11126     sts = substs;
11127   }
11128   else {
11129     char mode[3];
11130     PerlIO * fp;
11131     if (flags & CLI$M_NOWAIT)
11132         strcpy(mode, "n");
11133     else
11134         strcpy(mode, "nW");
11135
11136     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
11137     if (fp != NULL)
11138       my_pclose(fp);
11139     /* sts will be the pid in the nowait case, so leave a
11140      * hint saying not to do any bit shifting to it.
11141      */
11142     if (flags & CLI$M_NOWAIT)
11143         PL_statusvalue = -1;
11144   }
11145   return sts;
11146 }  /* end of do_spawn2() */
11147 /*}}}*/
11148
11149
11150 static unsigned int *sockflags, sockflagsize;
11151
11152 /*
11153  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
11154  * routines found in some versions of the CRTL can't deal with sockets.
11155  * We don't shim the other file open routines since a socket isn't
11156  * likely to be opened by a name.
11157  */
11158 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
11159 FILE *
11160 my_fdopen(int fd, const char *mode)
11161 {
11162   FILE *fp = fdopen(fd, mode);
11163
11164   if (fp) {
11165     unsigned int fdoff = fd / sizeof(unsigned int);
11166     Stat_t sbuf; /* native stat; we don't need flex_stat */
11167     if (!sockflagsize || fdoff > sockflagsize) {
11168       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
11169       else           Newx  (sockflags,fdoff+2,unsigned int);
11170       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11171       sockflagsize = fdoff + 2;
11172     }
11173     if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
11174       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11175   }
11176   return fp;
11177
11178 }
11179 /*}}}*/
11180
11181
11182 /*
11183  * Clear the corresponding bit when the (possibly) socket stream is closed.
11184  * There still a small hole: we miss an implicit close which might occur
11185  * via freopen().  >> Todo
11186  */
11187 /*{{{ int my_fclose(FILE *fp)*/
11188 int
11189 my_fclose(FILE *fp) {
11190   if (fp) {
11191     unsigned int fd = fileno(fp);
11192     unsigned int fdoff = fd / sizeof(unsigned int);
11193
11194     if (sockflagsize && fdoff < sockflagsize)
11195       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11196   }
11197   return fclose(fp);
11198 }
11199 /*}}}*/
11200
11201
11202 /*
11203  * A simple fwrite replacement which outputs itmsz*nitm chars without
11204  * introducing record boundaries every itmsz chars.
11205  * We are using fputs, which depends on a terminating null.  We may
11206  * well be writing binary data, so we need to accommodate not only
11207  * data with nulls sprinkled in the middle but also data with no null
11208  * byte at the end.
11209  */
11210 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
11211 int
11212 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11213 {
11214   char *cp, *end, *cpd;
11215   char *data;
11216   unsigned int fd = fileno(dest);
11217   unsigned int fdoff = fd / sizeof(unsigned int);
11218   int retval;
11219   int bufsize = itmsz * nitm + 1;
11220
11221   if (fdoff < sockflagsize &&
11222       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11223     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11224     return nitm;
11225   }
11226
11227   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11228   memcpy( data, src, itmsz*nitm );
11229   data[itmsz*nitm] = '\0';
11230
11231   end = data + itmsz * nitm;
11232   retval = (int) nitm; /* on success return # items written */
11233
11234   cpd = data;
11235   while (cpd <= end) {
11236     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11237     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11238     if (cp < end)
11239       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11240     cpd = cp + 1;
11241   }
11242
11243   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11244   return retval;
11245
11246 }  /* end of my_fwrite() */
11247 /*}}}*/
11248
11249 /*{{{ int my_flush(FILE *fp)*/
11250 int
11251 Perl_my_flush(pTHX_ FILE *fp)
11252 {
11253     int res;
11254     if ((res = fflush(fp)) == 0 && fp) {
11255 #ifdef VMS_DO_SOCKETS
11256         Stat_t s;
11257         if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11258 #endif
11259             res = fsync(fileno(fp));
11260     }
11261 /*
11262  * If the flush succeeded but set end-of-file, we need to clear
11263  * the error because our caller may check ferror().  BTW, this
11264  * probably means we just flushed an empty file.
11265  */
11266     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11267
11268     return res;
11269 }
11270 /*}}}*/
11271
11272 /* fgetname() is not returning the correct file specifications when
11273  * decc_filename_unix_report mode is active.  So we have to have it
11274  * aways return filenames in VMS mode and convert it ourselves.
11275  */
11276
11277 /*{{{ char * my_fgetname(FILE *fp, buf)*/
11278 char *
11279 Perl_my_fgetname(FILE *fp, char * buf) {
11280     char * retname;
11281     char * vms_name;
11282
11283     retname = fgetname(fp, buf, 1);
11284
11285     /* If we are in VMS mode, then we are done */
11286     if (!decc_filename_unix_report || (retname == NULL)) {
11287        return retname;
11288     }
11289
11290     /* Convert this to Unix format */
11291     vms_name = (char *)PerlMem_malloc(VMS_MAXRSS);
11292     my_strlcpy(vms_name, retname, VMS_MAXRSS);
11293     retname = int_tounixspec(vms_name, buf, NULL);
11294     PerlMem_free(vms_name);
11295
11296     return retname;
11297 }
11298 /*}}}*/
11299
11300 /*
11301  * Here are replacements for the following Unix routines in the VMS environment:
11302  *      getpwuid    Get information for a particular UIC or UID
11303  *      getpwnam    Get information for a named user
11304  *      getpwent    Get information for each user in the rights database
11305  *      setpwent    Reset search to the start of the rights database
11306  *      endpwent    Finish searching for users in the rights database
11307  *
11308  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11309  * (defined in pwd.h), which contains the following fields:-
11310  *      struct passwd {
11311  *              char        *pw_name;    Username (in lower case)
11312  *              char        *pw_passwd;  Hashed password
11313  *              unsigned int pw_uid;     UIC
11314  *              unsigned int pw_gid;     UIC group  number
11315  *              char        *pw_unixdir; Default device/directory (VMS-style)
11316  *              char        *pw_gecos;   Owner name
11317  *              char        *pw_dir;     Default device/directory (Unix-style)
11318  *              char        *pw_shell;   Default CLI name (eg. DCL)
11319  *      };
11320  * If the specified user does not exist, getpwuid and getpwnam return NULL.
11321  *
11322  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11323  * not the UIC member number (eg. what's returned by getuid()),
11324  * getpwuid() can accept either as input (if uid is specified, the caller's
11325  * UIC group is used), though it won't recognise gid=0.
11326  *
11327  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11328  * information about other users in your group or in other groups, respectively.
11329  * If the required privilege is not available, then these routines fill only
11330  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11331  * string).
11332  *
11333  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11334  */
11335
11336 /* sizes of various UAF record fields */
11337 #define UAI$S_USERNAME 12
11338 #define UAI$S_IDENT    31
11339 #define UAI$S_OWNER    31
11340 #define UAI$S_DEFDEV   31
11341 #define UAI$S_DEFDIR   63
11342 #define UAI$S_DEFCLI   31
11343 #define UAI$S_PWD       8
11344
11345 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
11346                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11347                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
11348
11349 static char __empty[]= "";
11350 static struct passwd __passwd_empty=
11351     {(char *) __empty, (char *) __empty, 0, 0,
11352      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11353 static int contxt= 0;
11354 static struct passwd __pwdcache;
11355 static char __pw_namecache[UAI$S_IDENT+1];
11356
11357 /*
11358  * This routine does most of the work extracting the user information.
11359  */
11360 static int
11361 fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11362 {
11363     static struct {
11364         unsigned char length;
11365         char pw_gecos[UAI$S_OWNER+1];
11366     } owner;
11367     static union uicdef uic;
11368     static struct {
11369         unsigned char length;
11370         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11371     } defdev;
11372     static struct {
11373         unsigned char length;
11374         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11375     } defdir;
11376     static struct {
11377         unsigned char length;
11378         char pw_shell[UAI$S_DEFCLI+1];
11379     } defcli;
11380     static char pw_passwd[UAI$S_PWD+1];
11381
11382     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11383     struct dsc$descriptor_s name_desc;
11384     unsigned long int sts;
11385
11386     static struct itmlst_3 itmlst[]= {
11387         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
11388         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
11389         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
11390         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
11391         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
11392         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
11393         {0,                0,           NULL,    NULL}};
11394
11395     name_desc.dsc$w_length=  strlen(name);
11396     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11397     name_desc.dsc$b_class=   DSC$K_CLASS_S;
11398     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11399
11400 /*  Note that sys$getuai returns many fields as counted strings. */
11401     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11402     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11403       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11404     }
11405     else { _ckvmssts(sts); }
11406     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
11407
11408     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
11409     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11410     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11411     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11412     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11413     owner.pw_gecos[lowner]=            '\0';
11414     defdev.pw_dir[ldefdev+ldefdir]= '\0';
11415     defcli.pw_shell[ldefcli]=          '\0';
11416     if (valid_uic(uic)) {
11417         pwd->pw_uid= uic.uic$l_uic;
11418         pwd->pw_gid= uic.uic$v_group;
11419     }
11420     else
11421       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11422     pwd->pw_passwd=  pw_passwd;
11423     pwd->pw_gecos=   owner.pw_gecos;
11424     pwd->pw_dir=     defdev.pw_dir;
11425     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11426     pwd->pw_shell=   defcli.pw_shell;
11427     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11428         int ldir;
11429         ldir= strlen(pwd->pw_unixdir) - 1;
11430         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11431     }
11432     else
11433         my_strlcpy(pwd->pw_unixdir, pwd->pw_dir, sizeof(pwd->pw_unixdir));
11434     if (!decc_efs_case_preserve)
11435         __mystrtolower(pwd->pw_unixdir);
11436     return 1;
11437 }
11438
11439 /*
11440  * Get information for a named user.
11441 */
11442 /*{{{struct passwd *getpwnam(char *name)*/
11443 struct passwd *
11444 Perl_my_getpwnam(pTHX_ const char *name)
11445 {
11446     struct dsc$descriptor_s name_desc;
11447     union uicdef uic;
11448     unsigned long int sts;
11449
11450     __pwdcache = __passwd_empty;
11451     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11452       /* We still may be able to determine pw_uid and pw_gid */
11453       name_desc.dsc$w_length=  strlen(name);
11454       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11455       name_desc.dsc$b_class=   DSC$K_CLASS_S;
11456       name_desc.dsc$a_pointer= (char *) name;
11457       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11458         __pwdcache.pw_uid= uic.uic$l_uic;
11459         __pwdcache.pw_gid= uic.uic$v_group;
11460       }
11461       else {
11462         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11463           set_vaxc_errno(sts);
11464           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11465           return NULL;
11466         }
11467         else { _ckvmssts(sts); }
11468       }
11469     }
11470     my_strlcpy(__pw_namecache, name, sizeof(__pw_namecache));
11471     __pwdcache.pw_name= __pw_namecache;
11472     return &__pwdcache;
11473 }  /* end of my_getpwnam() */
11474 /*}}}*/
11475
11476 /*
11477  * Get information for a particular UIC or UID.
11478  * Called by my_getpwent with uid=-1 to list all users.
11479 */
11480 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11481 struct passwd *
11482 Perl_my_getpwuid(pTHX_ Uid_t uid)
11483 {
11484     const $DESCRIPTOR(name_desc,__pw_namecache);
11485     unsigned short lname;
11486     union uicdef uic;
11487     unsigned long int status;
11488
11489     if (uid == (unsigned int) -1) {
11490       do {
11491         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11492         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11493           set_vaxc_errno(status);
11494           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11495           my_endpwent();
11496           return NULL;
11497         }
11498         else { _ckvmssts(status); }
11499       } while (!valid_uic (uic));
11500     }
11501     else {
11502       uic.uic$l_uic= uid;
11503       if (!uic.uic$v_group)
11504         uic.uic$v_group= PerlProc_getgid();
11505       if (valid_uic(uic))
11506         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11507       else status = SS$_IVIDENT;
11508       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11509           status == RMS$_PRV) {
11510         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11511         return NULL;
11512       }
11513       else { _ckvmssts(status); }
11514     }
11515     __pw_namecache[lname]= '\0';
11516     __mystrtolower(__pw_namecache);
11517
11518     __pwdcache = __passwd_empty;
11519     __pwdcache.pw_name = __pw_namecache;
11520
11521 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11522     The identifier's value is usually the UIC, but it doesn't have to be,
11523     so if we can, we let fillpasswd update this. */
11524     __pwdcache.pw_uid =  uic.uic$l_uic;
11525     __pwdcache.pw_gid =  uic.uic$v_group;
11526
11527     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11528     return &__pwdcache;
11529
11530 }  /* end of my_getpwuid() */
11531 /*}}}*/
11532
11533 /*
11534  * Get information for next user.
11535 */
11536 /*{{{struct passwd *my_getpwent()*/
11537 struct passwd *
11538 Perl_my_getpwent(pTHX)
11539 {
11540     return (my_getpwuid((unsigned int) -1));
11541 }
11542 /*}}}*/
11543
11544 /*
11545  * Finish searching rights database for users.
11546 */
11547 /*{{{void my_endpwent()*/
11548 void
11549 Perl_my_endpwent(pTHX)
11550 {
11551     if (contxt) {
11552       _ckvmssts(sys$finish_rdb(&contxt));
11553       contxt= 0;
11554     }
11555 }
11556 /*}}}*/
11557
11558 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11559  * my_utime(), and flex_stat(), all of which operate on UTC unless
11560  * VMSISH_TIMES is true.
11561  */
11562 /* method used to handle UTC conversions:
11563  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
11564  */
11565 static int gmtime_emulation_type;
11566 /* number of secs to add to UTC POSIX-style time to get local time */
11567 static long int utc_offset_secs;
11568
11569 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11570  * in vmsish.h.  #undef them here so we can call the CRTL routines
11571  * directly.
11572  */
11573 #undef gmtime
11574 #undef localtime
11575 #undef time
11576
11577
11578 static time_t toutc_dst(time_t loc) {
11579   struct tm *rsltmp;
11580
11581   if ((rsltmp = localtime(&loc)) == NULL) return -1u;
11582   loc -= utc_offset_secs;
11583   if (rsltmp->tm_isdst) loc -= 3600;
11584   return loc;
11585 }
11586 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11587        ((gmtime_emulation_type || my_time(NULL)), \
11588        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11589        ((secs) - utc_offset_secs))))
11590
11591 static time_t toloc_dst(time_t utc) {
11592   struct tm *rsltmp;
11593
11594   utc += utc_offset_secs;
11595   if ((rsltmp = localtime(&utc)) == NULL) return -1u;
11596   if (rsltmp->tm_isdst) utc += 3600;
11597   return utc;
11598 }
11599 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11600        ((gmtime_emulation_type || my_time(NULL)), \
11601        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11602        ((secs) + utc_offset_secs))))
11603
11604 /* my_time(), my_localtime(), my_gmtime()
11605  * By default traffic in UTC time values, using CRTL gmtime() or
11606  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11607  * Note: We need to use these functions even when the CRTL has working
11608  * UTC support, since they also handle C<use vmsish qw(times);>
11609  *
11610  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
11611  * Modified by Charles Bailey <bailey@newman.upenn.edu>
11612  */
11613
11614 /*{{{time_t my_time(time_t *timep)*/
11615 time_t
11616 Perl_my_time(pTHX_ time_t *timep)
11617 {
11618   time_t when;
11619   struct tm *tm_p;
11620
11621   if (gmtime_emulation_type == 0) {
11622     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
11623                               /* results of calls to gmtime() and localtime() */
11624                               /* for same &base */
11625
11626     gmtime_emulation_type++;
11627     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11628       char off[LNM$C_NAMLENGTH+1];;
11629
11630       gmtime_emulation_type++;
11631       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11632         gmtime_emulation_type++;
11633         utc_offset_secs = 0;
11634         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11635       }
11636       else { utc_offset_secs = atol(off); }
11637     }
11638     else { /* We've got a working gmtime() */
11639       struct tm gmt, local;
11640
11641       gmt = *tm_p;
11642       tm_p = localtime(&base);
11643       local = *tm_p;
11644       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
11645       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11646       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
11647       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
11648     }
11649   }
11650
11651   when = time(NULL);
11652 # ifdef VMSISH_TIME
11653   if (VMSISH_TIME) when = _toloc(when);
11654 # endif
11655   if (timep != NULL) *timep = when;
11656   return when;
11657
11658 }  /* end of my_time() */
11659 /*}}}*/
11660
11661
11662 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11663 struct tm *
11664 Perl_my_gmtime(pTHX_ const time_t *timep)
11665 {
11666   time_t when;
11667   struct tm *rsltmp;
11668
11669   if (timep == NULL) {
11670     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11671     return NULL;
11672   }
11673   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11674
11675   when = *timep;
11676 # ifdef VMSISH_TIME
11677   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11678 #  endif
11679   return gmtime(&when);
11680 }  /* end of my_gmtime() */
11681 /*}}}*/
11682
11683
11684 /*{{{struct tm *my_localtime(const time_t *timep)*/
11685 struct tm *
11686 Perl_my_localtime(pTHX_ const time_t *timep)
11687 {
11688   time_t when;
11689
11690   if (timep == NULL) {
11691     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11692     return NULL;
11693   }
11694   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11695   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11696
11697   when = *timep;
11698 # ifdef VMSISH_TIME
11699   if (VMSISH_TIME) when = _toutc(when);
11700 # endif
11701   /* CRTL localtime() wants UTC as input, does tz correction itself */
11702   return localtime(&when);
11703 } /*  end of my_localtime() */
11704 /*}}}*/
11705
11706 /* Reset definitions for later calls */
11707 #define gmtime(t)    my_gmtime(t)
11708 #define localtime(t) my_localtime(t)
11709 #define time(t)      my_time(t)
11710
11711
11712 /* my_utime - update modification/access time of a file
11713  *
11714  * Only the UTC translation is home-grown. The rest is handled by the
11715  * CRTL utime(), which will take into account the relevant feature
11716  * logicals and ODS-5 volume characteristics for true access times.
11717  *
11718  */
11719
11720 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11721  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
11722  * in 100 ns intervals.
11723  */
11724 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11725
11726 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11727 int
11728 Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11729 {
11730   struct utimbuf utc_utimes, *utc_utimesp;
11731
11732   if (utimes != NULL) {
11733     utc_utimes.actime = utimes->actime;
11734     utc_utimes.modtime = utimes->modtime;
11735 # ifdef VMSISH_TIME
11736     /* If input was local; convert to UTC for sys svc */
11737     if (VMSISH_TIME) {
11738       utc_utimes.actime = _toutc(utimes->actime);
11739       utc_utimes.modtime = _toutc(utimes->modtime);
11740     }
11741 # endif
11742     utc_utimesp = &utc_utimes;
11743   }
11744   else {
11745     utc_utimesp = NULL;
11746   }
11747
11748   return utime(file, utc_utimesp);
11749
11750 }  /* end of my_utime() */
11751 /*}}}*/
11752
11753 /*
11754  * flex_stat, flex_lstat, flex_fstat
11755  * basic stat, but gets it right when asked to stat
11756  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11757  */
11758
11759 #ifndef _USE_STD_STAT
11760 /* encode_dev packs a VMS device name string into an integer to allow
11761  * simple comparisons. This can be used, for example, to check whether two
11762  * files are located on the same device, by comparing their encoded device
11763  * names. Even a string comparison would not do, because stat() reuses the
11764  * device name buffer for each call; so without encode_dev, it would be
11765  * necessary to save the buffer and use strcmp (this would mean a number of
11766  * changes to the standard Perl code, to say nothing of what a Perl script
11767  * would have to do.
11768  *
11769  * The device lock id, if it exists, should be unique (unless perhaps compared
11770  * with lock ids transferred from other nodes). We have a lock id if the disk is
11771  * mounted cluster-wide, which is when we tend to get long (host-qualified)
11772  * device names. Thus we use the lock id in preference, and only if that isn't
11773  * available, do we try to pack the device name into an integer (flagged by
11774  * the sign bit (LOCKID_MASK) being set).
11775  *
11776  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11777  * name and its encoded form, but it seems very unlikely that we will find
11778  * two files on different disks that share the same encoded device names,
11779  * and even more remote that they will share the same file id (if the test
11780  * is to check for the same file).
11781  *
11782  * A better method might be to use sys$device_scan on the first call, and to
11783  * search for the device, returning an index into the cached array.
11784  * The number returned would be more intelligible.
11785  * This is probably not worth it, and anyway would take quite a bit longer
11786  * on the first call.
11787  */
11788 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
11789 static mydev_t
11790 encode_dev (pTHX_ const char *dev)
11791 {
11792   int i;
11793   unsigned long int f;
11794   mydev_t enc;
11795   char c;
11796   const char *q;
11797
11798   if (!dev || !dev[0]) return 0;
11799
11800 #if LOCKID_MASK
11801   {
11802     struct dsc$descriptor_s dev_desc;
11803     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11804
11805     /* For cluster-mounted disks, the disk lock identifier is unique, so we
11806        can try that first. */
11807     dev_desc.dsc$w_length =  strlen (dev);
11808     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
11809     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
11810     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
11811     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11812     if (!$VMS_STATUS_SUCCESS(status)) {
11813       switch (status) {
11814         case SS$_NOSUCHDEV:
11815           SETERRNO(ENODEV, status);
11816           return 0;
11817         default:
11818           _ckvmssts(status);
11819       }
11820     }
11821     if (lockid) return (lockid & ~LOCKID_MASK);
11822   }
11823 #endif
11824
11825   /* Otherwise we try to encode the device name */
11826   enc = 0;
11827   f = 1;
11828   i = 0;
11829   for (q = dev + strlen(dev); q--; q >= dev) {
11830     if (*q == ':')
11831         break;
11832     if (isdigit (*q))
11833       c= (*q) - '0';
11834     else if (isalpha (toupper (*q)))
11835       c= toupper (*q) - 'A' + (char)10;
11836     else
11837       continue; /* Skip '$'s */
11838     i++;
11839     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
11840     if (i>1) f *= 36;
11841     enc += f * (unsigned long int) c;
11842   }
11843   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
11844
11845 }  /* end of encode_dev() */
11846 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11847         device_no = encode_dev(aTHX_ devname)
11848 #else
11849 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11850         device_no = new_dev_no
11851 #endif
11852
11853 static int
11854 is_null_device(const char *name)
11855 {
11856   if (decc_bug_devnull != 0) {
11857     if (strncmp("/dev/null", name, 9) == 0)
11858       return 1;
11859   }
11860     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11861        The underscore prefix, controller letter, and unit number are
11862        independently optional; for our purposes, the colon punctuation
11863        is not.  The colon can be trailed by optional directory and/or
11864        filename, but two consecutive colons indicates a nodename rather
11865        than a device.  [pr]  */
11866   if (*name == '_') ++name;
11867   if (tolower(*name++) != 'n') return 0;
11868   if (tolower(*name++) != 'l') return 0;
11869   if (tolower(*name) == 'a') ++name;
11870   if (*name == '0') ++name;
11871   return (*name++ == ':') && (*name != ':');
11872 }
11873
11874 static int
11875 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
11876
11877 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11878
11879 static I32
11880 Perl_cando_by_name_int(pTHX_ I32 bit, bool effective, const char *fname, int opts)
11881 {
11882   char usrname[L_cuserid];
11883   struct dsc$descriptor_s usrdsc =
11884          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11885   char *vmsname = NULL, *fileified = NULL;
11886   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11887   unsigned short int retlen, trnlnm_iter_count;
11888   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11889   union prvdef curprv;
11890   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11891          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11892          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11893   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11894          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11895          {0,0,0,0}};
11896   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11897          {0,0,0,0}};
11898   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11899   Stat_t st;
11900   static int profile_context = -1;
11901
11902   if (!fname || !*fname) return FALSE;
11903
11904   /* Make sure we expand logical names, since sys$check_access doesn't */
11905   fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
11906   if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11907   if (!strpbrk(fname,"/]>:")) {
11908       my_strlcpy(fileified, fname, VMS_MAXRSS);
11909       trnlnm_iter_count = 0;
11910       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11911         trnlnm_iter_count++;
11912         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11913       }
11914       fname = fileified;
11915   }
11916
11917   vmsname = (char *)PerlMem_malloc(VMS_MAXRSS);
11918   if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11919   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11920     /* Don't know if already in VMS format, so make sure */
11921     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11922       PerlMem_free(fileified);
11923       PerlMem_free(vmsname);
11924       return FALSE;
11925     }
11926   }
11927   else {
11928     my_strlcpy(vmsname, fname, VMS_MAXRSS);
11929   }
11930
11931   /* sys$check_access needs a file spec, not a directory spec.
11932    * flex_stat now will handle a null thread context during startup.
11933    */
11934
11935   retlen = namdsc.dsc$w_length = strlen(vmsname);
11936   if (vmsname[retlen-1] == ']'
11937       || vmsname[retlen-1] == '>'
11938       || vmsname[retlen-1] == ':'
11939       || (!flex_stat_int(vmsname, &st, 1) &&
11940           S_ISDIR(st.st_mode))) {
11941
11942       if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
11943         PerlMem_free(fileified);
11944         PerlMem_free(vmsname);
11945         return FALSE;
11946       }
11947       fname = fileified;
11948   }
11949   else {
11950       fname = vmsname;
11951   }
11952
11953   retlen = namdsc.dsc$w_length = strlen(fname);
11954   namdsc.dsc$a_pointer = (char *)fname;
11955
11956   switch (bit) {
11957     case S_IXUSR: case S_IXGRP: case S_IXOTH:
11958       access = ARM$M_EXECUTE;
11959       flags = CHP$M_READ;
11960       break;
11961     case S_IRUSR: case S_IRGRP: case S_IROTH:
11962       access = ARM$M_READ;
11963       flags = CHP$M_READ | CHP$M_USEREADALL;
11964       break;
11965     case S_IWUSR: case S_IWGRP: case S_IWOTH:
11966       access = ARM$M_WRITE;
11967       flags = CHP$M_READ | CHP$M_WRITE;
11968       break;
11969     case S_IDUSR: case S_IDGRP: case S_IDOTH:
11970       access = ARM$M_DELETE;
11971       flags = CHP$M_READ | CHP$M_WRITE;
11972       break;
11973     default:
11974       if (fileified != NULL)
11975         PerlMem_free(fileified);
11976       if (vmsname != NULL)
11977         PerlMem_free(vmsname);
11978       return FALSE;
11979   }
11980
11981   /* Before we call $check_access, create a user profile with the current
11982    * process privs since otherwise it just uses the default privs from the
11983    * UAF and might give false positives or negatives.  This only works on
11984    * VMS versions v6.0 and later since that's when sys$create_user_profile
11985    * became available.
11986    */
11987
11988   /* get current process privs and username */
11989   _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11990   _ckvmssts_noperl(iosb[0]);
11991
11992   /* find out the space required for the profile */
11993   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11994                                     &usrprodsc.dsc$w_length,&profile_context));
11995
11996   /* allocate space for the profile and get it filled in */
11997   usrprodsc.dsc$a_pointer = (char *)PerlMem_malloc(usrprodsc.dsc$w_length);
11998   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11999   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
12000                                     &usrprodsc.dsc$w_length,&profile_context));
12001
12002   /* use the profile to check access to the file; free profile & analyze results */
12003   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
12004   PerlMem_free(usrprodsc.dsc$a_pointer);
12005   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
12006
12007   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
12008       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
12009       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
12010     set_vaxc_errno(retsts);
12011     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12012     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12013     else set_errno(ENOENT);
12014     if (fileified != NULL)
12015       PerlMem_free(fileified);
12016     if (vmsname != NULL)
12017       PerlMem_free(vmsname);
12018     return FALSE;
12019   }
12020   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12021     if (fileified != NULL)
12022       PerlMem_free(fileified);
12023     if (vmsname != NULL)
12024       PerlMem_free(vmsname);
12025     return TRUE;
12026   }
12027   _ckvmssts_noperl(retsts);
12028
12029   if (fileified != NULL)
12030     PerlMem_free(fileified);
12031   if (vmsname != NULL)
12032     PerlMem_free(vmsname);
12033   return FALSE;  /* Should never get here */
12034
12035 }
12036
12037 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
12038 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12039  * subset of the applicable information.
12040  */
12041 bool
12042 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12043 {
12044   return cando_by_name_int
12045         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12046 }  /* end of cando() */
12047 /*}}}*/
12048
12049
12050 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12051 I32
12052 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12053 {
12054    return cando_by_name_int(bit, effective, fname, 0);
12055
12056 }  /* end of cando_by_name() */
12057 /*}}}*/
12058
12059
12060 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12061 int
12062 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12063 {
12064   dSAVE_ERRNO; /* fstat may set this even on success */
12065   if (!fstat(fd, &statbufp->crtl_stat)) {
12066     char *cptr;
12067     char *vms_filename;
12068     vms_filename = (char *)PerlMem_malloc(VMS_MAXRSS);
12069     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12070
12071     /* Save name for cando by name in VMS format */
12072     cptr = getname(fd, vms_filename, 1);
12073
12074     /* This should not happen, but just in case */
12075     if (cptr == NULL) {
12076         statbufp->st_devnam[0] = 0;
12077     }
12078     else {
12079         /* Make sure that the saved name fits in 255 characters */
12080         cptr = int_rmsexpand_vms
12081                        (vms_filename,
12082                         statbufp->st_devnam,
12083                         0);
12084         if (cptr == NULL)
12085             statbufp->st_devnam[0] = 0;
12086     }
12087     PerlMem_free(vms_filename);
12088
12089     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12090     VMS_DEVICE_ENCODE
12091         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12092
12093 #   ifdef VMSISH_TIME
12094     if (VMSISH_TIME) {
12095       statbufp->st_mtime = _toloc(statbufp->st_mtime);
12096       statbufp->st_atime = _toloc(statbufp->st_atime);
12097       statbufp->st_ctime = _toloc(statbufp->st_ctime);
12098     }
12099 #   endif
12100     RESTORE_ERRNO;
12101     return 0;
12102   }
12103   return -1;
12104
12105 }  /* end of flex_fstat() */
12106 /*}}}*/
12107
12108 static int
12109 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12110 {
12111     char *temp_fspec = NULL;
12112     char *fileified = NULL;
12113     const char *save_spec;
12114     char *ret_spec;
12115     int retval = -1;
12116     char efs_hack = 0;
12117     char already_fileified = 0;
12118     dSAVEDERRNO;
12119
12120     if (!fspec) {
12121         errno = EINVAL;
12122         return retval;
12123     }
12124
12125     if (decc_bug_devnull != 0) {
12126       if (is_null_device(fspec)) { /* Fake a stat() for the null device */
12127         memset(statbufp,0,sizeof *statbufp);
12128         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12129         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12130         statbufp->st_uid = 0x00010001;
12131         statbufp->st_gid = 0x0001;
12132         time((time_t *)&statbufp->st_mtime);
12133         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12134         return 0;
12135       }
12136     }
12137
12138     SAVE_ERRNO;
12139
12140 #if __CRTL_VER >= 80200000
12141   /*
12142    * If we are in POSIX filespec mode, accept the filename as is.
12143    */
12144   if (decc_posix_compliant_pathnames == 0) {
12145 #endif
12146
12147     /* Try for a simple stat first.  If fspec contains a filename without
12148      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12149      * and sea:[wine.dark]water. exist, the CRTL prefers the directory here.
12150      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12151      * not sea:[wine.dark]., if the latter exists.  If the intended target is
12152      * the file with null type, specify this by calling flex_stat() with
12153      * a '.' at the end of fspec.
12154      */
12155
12156     if (lstat_flag == 0)
12157         retval = stat(fspec, &statbufp->crtl_stat);
12158     else
12159         retval = lstat(fspec, &statbufp->crtl_stat);
12160
12161     if (!retval) {
12162         save_spec = fspec;
12163     }
12164     else {
12165         /* In the odd case where we have write but not read access
12166          * to a directory, stat('foo.DIR') works but stat('foo') doesn't.
12167          */
12168         fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
12169         if (fileified == NULL)
12170               _ckvmssts_noperl(SS$_INSFMEM);
12171
12172         ret_spec = int_fileify_dirspec(fspec, fileified, NULL);
12173         if (ret_spec != NULL) {
12174             if (lstat_flag == 0)
12175                 retval = stat(fileified, &statbufp->crtl_stat);
12176             else
12177                 retval = lstat(fileified, &statbufp->crtl_stat);
12178             save_spec = fileified;
12179             already_fileified = 1;
12180         }
12181     }
12182
12183     if (retval && vms_bug_stat_filename) {
12184
12185         temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
12186         if (temp_fspec == NULL)
12187             _ckvmssts_noperl(SS$_INSFMEM);
12188
12189         /* We should try again as a vmsified file specification. */
12190
12191         ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12192         if (ret_spec != NULL) {
12193             if (lstat_flag == 0)
12194                 retval = stat(temp_fspec, &statbufp->crtl_stat);
12195             else
12196                 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12197             save_spec = temp_fspec;
12198         }
12199     }
12200
12201     if (retval) {
12202         /* Last chance - allow multiple dots without EFS CHARSET */
12203         /* The CRTL stat() falls down hard on multi-dot filenames in unix
12204          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12205          * enable it if it isn't already.
12206          */
12207         if (!decc_efs_charset && (decc_efs_charset_index > 0))
12208             decc$feature_set_value(decc_efs_charset_index, 1, 1);
12209         if (lstat_flag == 0)
12210             retval = stat(fspec, &statbufp->crtl_stat);
12211         else
12212             retval = lstat(fspec, &statbufp->crtl_stat);
12213         save_spec = fspec;
12214         if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
12215             decc$feature_set_value(decc_efs_charset_index, 1, 0);
12216             efs_hack = 1;
12217         }
12218     }
12219
12220 #if __CRTL_VER >= 80200000
12221   } else {
12222     if (lstat_flag == 0)
12223       retval = stat(temp_fspec, &statbufp->crtl_stat);
12224     else
12225       retval = lstat(temp_fspec, &statbufp->crtl_stat);
12226       save_spec = temp_fspec;
12227   }
12228 #endif
12229
12230   /* As you were... */
12231   if (!decc_efs_charset)
12232     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12233
12234     if (!retval) {
12235       char *cptr;
12236       int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12237
12238       /* If this is an lstat, do not follow the link */
12239       if (lstat_flag)
12240         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12241
12242       /* If we used the efs_hack above, we must also use it here for */
12243       /* perl_cando to work */
12244       if (efs_hack && (decc_efs_charset_index > 0)) {
12245           decc$feature_set_value(decc_efs_charset_index, 1, 1);
12246       }
12247
12248       /* If we've got a directory, save a fileified, expanded version of it
12249        * in st_devnam.  If not a directory, just an expanded version.
12250        */
12251       if (S_ISDIR(statbufp->st_mode) && !already_fileified) {
12252           fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
12253           if (fileified == NULL)
12254               _ckvmssts_noperl(SS$_INSFMEM);
12255
12256           cptr = do_fileify_dirspec(save_spec, fileified, 0, NULL);
12257           if (cptr != NULL)
12258               save_spec = fileified;
12259       }
12260
12261       cptr = int_rmsexpand(save_spec,
12262                            statbufp->st_devnam,
12263                            NULL,
12264                            rmsex_flags,
12265                            0,
12266                            0);
12267
12268       if (efs_hack && (decc_efs_charset_index > 0)) {
12269           decc$feature_set_value(decc_efs_charset, 1, 0);
12270       }
12271
12272       /* Fix me: If this is NULL then stat found a file, and we could */
12273       /* not convert the specification to VMS - Should never happen */
12274       if (cptr == NULL)
12275         statbufp->st_devnam[0] = 0;
12276
12277       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12278       VMS_DEVICE_ENCODE
12279         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12280 #     ifdef VMSISH_TIME
12281       if (VMSISH_TIME) {
12282         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12283         statbufp->st_atime = _toloc(statbufp->st_atime);
12284         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12285       }
12286 #     endif
12287     }
12288     /* If we were successful, leave errno where we found it */
12289     if (retval == 0) RESTORE_ERRNO;
12290     if (temp_fspec)
12291         PerlMem_free(temp_fspec);
12292     if (fileified)
12293         PerlMem_free(fileified);
12294     return retval;
12295
12296 }  /* end of flex_stat_int() */
12297
12298
12299 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12300 int
12301 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12302 {
12303    return flex_stat_int(fspec, statbufp, 0);
12304 }
12305 /*}}}*/
12306
12307 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12308 int
12309 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12310 {
12311    return flex_stat_int(fspec, statbufp, 1);
12312 }
12313 /*}}}*/
12314
12315
12316 /*  rmscopy - copy a file using VMS RMS routines
12317  *
12318  *  Copies contents and attributes of spec_in to spec_out, except owner
12319  *  and protection information.  Name and type of spec_in are used as
12320  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
12321  *  should try to propagate timestamps from the input file to the output file.
12322  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
12323  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
12324  *  propagated to the output file at creation iff the output file specification
12325  *  did not contain an explicit name or type, and the revision date is always
12326  *  updated at the end of the copy operation.  If it is greater than 0, then
12327  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12328  *  other than the revision date should be propagated, and bit 1 indicates
12329  *  that the revision date should be propagated.
12330  *
12331  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12332  *
12333  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12334  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
12335  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
12336  * as part of the Perl standard distribution under the terms of the
12337  * GNU General Public License or the Perl Artistic License.  Copies
12338  * of each may be found in the Perl standard distribution.
12339  */ /* FIXME */
12340 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12341 int
12342 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12343 {
12344     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12345          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12346     unsigned long int sts;
12347     int dna_len;
12348     struct FAB fab_in, fab_out;
12349     struct RAB rab_in, rab_out;
12350     rms_setup_nam(nam);
12351     rms_setup_nam(nam_out);
12352     struct XABDAT xabdat;
12353     struct XABFHC xabfhc;
12354     struct XABRDT xabrdt;
12355     struct XABSUM xabsum;
12356
12357     vmsin = (char *)PerlMem_malloc(VMS_MAXRSS);
12358     if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12359     vmsout = (char *)PerlMem_malloc(VMS_MAXRSS);
12360     if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12361     if (!spec_in  || !*spec_in  || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
12362         !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
12363       PerlMem_free(vmsin);
12364       PerlMem_free(vmsout);
12365       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12366       return 0;
12367     }
12368
12369     esa = (char *)PerlMem_malloc(VMS_MAXRSS);
12370     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12371     esal = NULL;
12372 #if defined(NAML$C_MAXRSS)
12373     esal = (char *)PerlMem_malloc(VMS_MAXRSS);
12374     if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12375 #endif
12376     fab_in = cc$rms_fab;
12377     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12378     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12379     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12380     fab_in.fab$l_fop = FAB$M_SQO;
12381     rms_bind_fab_nam(fab_in, nam);
12382     fab_in.fab$l_xab = (void *) &xabdat;
12383
12384     rsa = (char *)PerlMem_malloc(VMS_MAXRSS);
12385     if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12386     rsal = NULL;
12387 #if defined(NAML$C_MAXRSS)
12388     rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
12389     if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12390 #endif
12391     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12392     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12393     rms_nam_esl(nam) = 0;
12394     rms_nam_rsl(nam) = 0;
12395     rms_nam_esll(nam) = 0;
12396     rms_nam_rsll(nam) = 0;
12397 #ifdef NAM$M_NO_SHORT_UPCASE
12398     if (decc_efs_case_preserve)
12399         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12400 #endif
12401
12402     xabdat = cc$rms_xabdat;        /* To get creation date */
12403     xabdat.xab$l_nxt = (void *) &xabfhc;
12404
12405     xabfhc = cc$rms_xabfhc;        /* To get record length */
12406     xabfhc.xab$l_nxt = (void *) &xabsum;
12407
12408     xabsum = cc$rms_xabsum;        /* To get key and area information */
12409
12410     if (!((sts = sys$open(&fab_in)) & 1)) {
12411       PerlMem_free(vmsin);
12412       PerlMem_free(vmsout);
12413       PerlMem_free(esa);
12414       if (esal != NULL)
12415         PerlMem_free(esal);
12416       PerlMem_free(rsa);
12417       if (rsal != NULL)
12418         PerlMem_free(rsal);
12419       set_vaxc_errno(sts);
12420       switch (sts) {
12421         case RMS$_FNF: case RMS$_DNF:
12422           set_errno(ENOENT); break;
12423         case RMS$_DIR:
12424           set_errno(ENOTDIR); break;
12425         case RMS$_DEV:
12426           set_errno(ENODEV); break;
12427         case RMS$_SYN:
12428           set_errno(EINVAL); break;
12429         case RMS$_PRV:
12430           set_errno(EACCES); break;
12431         default:
12432           set_errno(EVMSERR);
12433       }
12434       return 0;
12435     }
12436
12437     nam_out = nam;
12438     fab_out = fab_in;
12439     fab_out.fab$w_ifi = 0;
12440     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12441     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12442     fab_out.fab$l_fop = FAB$M_SQO;
12443     rms_bind_fab_nam(fab_out, nam_out);
12444     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12445     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12446     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12447     esa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
12448     if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12449     rsa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
12450     if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12451     esal_out = NULL;
12452     rsal_out = NULL;
12453 #if defined(NAML$C_MAXRSS)
12454     esal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
12455     if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12456     rsal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
12457     if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12458 #endif
12459     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12460     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12461
12462     if (preserve_dates == 0) {  /* Act like DCL COPY */
12463       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12464       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
12465       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12466         PerlMem_free(vmsin);
12467         PerlMem_free(vmsout);
12468         PerlMem_free(esa);
12469         if (esal != NULL)
12470             PerlMem_free(esal);
12471         PerlMem_free(rsa);
12472         if (rsal != NULL)
12473             PerlMem_free(rsal);
12474         PerlMem_free(esa_out);
12475         if (esal_out != NULL)
12476             PerlMem_free(esal_out);
12477         PerlMem_free(rsa_out);
12478         if (rsal_out != NULL)
12479             PerlMem_free(rsal_out);
12480         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12481         set_vaxc_errno(sts);
12482         return 0;
12483       }
12484       fab_out.fab$l_xab = (void *) &xabdat;
12485       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12486         preserve_dates = 1;
12487     }
12488     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
12489       preserve_dates =0;      /* bitmask from this point forward   */
12490
12491     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12492     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12493       PerlMem_free(vmsin);
12494       PerlMem_free(vmsout);
12495       PerlMem_free(esa);
12496       if (esal != NULL)
12497           PerlMem_free(esal);
12498       PerlMem_free(rsa);
12499       if (rsal != NULL)
12500           PerlMem_free(rsal);
12501       PerlMem_free(esa_out);
12502       if (esal_out != NULL)
12503           PerlMem_free(esal_out);
12504       PerlMem_free(rsa_out);
12505       if (rsal_out != NULL)
12506           PerlMem_free(rsal_out);
12507       set_vaxc_errno(sts);
12508       switch (sts) {
12509         case RMS$_DNF:
12510           set_errno(ENOENT); break;
12511         case RMS$_DIR:
12512           set_errno(ENOTDIR); break;
12513         case RMS$_DEV:
12514           set_errno(ENODEV); break;
12515         case RMS$_SYN:
12516           set_errno(EINVAL); break;
12517         case RMS$_PRV:
12518           set_errno(EACCES); break;
12519         default:
12520           set_errno(EVMSERR);
12521       }
12522       return 0;
12523     }
12524     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
12525     if (preserve_dates & 2) {
12526       /* sys$close() will process xabrdt, not xabdat */
12527       xabrdt = cc$rms_xabrdt;
12528       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12529       fab_out.fab$l_xab = (void *) &xabrdt;
12530     }
12531
12532     ubf = (char *)PerlMem_malloc(32256);
12533     if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12534     rab_in = cc$rms_rab;
12535     rab_in.rab$l_fab = &fab_in;
12536     rab_in.rab$l_rop = RAB$M_BIO;
12537     rab_in.rab$l_ubf = ubf;
12538     rab_in.rab$w_usz = 32256;
12539     if (!((sts = sys$connect(&rab_in)) & 1)) {
12540       sys$close(&fab_in); sys$close(&fab_out);
12541       PerlMem_free(vmsin);
12542       PerlMem_free(vmsout);
12543       PerlMem_free(ubf);
12544       PerlMem_free(esa);
12545       if (esal != NULL)
12546           PerlMem_free(esal);
12547       PerlMem_free(rsa);
12548       if (rsal != NULL)
12549           PerlMem_free(rsal);
12550       PerlMem_free(esa_out);
12551       if (esal_out != NULL)
12552           PerlMem_free(esal_out);
12553       PerlMem_free(rsa_out);
12554       if (rsal_out != NULL)
12555           PerlMem_free(rsal_out);
12556       set_errno(EVMSERR); set_vaxc_errno(sts);
12557       return 0;
12558     }
12559
12560     rab_out = cc$rms_rab;
12561     rab_out.rab$l_fab = &fab_out;
12562     rab_out.rab$l_rbf = ubf;
12563     if (!((sts = sys$connect(&rab_out)) & 1)) {
12564       sys$close(&fab_in); sys$close(&fab_out);
12565       PerlMem_free(vmsin);
12566       PerlMem_free(vmsout);
12567       PerlMem_free(ubf);
12568       PerlMem_free(esa);
12569       if (esal != NULL)
12570           PerlMem_free(esal);
12571       PerlMem_free(rsa);
12572       if (rsal != NULL)
12573           PerlMem_free(rsal);
12574       PerlMem_free(esa_out);
12575       if (esal_out != NULL)
12576           PerlMem_free(esal_out);
12577       PerlMem_free(rsa_out);
12578       if (rsal_out != NULL)
12579           PerlMem_free(rsal_out);
12580       set_errno(EVMSERR); set_vaxc_errno(sts);
12581       return 0;
12582     }
12583
12584     while ((sts = sys$read(&rab_in))) {  /* always true  */
12585       if (sts == RMS$_EOF) break;
12586       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12587       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12588         sys$close(&fab_in); sys$close(&fab_out);
12589         PerlMem_free(vmsin);
12590         PerlMem_free(vmsout);
12591         PerlMem_free(ubf);
12592         PerlMem_free(esa);
12593         if (esal != NULL)
12594             PerlMem_free(esal);
12595         PerlMem_free(rsa);
12596         if (rsal != NULL)
12597             PerlMem_free(rsal);
12598         PerlMem_free(esa_out);
12599         if (esal_out != NULL)
12600             PerlMem_free(esal_out);
12601         PerlMem_free(rsa_out);
12602         if (rsal_out != NULL)
12603             PerlMem_free(rsal_out);
12604         set_errno(EVMSERR); set_vaxc_errno(sts);
12605         return 0;
12606       }
12607     }
12608
12609
12610     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
12611     sys$close(&fab_in);  sys$close(&fab_out);
12612     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12613
12614     PerlMem_free(vmsin);
12615     PerlMem_free(vmsout);
12616     PerlMem_free(ubf);
12617     PerlMem_free(esa);
12618     if (esal != NULL)
12619         PerlMem_free(esal);
12620     PerlMem_free(rsa);
12621     if (rsal != NULL)
12622         PerlMem_free(rsal);
12623     PerlMem_free(esa_out);
12624     if (esal_out != NULL)
12625         PerlMem_free(esal_out);
12626     PerlMem_free(rsa_out);
12627     if (rsal_out != NULL)
12628         PerlMem_free(rsal_out);
12629
12630     if (!(sts & 1)) {
12631       set_errno(EVMSERR); set_vaxc_errno(sts);
12632       return 0;
12633     }
12634
12635     return 1;
12636
12637 }  /* end of rmscopy() */
12638 /*}}}*/
12639
12640
12641 /***  The following glue provides 'hooks' to make some of the routines
12642  * from this file available from Perl.  These routines are sufficiently
12643  * basic, and are required sufficiently early in the build process,
12644  * that's it's nice to have them available to miniperl as well as the
12645  * full Perl, so they're set up here instead of in an extension.  The
12646  * Perl code which handles importation of these names into a given
12647  * package lives in [.VMS]Filespec.pm in @INC.
12648  */
12649
12650 void
12651 rmsexpand_fromperl(pTHX_ CV *cv)
12652 {
12653   dXSARGS;
12654   char *fspec, *defspec = NULL, *rslt;
12655   STRLEN n_a;
12656   int fs_utf8, dfs_utf8;
12657
12658   fs_utf8 = 0;
12659   dfs_utf8 = 0;
12660   if (!items || items > 2)
12661     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12662   fspec = SvPV(ST(0),n_a);
12663   fs_utf8 = SvUTF8(ST(0));
12664   if (!fspec || !*fspec) XSRETURN_UNDEF;
12665   if (items == 2) {
12666     defspec = SvPV(ST(1),n_a);
12667     dfs_utf8 = SvUTF8(ST(1));
12668   }
12669   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12670   ST(0) = sv_newmortal();
12671   if (rslt != NULL) {
12672     sv_usepvn(ST(0),rslt,strlen(rslt));
12673     if (fs_utf8) {
12674         SvUTF8_on(ST(0));
12675     }
12676   }
12677   XSRETURN(1);
12678 }
12679
12680 void
12681 vmsify_fromperl(pTHX_ CV *cv)
12682 {
12683   dXSARGS;
12684   char *vmsified;
12685   STRLEN n_a;
12686   int utf8_fl;
12687
12688   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12689   utf8_fl = SvUTF8(ST(0));
12690   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12691   ST(0) = sv_newmortal();
12692   if (vmsified != NULL) {
12693     sv_usepvn(ST(0),vmsified,strlen(vmsified));
12694     if (utf8_fl) {
12695         SvUTF8_on(ST(0));
12696     }
12697   }
12698   XSRETURN(1);
12699 }
12700
12701 void
12702 unixify_fromperl(pTHX_ CV *cv)
12703 {
12704   dXSARGS;
12705   char *unixified;
12706   STRLEN n_a;
12707   int utf8_fl;
12708
12709   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12710   utf8_fl = SvUTF8(ST(0));
12711   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12712   ST(0) = sv_newmortal();
12713   if (unixified != NULL) {
12714     sv_usepvn(ST(0),unixified,strlen(unixified));
12715     if (utf8_fl) {
12716         SvUTF8_on(ST(0));
12717     }
12718   }
12719   XSRETURN(1);
12720 }
12721
12722 void
12723 fileify_fromperl(pTHX_ CV *cv)
12724 {
12725   dXSARGS;
12726   char *fileified;
12727   STRLEN n_a;
12728   int utf8_fl;
12729
12730   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12731   utf8_fl = SvUTF8(ST(0));
12732   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12733   ST(0) = sv_newmortal();
12734   if (fileified != NULL) {
12735     sv_usepvn(ST(0),fileified,strlen(fileified));
12736     if (utf8_fl) {
12737         SvUTF8_on(ST(0));
12738     }
12739   }
12740   XSRETURN(1);
12741 }
12742
12743 void
12744 pathify_fromperl(pTHX_ CV *cv)
12745 {
12746   dXSARGS;
12747   char *pathified;
12748   STRLEN n_a;
12749   int utf8_fl;
12750
12751   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12752   utf8_fl = SvUTF8(ST(0));
12753   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12754   ST(0) = sv_newmortal();
12755   if (pathified != NULL) {
12756     sv_usepvn(ST(0),pathified,strlen(pathified));
12757     if (utf8_fl) {
12758         SvUTF8_on(ST(0));
12759     }
12760   }
12761   XSRETURN(1);
12762 }
12763
12764 void
12765 vmspath_fromperl(pTHX_ CV *cv)
12766 {
12767   dXSARGS;
12768   char *vmspath;
12769   STRLEN n_a;
12770   int utf8_fl;
12771
12772   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12773   utf8_fl = SvUTF8(ST(0));
12774   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12775   ST(0) = sv_newmortal();
12776   if (vmspath != NULL) {
12777     sv_usepvn(ST(0),vmspath,strlen(vmspath));
12778     if (utf8_fl) {
12779         SvUTF8_on(ST(0));
12780     }
12781   }
12782   XSRETURN(1);
12783 }
12784
12785 void
12786 unixpath_fromperl(pTHX_ CV *cv)
12787 {
12788   dXSARGS;
12789   char *unixpath;
12790   STRLEN n_a;
12791   int utf8_fl;
12792
12793   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12794   utf8_fl = SvUTF8(ST(0));
12795   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12796   ST(0) = sv_newmortal();
12797   if (unixpath != NULL) {
12798     sv_usepvn(ST(0),unixpath,strlen(unixpath));
12799     if (utf8_fl) {
12800         SvUTF8_on(ST(0));
12801     }
12802   }
12803   XSRETURN(1);
12804 }
12805
12806 void
12807 candelete_fromperl(pTHX_ CV *cv)
12808 {
12809   dXSARGS;
12810   char *fspec, *fsp;
12811   SV *mysv;
12812   IO *io;
12813   STRLEN n_a;
12814
12815   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12816
12817   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12818   Newx(fspec, VMS_MAXRSS, char);
12819   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12820   if (isGV_with_GP(mysv)) {
12821     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12822       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12823       ST(0) = &PL_sv_no;
12824       Safefree(fspec);
12825       XSRETURN(1);
12826     }
12827     fsp = fspec;
12828   }
12829   else {
12830     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12831       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12832       ST(0) = &PL_sv_no;
12833       Safefree(fspec);
12834       XSRETURN(1);
12835     }
12836   }
12837
12838   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12839   Safefree(fspec);
12840   XSRETURN(1);
12841 }
12842
12843 void
12844 rmscopy_fromperl(pTHX_ CV *cv)
12845 {
12846   dXSARGS;
12847   char *inspec, *outspec, *inp, *outp;
12848   int date_flag;
12849   SV *mysv;
12850   IO *io;
12851   STRLEN n_a;
12852
12853   if (items < 2 || items > 3)
12854     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12855
12856   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12857   Newx(inspec, VMS_MAXRSS, char);
12858   if (isGV_with_GP(mysv)) {
12859     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12860       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12861       ST(0) = sv_2mortal(newSViv(0));
12862       Safefree(inspec);
12863       XSRETURN(1);
12864     }
12865     inp = inspec;
12866   }
12867   else {
12868     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12869       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12870       ST(0) = sv_2mortal(newSViv(0));
12871       Safefree(inspec);
12872       XSRETURN(1);
12873     }
12874   }
12875   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12876   Newx(outspec, VMS_MAXRSS, char);
12877   if (isGV_with_GP(mysv)) {
12878     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12879       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12880       ST(0) = sv_2mortal(newSViv(0));
12881       Safefree(inspec);
12882       Safefree(outspec);
12883       XSRETURN(1);
12884     }
12885     outp = outspec;
12886   }
12887   else {
12888     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12889       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12890       ST(0) = sv_2mortal(newSViv(0));
12891       Safefree(inspec);
12892       Safefree(outspec);
12893       XSRETURN(1);
12894     }
12895   }
12896   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12897
12898   ST(0) = sv_2mortal(newSViv(rmscopy(inp,outp,date_flag)));
12899   Safefree(inspec);
12900   Safefree(outspec);
12901   XSRETURN(1);
12902 }
12903
12904 /* The mod2fname is limited to shorter filenames by design, so it should
12905  * not be modified to support longer EFS pathnames
12906  */
12907 void
12908 mod2fname(pTHX_ CV *cv)
12909 {
12910   dXSARGS;
12911   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12912        workbuff[NAM$C_MAXRSS*1 + 1];
12913   SSize_t counter, num_entries;
12914   /* ODS-5 ups this, but we want to be consistent, so... */
12915   int max_name_len = 39;
12916   AV *in_array = (AV *)SvRV(ST(0));
12917
12918   num_entries = av_tindex(in_array);
12919
12920   /* All the names start with PL_. */
12921   strcpy(ultimate_name, "PL_");
12922
12923   /* Clean up our working buffer */
12924   Zero(work_name, sizeof(work_name), char);
12925
12926   /* Run through the entries and build up a working name */
12927   for(counter = 0; counter <= num_entries; counter++) {
12928     /* If it's not the first name then tack on a __ */
12929     if (counter) {
12930       my_strlcat(work_name, "__", sizeof(work_name));
12931     }
12932     my_strlcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)), sizeof(work_name));
12933   }
12934
12935   /* Check to see if we actually have to bother...*/
12936   if (strlen(work_name) + 3 <= max_name_len) {
12937     my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
12938   } else {
12939     /* It's too darned big, so we need to go strip. We use the same */
12940     /* algorithm as xsubpp does. First, strip out doubled __ */
12941     char *source, *dest, last;
12942     dest = workbuff;
12943     last = 0;
12944     for (source = work_name; *source; source++) {
12945       if (last == *source && last == '_') {
12946         continue;
12947       }
12948       *dest++ = *source;
12949       last = *source;
12950     }
12951     /* Go put it back */
12952     my_strlcpy(work_name, workbuff, sizeof(work_name));
12953     /* Is it still too big? */
12954     if (strlen(work_name) + 3 > max_name_len) {
12955       /* Strip duplicate letters */
12956       last = 0;
12957       dest = workbuff;
12958       for (source = work_name; *source; source++) {
12959         if (last == toupper(*source)) {
12960         continue;
12961         }
12962         *dest++ = *source;
12963         last = toupper(*source);
12964       }
12965       my_strlcpy(work_name, workbuff, sizeof(work_name));
12966     }
12967
12968     /* Is it *still* too big? */
12969     if (strlen(work_name) + 3 > max_name_len) {
12970       /* Too bad, we truncate */
12971       work_name[max_name_len - 2] = 0;
12972     }
12973     my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
12974   }
12975
12976   /* Okay, return it */
12977   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
12978   XSRETURN(1);
12979 }
12980
12981 void
12982 hushexit_fromperl(pTHX_ CV *cv)
12983 {
12984     dXSARGS;
12985
12986     if (items > 0) {
12987         VMSISH_HUSHED = SvTRUE(ST(0));
12988     }
12989     ST(0) = boolSV(VMSISH_HUSHED);
12990     XSRETURN(1);
12991 }
12992
12993
12994 PerlIO *
12995 Perl_vms_start_glob(pTHX_ SV *tmpglob, IO *io)
12996 {
12997     PerlIO *fp;
12998     struct vs_str_st *rslt;
12999     char *vmsspec;
13000     char *rstr;
13001     char *begin, *cp;
13002     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13003     PerlIO *tmpfp;
13004     STRLEN i;
13005     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13006     struct dsc$descriptor_vs rsdsc;
13007     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13008     unsigned long hasver = 0, isunix = 0;
13009     unsigned long int lff_flags = 0;
13010     int rms_sts;
13011     int vms_old_glob = 1;
13012
13013     if (!SvOK(tmpglob)) {
13014         SETERRNO(ENOENT,RMS$_FNF);
13015         return NULL;
13016     }
13017
13018     vms_old_glob = !decc_filename_unix_report;
13019
13020 #ifdef VMS_LONGNAME_SUPPORT
13021     lff_flags = LIB$M_FIL_LONG_NAMES;
13022 #endif
13023     /* The Newx macro will not allow me to assign a smaller array
13024      * to the rslt pointer, so we will assign it to the begin char pointer
13025      * and then copy the value into the rslt pointer.
13026      */
13027     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13028     rslt = (struct vs_str_st *)begin;
13029     rslt->length = 0;
13030     rstr = &rslt->str[0];
13031     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13032     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13033     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13034     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13035
13036     Newx(vmsspec, VMS_MAXRSS, char);
13037
13038         /* We could find out if there's an explicit dev/dir or version
13039            by peeking into lib$find_file's internal context at
13040            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13041            but that's unsupported, so I don't want to do it now and
13042            have it bite someone in the future. */
13043         /* Fix-me: vms_split_path() is the only way to do this, the
13044            existing method will fail with many legal EFS or UNIX specifications
13045          */
13046
13047     cp = SvPV(tmpglob,i);
13048
13049     for (; i; i--) {
13050         if (cp[i] == ';') hasver = 1;
13051         if (cp[i] == '.') {
13052             if (sts) hasver = 1;
13053             else sts = 1;
13054         }
13055         if (cp[i] == '/') {
13056             hasdir = isunix = 1;
13057             break;
13058         }
13059         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13060             hasdir = 1;
13061             break;
13062         }
13063     }
13064
13065     /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13066     if ((hasdir == 0) && decc_filename_unix_report) {
13067         isunix = 1;
13068     }
13069
13070     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13071         char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13072         int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13073         int wildstar = 0;
13074         int wildquery = 0;
13075         int found = 0;
13076         Stat_t st;
13077         int stat_sts;
13078         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13079         if (!stat_sts && S_ISDIR(st.st_mode)) {
13080             char * vms_dir;
13081             const char * fname;
13082             STRLEN fname_len;
13083
13084             /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13085             /* path delimiter of ':>]', if so, then the old behavior has */
13086             /* obviously been specifically requested */
13087
13088             fname = SvPVX_const(tmpglob);
13089             fname_len = strlen(fname);
13090             vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13091             if (vms_old_glob || (vms_dir != NULL)) {
13092                 wilddsc.dsc$a_pointer = tovmspath_utf8(
13093                                             SvPVX(tmpglob),vmsspec,NULL);
13094                 ok = (wilddsc.dsc$a_pointer != NULL);
13095                 /* maybe passed 'foo' rather than '[.foo]', thus not
13096                    detected above */
13097                 hasdir = 1;
13098             } else {
13099                 /* Operate just on the directory, the special stat/fstat for */
13100                 /* leaves the fileified  specification in the st_devnam */
13101                 /* member. */
13102                 wilddsc.dsc$a_pointer = st.st_devnam;
13103                 ok = 1;
13104             }
13105         }
13106         else {
13107             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13108             ok = (wilddsc.dsc$a_pointer != NULL);
13109         }
13110         if (ok)
13111             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13112
13113         /* If not extended character set, replace ? with % */
13114         /* With extended character set, ? is a wildcard single character */
13115         for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13116             if (*cp == '?') {
13117                 wildquery = 1;
13118                 if (!decc_efs_charset)
13119                     *cp = '%';
13120             } else if (*cp == '%') {
13121                 wildquery = 1;
13122             } else if (*cp == '*') {
13123                 wildstar = 1;
13124             }
13125         }
13126
13127         if (ok) {
13128             wv_sts = vms_split_path(
13129                 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13130                 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13131                 &wvs_spec, &wvs_len);
13132         } else {
13133             wn_spec = NULL;
13134             wn_len = 0;
13135             we_spec = NULL;
13136             we_len = 0;
13137         }
13138
13139         sts = SS$_NORMAL;
13140         while (ok && $VMS_STATUS_SUCCESS(sts)) {
13141          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13142          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13143          int valid_find;
13144
13145             valid_find = 0;
13146             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13147                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
13148             if (!$VMS_STATUS_SUCCESS(sts))
13149                 break;
13150
13151             /* with varying string, 1st word of buffer contains result length */
13152             rstr[rslt->length] = '\0';
13153
13154              /* Find where all the components are */
13155              v_sts = vms_split_path
13156                        (rstr,
13157                         &v_spec,
13158                         &v_len,
13159                         &r_spec,
13160                         &r_len,
13161                         &d_spec,
13162                         &d_len,
13163                         &n_spec,
13164                         &n_len,
13165                         &e_spec,
13166                         &e_len,
13167                         &vs_spec,
13168                         &vs_len);
13169
13170             /* If no version on input, truncate the version on output */
13171             if (!hasver && (vs_len > 0)) {
13172                 *vs_spec = '\0';
13173                 vs_len = 0;
13174             }
13175
13176             if (isunix) {
13177
13178                 /* In Unix report mode, remove the ".dir;1" from the name */
13179                 /* if it is a real directory */
13180                 if (decc_filename_unix_report && decc_efs_charset) {
13181                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13182                         Stat_t statbuf;
13183                         int ret_sts;
13184
13185                         ret_sts = flex_lstat(rstr, &statbuf);
13186                         if ((ret_sts == 0) &&
13187                             S_ISDIR(statbuf.st_mode)) {
13188                             e_len = 0;
13189                             e_spec[0] = 0;
13190                         }
13191                     }
13192                 }
13193
13194                 /* No version & a null extension on UNIX handling */
13195                 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13196                     e_len = 0;
13197                     *e_spec = '\0';
13198                 }
13199             }
13200
13201             if (!decc_efs_case_preserve) {
13202                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13203             }
13204
13205             /* Find File treats a Null extension as return all extensions */
13206             /* This is contrary to Perl expectations */
13207
13208             if (wildstar || wildquery || vms_old_glob) {
13209                 /* really need to see if the returned file name matched */
13210                 /* but for now will assume that it matches */
13211                 valid_find = 1;
13212             } else {
13213                 /* Exact Match requested */
13214                 /* How are directories handled? - like a file */
13215                 if ((e_len == we_len) && (n_len == wn_len)) {
13216                     int t1;
13217                     t1 = e_len;
13218                     if (t1 > 0)
13219                         t1 = strncmp(e_spec, we_spec, e_len);
13220                     if (t1 == 0) {
13221                        t1 = n_len;
13222                        if (t1 > 0)
13223                            t1 = strncmp(n_spec, we_spec, n_len);
13224                        if (t1 == 0)
13225                            valid_find = 1;
13226                     }
13227                 }
13228             }
13229
13230             if (valid_find) {
13231                 found++;
13232
13233                 if (hasdir) {
13234                     if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13235                     begin = rstr;
13236                 }
13237                 else {
13238                     /* Start with the name */
13239                     begin = n_spec;
13240                 }
13241                 strcat(begin,"\n");
13242                 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13243             }
13244         }
13245         if (cxt) (void)lib$find_file_end(&cxt);
13246
13247         if (!found) {
13248             /* Be POSIXish: return the input pattern when no matches */
13249             my_strlcpy(rstr, SvPVX(tmpglob), VMS_MAXRSS);
13250             strcat(rstr,"\n");
13251             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13252         }
13253
13254         if (ok && sts != RMS$_NMF &&
13255             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13256         if (!ok) {
13257             if (!(sts & 1)) {
13258                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13259             }
13260             PerlIO_close(tmpfp);
13261             fp = NULL;
13262         }
13263         else {
13264             PerlIO_rewind(tmpfp);
13265             IoTYPE(io) = IoTYPE_RDONLY;
13266             IoIFP(io) = fp = tmpfp;
13267             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
13268         }
13269     }
13270     Safefree(vmsspec);
13271     Safefree(rslt);
13272     return fp;
13273 }
13274
13275
13276 static char *
13277 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13278                    int *utf8_fl);
13279
13280 void
13281 unixrealpath_fromperl(pTHX_ CV *cv)
13282 {
13283     dXSARGS;
13284     char *fspec, *rslt_spec, *rslt;
13285     STRLEN n_a;
13286
13287     if (!items || items != 1)
13288         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
13289
13290     fspec = SvPV(ST(0),n_a);
13291     if (!fspec || !*fspec) XSRETURN_UNDEF;
13292
13293     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13294     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13295
13296     ST(0) = sv_newmortal();
13297     if (rslt != NULL)
13298         sv_usepvn(ST(0),rslt,strlen(rslt));
13299     else
13300         Safefree(rslt_spec);
13301         XSRETURN(1);
13302 }
13303
13304 static char *
13305 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13306                    int *utf8_fl);
13307
13308 void
13309 vmsrealpath_fromperl(pTHX_ CV *cv)
13310 {
13311     dXSARGS;
13312     char *fspec, *rslt_spec, *rslt;
13313     STRLEN n_a;
13314
13315     if (!items || items != 1)
13316         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
13317
13318     fspec = SvPV(ST(0),n_a);
13319     if (!fspec || !*fspec) XSRETURN_UNDEF;
13320
13321     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13322     rslt = do_vms_realname(fspec, rslt_spec, NULL);
13323
13324     ST(0) = sv_newmortal();
13325     if (rslt != NULL)
13326         sv_usepvn(ST(0),rslt,strlen(rslt));
13327     else
13328         Safefree(rslt_spec);
13329         XSRETURN(1);
13330 }
13331
13332 #ifdef HAS_SYMLINK
13333 /*
13334  * A thin wrapper around decc$symlink to make sure we follow the
13335  * standard and do not create a symlink with a zero-length name,
13336  * and convert the target to Unix format, as the CRTL can't handle
13337  * targets in VMS format.
13338  */
13339 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
13340 int
13341 Perl_my_symlink(pTHX_ const char *contents, const char *link_name)
13342 {
13343     int sts;
13344     char * utarget;
13345
13346     if (!link_name || !*link_name) {
13347       SETERRNO(ENOENT, SS$_NOSUCHFILE);
13348       return -1;
13349     }
13350
13351     utarget = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
13352     /* An untranslatable filename should be passed through. */
13353     (void) int_tounixspec(contents, utarget, NULL);
13354     sts = symlink(utarget, link_name);
13355     PerlMem_free(utarget);
13356     return sts;
13357 }
13358 /*}}}*/
13359
13360 #endif /* HAS_SYMLINK */
13361
13362 int do_vms_case_tolerant(void);
13363
13364 void
13365 case_tolerant_process_fromperl(pTHX_ CV *cv)
13366 {
13367   dXSARGS;
13368   ST(0) = boolSV(do_vms_case_tolerant());
13369   XSRETURN(1);
13370 }
13371
13372 #ifdef USE_ITHREADS
13373
13374 void
13375 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13376                           struct interp_intern *dst)
13377 {
13378     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13379
13380     memcpy(dst,src,sizeof(struct interp_intern));
13381 }
13382
13383 #endif
13384
13385 void
13386 Perl_sys_intern_clear(pTHX)
13387 {
13388 }
13389
13390 void
13391 Perl_sys_intern_init(pTHX)
13392 {
13393     unsigned int ix = RAND_MAX;
13394     double x;
13395
13396     VMSISH_HUSHED = 0;
13397
13398     MY_POSIX_EXIT = vms_posix_exit;
13399
13400     x = (float)ix;
13401     MY_INV_RAND_MAX = 1./x;
13402 }
13403
13404 void
13405 init_os_extras(void)
13406 {
13407   dTHX;
13408   char* file = __FILE__;
13409   if (decc_disable_to_vms_logname_translation) {
13410     no_translate_barewords = TRUE;
13411   } else {
13412     no_translate_barewords = FALSE;
13413   }
13414
13415   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13416   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13417   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13418   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13419   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13420   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13421   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13422   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13423   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13424   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13425   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13426   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13427   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13428   newXSproto("VMS::Filespec::case_tolerant_process",
13429       case_tolerant_process_fromperl,file,"");
13430
13431   store_pipelocs(aTHX);         /* will redo any earlier attempts */
13432
13433   return;
13434 }
13435
13436 #if __CRTL_VER == 80200000
13437 /* This missed getting in to the DECC SDK for 8.2 */
13438 char *realpath(const char *file_name, char * resolved_name, ...);
13439 #endif
13440
13441 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13442 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13443  * The perl fallback routine to provide realpath() is not as efficient
13444  * on OpenVMS.
13445  */
13446
13447 #ifdef __cplusplus
13448 extern "C" {
13449 #endif
13450
13451 /* Hack, use old stat() as fastest way of getting ino_t and device */
13452 int decc$stat(const char *name, void * statbuf);
13453 #if __CRTL_VER >= 80200000
13454 int decc$lstat(const char *name, void * statbuf);
13455 #else
13456 #define decc$lstat decc$stat
13457 #endif
13458
13459 #ifdef __cplusplus
13460 }
13461 #endif
13462
13463
13464 /* Realpath is fragile.  In 8.3 it does not work if the feature
13465  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13466  * links are implemented in RMS, not the CRTL. It also can fail if the
13467  * user does not have read/execute access to some of the directories.
13468  * So in order for Do What I Mean mode to work, if realpath() fails,
13469  * fall back to looking up the filename by the device name and FID.
13470  */
13471
13472 int vms_fid_to_name(char * outname, int outlen,
13473                     const char * name, int lstat_flag, mode_t * mode)
13474 {
13475 #pragma message save
13476 #pragma message disable MISALGNDSTRCT
13477 #pragma message disable MISALGNDMEM
13478 #pragma member_alignment save
13479 #pragma nomember_alignment
13480     struct statbuf_t {
13481         char       * st_dev;
13482         unsigned short st_ino[3];
13483         unsigned short old_st_mode;
13484         unsigned long  padl[30];  /* plenty of room */
13485     } statbuf;
13486 #pragma message restore
13487 #pragma member_alignment restore
13488
13489     int sts;
13490     struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13491     struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13492     char *fileified;
13493     char *temp_fspec;
13494     char *ret_spec;
13495
13496     /* Need to follow the mostly the same rules as flex_stat_int, or we may get
13497      * unexpected answers
13498      */
13499
13500     fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
13501     if (fileified == NULL)
13502         _ckvmssts_noperl(SS$_INSFMEM);
13503
13504     temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
13505     if (temp_fspec == NULL)
13506         _ckvmssts_noperl(SS$_INSFMEM);
13507
13508     sts = -1;
13509     /* First need to try as a directory */
13510     ret_spec = int_tovmspath(name, temp_fspec, NULL);
13511     if (ret_spec != NULL) {
13512         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
13513         if (ret_spec != NULL) {
13514             if (lstat_flag == 0)
13515                 sts = decc$stat(fileified, &statbuf);
13516             else
13517                 sts = decc$lstat(fileified, &statbuf);
13518         }
13519     }
13520
13521     /* Then as a VMS file spec */
13522     if (sts != 0) {
13523         ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
13524         if (ret_spec != NULL) {
13525             if (lstat_flag == 0) {
13526                 sts = decc$stat(temp_fspec, &statbuf);
13527             } else {
13528                 sts = decc$lstat(temp_fspec, &statbuf);
13529             }
13530         }
13531     }
13532
13533     if (sts) {
13534         /* Next try - allow multiple dots with out EFS CHARSET */
13535         /* The CRTL stat() falls down hard on multi-dot filenames in unix
13536          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
13537          * enable it if it isn't already.
13538          */
13539         if (!decc_efs_charset && (decc_efs_charset_index > 0))
13540             decc$feature_set_value(decc_efs_charset_index, 1, 1);
13541         ret_spec = int_tovmspath(name, temp_fspec, NULL);
13542         if (lstat_flag == 0) {
13543             sts = decc$stat(name, &statbuf);
13544         } else {
13545             sts = decc$lstat(name, &statbuf);
13546         }
13547         if (!decc_efs_charset && (decc_efs_charset_index > 0))
13548             decc$feature_set_value(decc_efs_charset_index, 1, 0);
13549     }
13550
13551
13552     /* and then because the Perl Unix to VMS conversion is not perfect */
13553     /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
13554     /* characters from filenames so we need to try it as-is */
13555     if (sts) {
13556         if (lstat_flag == 0) {
13557             sts = decc$stat(name, &statbuf);
13558         } else {
13559             sts = decc$lstat(name, &statbuf);
13560         }
13561     }
13562
13563     if (sts == 0) {
13564         int vms_sts;
13565
13566         dvidsc.dsc$a_pointer=statbuf.st_dev;
13567         dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13568
13569         specdsc.dsc$a_pointer = outname;
13570         specdsc.dsc$w_length = outlen-1;
13571
13572         vms_sts = lib$fid_to_name
13573             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13574         if ($VMS_STATUS_SUCCESS(vms_sts)) {
13575             outname[specdsc.dsc$w_length] = 0;
13576
13577             /* Return the mode */
13578             if (mode) {
13579                 *mode = statbuf.old_st_mode;
13580             }
13581         }
13582     }
13583     PerlMem_free(temp_fspec);
13584     PerlMem_free(fileified);
13585     return sts;
13586 }
13587
13588
13589
13590 static char *
13591 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13592                    int *utf8_fl)
13593 {
13594     char * rslt = NULL;
13595
13596 #ifdef HAS_SYMLINK
13597     if (decc_posix_compliant_pathnames > 0 ) {
13598         /* realpath currently only works if posix compliant pathnames are
13599          * enabled.  It may start working when they are not, but in that
13600          * case we still want the fallback behavior for backwards compatibility
13601          */
13602         rslt = realpath(filespec, outbuf);
13603     }
13604 #endif
13605
13606     if (rslt == NULL) {
13607         char * vms_spec;
13608         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13609         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13610         mode_t my_mode;
13611
13612         /* Fall back to fid_to_name */
13613
13614         Newx(vms_spec, VMS_MAXRSS + 1, char);
13615
13616         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
13617         if (sts == 0) {
13618
13619
13620             /* Now need to trim the version off */
13621             sts = vms_split_path
13622                   (vms_spec,
13623                    &v_spec,
13624                    &v_len,
13625                    &r_spec,
13626                    &r_len,
13627                    &d_spec,
13628                    &d_len,
13629                    &n_spec,
13630                    &n_len,
13631                    &e_spec,
13632                    &e_len,
13633                    &vs_spec,
13634                    &vs_len);
13635
13636
13637                 if (sts == 0) {
13638                     int haslower = 0;
13639                     const char *cp;
13640
13641                     /* Trim off the version */
13642                     int file_len = v_len + r_len + d_len + n_len + e_len;
13643                     vms_spec[file_len] = 0;
13644
13645                     /* Trim off the .DIR if this is a directory */
13646                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13647                         if (S_ISDIR(my_mode)) {
13648                             e_len = 0;
13649                             e_spec[0] = 0;
13650                         }
13651                     }
13652
13653                     /* Drop NULL extensions on UNIX file specification */
13654                     if ((e_len == 1) && decc_readdir_dropdotnotype) {
13655                         e_len = 0;
13656                         e_spec[0] = '\0';
13657                     }
13658
13659                     /* The result is expected to be in UNIX format */
13660                     rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
13661
13662                     /* Downcase if input had any lower case letters and
13663                      * case preservation is not in effect.
13664                      */
13665                     if (!decc_efs_case_preserve) {
13666                         for (cp = filespec; *cp; cp++)
13667                             if (islower(*cp)) { haslower = 1; break; }
13668
13669                         if (haslower) __mystrtolower(rslt);
13670                     }
13671                 }
13672         } else {
13673
13674             /* Now for some hacks to deal with backwards and forward */
13675             /* compatibility */
13676             if (!decc_efs_charset) {
13677
13678                 /* 1. ODS-2 mode wants to do a syntax only translation */
13679                 rslt = int_rmsexpand(filespec, outbuf,
13680                                     NULL, 0, NULL, utf8_fl);
13681
13682             } else {
13683                 if (decc_filename_unix_report) {
13684                     char * dir_name;
13685                     char * vms_dir_name;
13686                     char * file_name;
13687
13688                     /* 2. ODS-5 / UNIX report mode should return a failure */
13689                     /*    if the parent directory also does not exist */
13690                     /*    Otherwise, get the real path for the parent */
13691                     /*    and add the child to it. */
13692
13693                     /* basename / dirname only available for VMS 7.0+ */
13694                     /* So we may need to implement them as common routines */
13695
13696                     Newx(dir_name, VMS_MAXRSS + 1, char);
13697                     Newx(vms_dir_name, VMS_MAXRSS + 1, char);
13698                     dir_name[0] = '\0';
13699                     file_name = NULL;
13700
13701                     /* First try a VMS parse */
13702                     sts = vms_split_path
13703                           (filespec,
13704                            &v_spec,
13705                            &v_len,
13706                            &r_spec,
13707                            &r_len,
13708                            &d_spec,
13709                            &d_len,
13710                            &n_spec,
13711                            &n_len,
13712                            &e_spec,
13713                            &e_len,
13714                            &vs_spec,
13715                            &vs_len);
13716
13717                     if (sts == 0) {
13718                         /* This is VMS */
13719
13720                         int dir_len = v_len + r_len + d_len + n_len;
13721                         if (dir_len > 0) {
13722                            memcpy(dir_name, filespec, dir_len);
13723                            dir_name[dir_len] = '\0';
13724                            file_name = (char *)&filespec[dir_len + 1];
13725                         }
13726                     } else {
13727                         /* This must be UNIX */
13728                         char * tchar;
13729
13730                         tchar = strrchr(filespec, '/');
13731
13732                         if (tchar != NULL) {
13733                             int dir_len = tchar - filespec;
13734                             memcpy(dir_name, filespec, dir_len);
13735                             dir_name[dir_len] = '\0';
13736                             file_name = (char *) &filespec[dir_len + 1];
13737                         }
13738                     }
13739
13740                     /* Dir name is defaulted */
13741                     if (dir_name[0] == 0) {
13742                         dir_name[0] = '.';
13743                         dir_name[1] = '\0';
13744                     }
13745
13746                     /* Need realpath for the directory */
13747                     sts = vms_fid_to_name(vms_dir_name,
13748                                           VMS_MAXRSS + 1,
13749                                           dir_name, 0, NULL);
13750
13751                     if (sts == 0) {
13752                         /* Now need to pathify it. */
13753                         char *tdir = int_pathify_dirspec(vms_dir_name,
13754                                                          outbuf);
13755
13756                         /* And now add the original filespec to it */
13757                         if (file_name != NULL) {
13758                             my_strlcat(outbuf, file_name, VMS_MAXRSS);
13759                         }
13760                         return outbuf;
13761                     }
13762                     Safefree(vms_dir_name);
13763                     Safefree(dir_name);
13764                 }
13765             }
13766         }
13767         Safefree(vms_spec);
13768     }
13769     return rslt;
13770 }
13771
13772 static char *
13773 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13774                    int *utf8_fl)
13775 {
13776     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13777     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13778
13779     /* Fall back to fid_to_name */
13780
13781     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
13782     if (sts != 0) {
13783         return NULL;
13784     }
13785     else {
13786
13787
13788         /* Now need to trim the version off */
13789         sts = vms_split_path
13790                   (outbuf,
13791                    &v_spec,
13792                    &v_len,
13793                    &r_spec,
13794                    &r_len,
13795                    &d_spec,
13796                    &d_len,
13797                    &n_spec,
13798                    &n_len,
13799                    &e_spec,
13800                    &e_len,
13801                    &vs_spec,
13802                    &vs_len);
13803
13804
13805         if (sts == 0) {
13806             int haslower = 0;
13807             const char *cp;
13808
13809             /* Trim off the version */
13810             int file_len = v_len + r_len + d_len + n_len + e_len;
13811             outbuf[file_len] = 0;
13812
13813             /* Downcase if input had any lower case letters and
13814              * case preservation is not in effect.
13815              */
13816             if (!decc_efs_case_preserve) {
13817                 for (cp = filespec; *cp; cp++)
13818                     if (islower(*cp)) { haslower = 1; break; }
13819
13820                 if (haslower) __mystrtolower(outbuf);
13821             }
13822         }
13823     }
13824     return outbuf;
13825 }
13826
13827
13828 /*}}}*/
13829 /* External entry points */
13830 char *
13831 Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13832 {
13833     return do_vms_realpath(filespec, outbuf, utf8_fl);
13834 }
13835
13836 char *
13837 Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13838 {
13839     return do_vms_realname(filespec, outbuf, utf8_fl);
13840 }
13841
13842 /* case_tolerant */
13843
13844 /*{{{int do_vms_case_tolerant(void)*/
13845 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13846  * controlled by a process setting.
13847  */
13848 int
13849 do_vms_case_tolerant(void)
13850 {
13851     return vms_process_case_tolerant;
13852 }
13853 /*}}}*/
13854 /* External entry points */
13855 int
13856 Perl_vms_case_tolerant(void)
13857 {
13858     return do_vms_case_tolerant();
13859 }
13860
13861  /* Start of DECC RTL Feature handling */
13862
13863 static int
13864 set_feature_default(const char *name, int value)
13865 {
13866     int status;
13867     int index;
13868     char val_str[10];
13869
13870     /* If the feature has been explicitly disabled in the environment,
13871      * then don't enable it here.
13872      */
13873     if (value > 0) {
13874         status = simple_trnlnm(name, val_str, sizeof(val_str));
13875         if (status) {
13876             val_str[0] = _toupper(val_str[0]);
13877             if (val_str[0] == 'D' || val_str[0] == '0' || val_str[0] == 'F')
13878                 return 0;
13879         }
13880     }
13881
13882     index = decc$feature_get_index(name);
13883
13884     status = decc$feature_set_value(index, 1, value);
13885     if (index == -1 || (status == -1)) {
13886       return -1;
13887     }
13888
13889     status = decc$feature_get_value(index, 1);
13890     if (status != value) {
13891       return -1;
13892     }
13893
13894     /* Various things may check for an environment setting
13895      * rather than the feature directly, so set that too.
13896      */
13897     vmssetuserlnm(name, value ? "ENABLE" : "DISABLE");
13898
13899     return 0;
13900 }
13901
13902
13903 /* C RTL Feature settings */
13904
13905 #if defined(__DECC) || defined(__DECCXX)
13906
13907 #ifdef __cplusplus
13908 extern "C" {
13909 #endif
13910
13911 extern void
13912 vmsperl_set_features(void)
13913 {
13914     int status;
13915     int s;
13916     char val_str[10];
13917 #if defined(JPI$_CASE_LOOKUP_PERM)
13918     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13919     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13920     unsigned long case_perm;
13921     unsigned long case_image;
13922 #endif
13923
13924     /* Allow an exception to bring Perl into the VMS debugger */
13925     vms_debug_on_exception = 0;
13926     status = simple_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
13927     if (status) {
13928        val_str[0] = _toupper(val_str[0]);
13929        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13930          vms_debug_on_exception = 1;
13931        else
13932          vms_debug_on_exception = 0;
13933     }
13934
13935     /* Debug unix/vms file translation routines */
13936     vms_debug_fileify = 0;
13937     status = simple_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
13938     if (status) {
13939         val_str[0] = _toupper(val_str[0]);
13940         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13941             vms_debug_fileify = 1;
13942         else
13943             vms_debug_fileify = 0;
13944     }
13945
13946
13947     /* Historically PERL has been doing vmsify / stat differently than */
13948     /* the CRTL.  In particular, under some conditions the CRTL will   */
13949     /* remove some illegal characters like spaces from filenames       */
13950     /* resulting in some differences.  The stat()/lstat() wrapper has  */
13951     /* been reporting such file names as invalid and fails to stat them */
13952     /* fixing this bug so that stat()/lstat() accept these like the     */
13953     /* CRTL does will result in several tests failing.                  */
13954     /* This should really be fixed, but for now, set up a feature to    */
13955     /* enable it so that the impact can be studied.                     */
13956     vms_bug_stat_filename = 0;
13957     status = simple_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
13958     if (status) {
13959         val_str[0] = _toupper(val_str[0]);
13960         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13961             vms_bug_stat_filename = 1;
13962         else
13963             vms_bug_stat_filename = 0;
13964     }
13965
13966
13967     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
13968     vms_vtf7_filenames = 0;
13969     status = simple_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
13970     if (status) {
13971        val_str[0] = _toupper(val_str[0]);
13972        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13973          vms_vtf7_filenames = 1;
13974        else
13975          vms_vtf7_filenames = 0;
13976     }
13977
13978     /* unlink all versions on unlink() or rename() */
13979     vms_unlink_all_versions = 0;
13980     status = simple_trnlnm("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13981     if (status) {
13982        val_str[0] = _toupper(val_str[0]);
13983        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13984          vms_unlink_all_versions = 1;
13985        else
13986          vms_unlink_all_versions = 0;
13987     }
13988
13989     /* Detect running under GNV Bash or other UNIX like shell */
13990     gnv_unix_shell = 0;
13991     status = simple_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
13992     if (status) {
13993          gnv_unix_shell = 1;
13994          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
13995          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
13996          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
13997          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
13998          vms_unlink_all_versions = 1;
13999          vms_posix_exit = 1;
14000          /* Reverse default ordering of PERL_ENV_TABLES. */
14001          defenv[0] = &crtlenvdsc;
14002          defenv[1] = &fildevdsc;
14003     }
14004     /* Some reasonable defaults that are not CRTL defaults */
14005     set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
14006     set_feature_default("DECC$ARGV_PARSE_STYLE", 1);     /* Requires extended parse. */
14007     set_feature_default("DECC$EFS_CHARSET", 1);
14008
14009     /* hacks to see if known bugs are still present for testing */
14010
14011     /* PCP mode requires creating /dev/null special device file */
14012     decc_bug_devnull = 0;
14013     status = simple_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14014     if (status) {
14015        val_str[0] = _toupper(val_str[0]);
14016        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14017           decc_bug_devnull = 1;
14018        else
14019           decc_bug_devnull = 0;
14020     }
14021
14022     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14023     if (s >= 0) {
14024         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14025         if (decc_disable_to_vms_logname_translation < 0)
14026             decc_disable_to_vms_logname_translation = 0;
14027     }
14028
14029     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14030     if (s >= 0) {
14031         decc_efs_case_preserve = decc$feature_get_value(s, 1);
14032         if (decc_efs_case_preserve < 0)
14033             decc_efs_case_preserve = 0;
14034     }
14035
14036     s = decc$feature_get_index("DECC$EFS_CHARSET");
14037     decc_efs_charset_index = s;
14038     if (s >= 0) {
14039         decc_efs_charset = decc$feature_get_value(s, 1);
14040         if (decc_efs_charset < 0)
14041             decc_efs_charset = 0;
14042     }
14043
14044     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14045     if (s >= 0) {
14046         decc_filename_unix_report = decc$feature_get_value(s, 1);
14047         if (decc_filename_unix_report > 0) {
14048             decc_filename_unix_report = 1;
14049             vms_posix_exit = 1;
14050         }
14051         else
14052             decc_filename_unix_report = 0;
14053     }
14054
14055     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14056     if (s >= 0) {
14057         decc_filename_unix_only = decc$feature_get_value(s, 1);
14058         if (decc_filename_unix_only > 0) {
14059             decc_filename_unix_only = 1;
14060         }
14061         else {
14062             decc_filename_unix_only = 0;
14063         }
14064     }
14065
14066     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14067     if (s >= 0) {
14068         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14069         if (decc_filename_unix_no_version < 0)
14070             decc_filename_unix_no_version = 0;
14071     }
14072
14073     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14074     if (s >= 0) {
14075         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14076         if (decc_readdir_dropdotnotype < 0)
14077             decc_readdir_dropdotnotype = 0;
14078     }
14079
14080 #if __CRTL_VER >= 80200000
14081     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14082     if (s >= 0) {
14083         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14084         if (decc_posix_compliant_pathnames < 0)
14085             decc_posix_compliant_pathnames = 0;
14086         if (decc_posix_compliant_pathnames > 4)
14087             decc_posix_compliant_pathnames = 0;
14088     }
14089
14090 #endif
14091
14092 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND)
14093
14094      /* Report true case tolerance */
14095     /*----------------------------*/
14096     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14097     if (!$VMS_STATUS_SUCCESS(status))
14098         case_perm = PPROP$K_CASE_BLIND;
14099     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14100     if (!$VMS_STATUS_SUCCESS(status))
14101         case_image = PPROP$K_CASE_BLIND;
14102     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14103         (case_image == PPROP$K_CASE_SENSITIVE))
14104         vms_process_case_tolerant = 0;
14105
14106 #endif
14107
14108     /* USE POSIX/DCL Exit codes - Recommended, but needs to default to  */
14109     /* for strict backward compatibility */
14110     status = simple_trnlnm("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14111     if (status) {
14112        val_str[0] = _toupper(val_str[0]);
14113        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14114          vms_posix_exit = 1;
14115        else
14116          vms_posix_exit = 0;
14117     }
14118 }
14119
14120 /* Use 32-bit pointers because that's what the image activator
14121  * assumes for the LIB$INITIALZE psect.
14122  */
14123 #if __INITIAL_POINTER_SIZE
14124 #pragma pointer_size save
14125 #pragma pointer_size 32
14126 #endif
14127
14128 /* Create a reference to the LIB$INITIALIZE function. */
14129 extern void LIB$INITIALIZE(void);
14130 extern void (*vmsperl_unused_global_1)(void) = LIB$INITIALIZE;
14131
14132 /* Create an array of pointers to the init functions in the special
14133  * LIB$INITIALIZE section. In our case, the array only has one entry.
14134  */
14135 #pragma extern_model save
14136 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic,gbl,nowrt,noshr,long
14137 extern void (* const vmsperl_unused_global_2[])() =
14138 {
14139    vmsperl_set_features,
14140 };
14141 #pragma extern_model restore
14142
14143 #if __INITIAL_POINTER_SIZE
14144 #pragma pointer_size restore
14145 #endif
14146
14147 #ifdef __cplusplus
14148 }
14149 #endif
14150
14151 #endif /* defined(__DECC) || defined(__DECCXX) */
14152 /*  End of vms.c */