vms/vms.c

   1 /*    vms.c
   2  *
   3  *    VMS-specific routines for perl5
   4  *
   5  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
   6  *    2002, 2003, 2004, 2005, 2006, 2007 by Charles Bailey and others.
   7  *
   8  *    You may distribute under the terms of either the GNU General Public
   9  *    License or the Artistic License, as specified in the README file.
  10  *
  11  *    Please see Changes*.* or the Perl Repository Browser for revision history.
  12  */
  13
  14 /*
  15  *               Yet small as was their hunted band
  16  *               still fell and fearless was each hand,
  17  *               and strong deeds they wrought yet oft,
  18  *               and loved the woods, whose ways more soft
  19  *               them seemed than thralls of that black throne
  20  *               to live and languish in halls of stone.
  21  *
  22  *                           The Lay of Leithian, 135-40
  23  */
  24
  25 #include <acedef.h>
  26 #include <acldef.h>
  27 #include <armdef.h>
  28 #include <atrdef.h>
  29 #include <chpdef.h>
  30 #include <clidef.h>
  31 #include <climsgdef.h>
  32 #include <dcdef.h>
  33 #include <descrip.h>
  34 #include <devdef.h>
  35 #include <dvidef.h>
  36 #include <fibdef.h>
  37 #include <float.h>
  38 #include <fscndef.h>
  39 #include <iodef.h>
  40 #include <jpidef.h>
  41 #include <kgbdef.h>
  42 #include <libclidef.h>
  43 #include <libdef.h>
  44 #include <lib$routines.h>
  45 #include <lnmdef.h>
  46 #include <msgdef.h>
  47 #include <ossdef.h>
  48 #if __CRTL_VER >= 70301000 && !defined(__VAX)
  49 #include <ppropdef.h>
  50 #endif
  51 #include <prvdef.h>
  52 #include <psldef.h>
  53 #include <rms.h>
  54 #include <shrdef.h>
  55 #include <ssdef.h>
  56 #include <starlet.h>
  57 #include <strdef.h>
  58 #include <str$routines.h>
  59 #include <syidef.h>
  60 #include <uaidef.h>
  61 #include <uicdef.h>
  62 #include <stsdef.h>
  63 #include <rmsdef.h>
  64 #include <smgdef.h>
  65 #if __CRTL_VER >= 70000000 /* FIXME to earliest version */
  66 #include <efndef.h>
  67 #define NO_EFN EFN$C_ENF
  68 #else
  69 #define NO_EFN 0;
  70 #endif
  71
  72 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  73 int   decc$feature_get_index(const char *name);
  74 char* decc$feature_get_name(int index);
  75 int   decc$feature_get_value(int index, int mode);
  76 int   decc$feature_set_value(int index, int mode, int value);
  77 #else
  78 #include <unixlib.h>
  79 #endif
  80
  81 #pragma member_alignment save
  82 #pragma nomember_alignment longword
  83 struct item_list_3 {
  84         unsigned short len;
  85         unsigned short code;
  86         void * bufadr;
  87         unsigned short * retadr;
  88 };
  89 #pragma member_alignment restore
  90
  91 /* More specific prototype than in starlet_c.h makes programming errors
  92    more visible.
  93  */
  94 #ifdef sys$getdviw
  95 #undef sys$getdviw
  96 int sys$getdviw
  97        (unsigned long efn,
  98         unsigned short chan,
  99         const struct dsc$descriptor_s * devnam,
 100         const struct item_list_3 * itmlst,
 101         void * iosb,
 102         void * (astadr)(unsigned long),
 103         void * astprm,
 104         void * nullarg);
 105 #endif
 106
 107 #ifdef sys$get_security
 108 #undef sys$get_security
 109 int sys$get_security
 110        (const struct dsc$descriptor_s * clsnam,
 111         const struct dsc$descriptor_s * objnam,
 112         const unsigned int *objhan,
 113         unsigned int flags,
 114         const struct item_list_3 * itmlst,
 115         unsigned int * contxt,
 116         const unsigned int * acmode);
 117 #endif
 118
 119 #ifdef sys$set_security
 120 #undef sys$set_security
 121 int sys$set_security
 122        (const struct dsc$descriptor_s * clsnam,
 123         const struct dsc$descriptor_s * objnam,
 124         const unsigned int *objhan,
 125         unsigned int flags,
 126         const struct item_list_3 * itmlst,
 127         unsigned int * contxt,
 128         const unsigned int * acmode);
 129 #endif
 130
 131 #ifdef lib$find_image_symbol
 132 #undef lib$find_image_symbol
 133 int lib$find_image_symbol
 134        (const struct dsc$descriptor_s * imgname,
 135         const struct dsc$descriptor_s * symname,
 136         void * symval,
 137         const struct dsc$descriptor_s * defspec,
 138         unsigned long flag);
 139 #endif
 140
 141 #ifdef lib$rename_file
 142 #undef lib$rename_file
 143 int lib$rename_file
 144        (const struct dsc$descriptor_s * old_file_dsc,
 145         const struct dsc$descriptor_s * new_file_dsc,
 146         const struct dsc$descriptor_s * default_file_dsc,
 147         const struct dsc$descriptor_s * related_file_dsc,
 148         const unsigned long * flags,
 149         void * (success)(const struct dsc$descriptor_s * old_dsc,
 150                          const struct dsc$descriptor_s * new_dsc,
 151                          const void *),
 152         void * (error)(const struct dsc$descriptor_s * old_dsc,
 153                        const struct dsc$descriptor_s * new_dsc,
 154                        const int * rms_sts,
 155                        const int * rms_stv,
 156                        const int * error_src,
 157                        const void * usr_arg),
 158         int (confirm)(const struct dsc$descriptor_s * old_dsc,
 159                       const struct dsc$descriptor_s * new_dsc,
 160                       const void * old_fab,
 161                       const void * usr_arg),
 162         void * user_arg,
 163         struct dsc$descriptor_s * old_result_name_dsc,
 164         struct dsc$descriptor_s * new_result_name_dsc,
 165         unsigned long * file_scan_context);
 166 #endif
 167
 168 #if __CRTL_VER >= 70300000 && !defined(__VAX)
 169
 170 static int set_feature_default(const char *name, int value)
 171 {
 172     int status;
 173     int index;
 174
 175     index = decc$feature_get_index(name);
 176
 177     status = decc$feature_set_value(index, 1, value);
 178     if (index == -1 || (status == -1)) {
 179       return -1;
 180     }
 181
 182     status = decc$feature_get_value(index, 1);
 183     if (status != value) {
 184       return -1;
 185     }
 186
 187 return 0;
 188 }
 189 #endif
 190
 191 /* Older versions of ssdef.h don't have these */
 192 #ifndef SS$_INVFILFOROP
 193 #  define SS$_INVFILFOROP 3930
 194 #endif
 195 #ifndef SS$_NOSUCHOBJECT
 196 #  define SS$_NOSUCHOBJECT 2696
 197 #endif
 198
 199 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
 200 #define PERLIO_NOT_STDIO 0
 201
 202 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
 203  * code below needs to get to the underlying CRTL routines. */
 204 #define DONT_MASK_RTL_CALLS
 205 #include "EXTERN.h"
 206 #include "perl.h"
 207 #include "XSUB.h"
 208 /* Anticipating future expansion in lexical warnings . . . */
 209 #ifndef WARN_INTERNAL
 210 #  define WARN_INTERNAL WARN_MISC
 211 #endif
 212
 213 #ifdef VMS_LONGNAME_SUPPORT
 214 #include <libfildef.h>
 215 #endif
 216
 217 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
 218 #  define RTL_USES_UTC 1
 219 #endif
 220
 221 /* Routine to create a decterm for use with the Perl debugger */
 222 /* No headers, this information was found in the Programming Concepts Manual */
 223
 224 static int (*decw_term_port)
 225    (const struct dsc$descriptor_s * display,
 226     const struct dsc$descriptor_s * setup_file,
 227     const struct dsc$descriptor_s * customization,
 228     struct dsc$descriptor_s * result_device_name,
 229     unsigned short * result_device_name_length,
 230     void * controller,
 231     void * char_buffer,
 232     void * char_change_buffer) = 0;
 233
 234 /* gcc's header files don't #define direct access macros
 235  * corresponding to VAXC's variant structs */
 236 #ifdef __GNUC__
 237 #  define uic$v_format uic$r_uic_form.uic$v_format
 238 #  define uic$v_group uic$r_uic_form.uic$v_group
 239 #  define uic$v_member uic$r_uic_form.uic$v_member
 240 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 241 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 242 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 243 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 244 #endif
 245
 246 #if defined(NEED_AN_H_ERRNO)
 247 dEXT int h_errno;
 248 #endif
 249
 250 #ifdef __DECC
 251 #pragma message disable pragma
 252 #pragma member_alignment save
 253 #pragma nomember_alignment longword
 254 #pragma message save
 255 #pragma message disable misalgndmem
 256 #endif
 257 struct itmlst_3 {
 258   unsigned short int buflen;
 259   unsigned short int itmcode;
 260   void *bufadr;
 261   unsigned short int *retlen;
 262 };
 263
 264 struct filescan_itmlst_2 {
 265     unsigned short length;
 266     unsigned short itmcode;
 267     char * component;
 268 };
 269
 270 struct vs_str_st {
 271     unsigned short length;
 272     char str[65536];
 273 };
 274
 275 #ifdef __DECC
 276 #pragma message restore
 277 #pragma member_alignment restore
 278 #endif
 279
 280 #define do_fileify_dirspec(a,b,c,d)     mp_do_fileify_dirspec(aTHX_ a,b,c,d)
 281 #define do_pathify_dirspec(a,b,c,d)     mp_do_pathify_dirspec(aTHX_ a,b,c,d)
 282 #define do_tovmsspec(a,b,c,d)           mp_do_tovmsspec(aTHX_ a,b,c,0,d)
 283 #define do_tovmspath(a,b,c,d)           mp_do_tovmspath(aTHX_ a,b,c,d)
 284 #define do_rmsexpand(a,b,c,d,e,f,g)     mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
 285 #define do_vms_realpath(a,b,c)          mp_do_vms_realpath(aTHX_ a,b,c)
 286 #define do_vms_realname(a,b,c)          mp_do_vms_realname(aTHX_ a,b,c)
 287 #define do_tounixspec(a,b,c,d)          mp_do_tounixspec(aTHX_ a,b,c,d)
 288 #define do_tounixpath(a,b,c,d)          mp_do_tounixpath(aTHX_ a,b,c,d)
 289 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 290 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 291 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 292
 293 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
 294 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
 295 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
 296 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
 297
 298 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 299 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 300
 301 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 302  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 303  * the Perl facility.
 304  */
 305 #define PERL_LNM_MAX_ITER 10
 306
 307   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 308 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 309 #define MAX_DCL_SYMBOL          (8192)
 310 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 311 #else
 312 #define MAX_DCL_SYMBOL          (1024)
 313 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 314 #endif
 315
 316 static char *__mystrtolower(char *str)
 317 {
 318   if (str) for (; *str; ++str) *str= tolower(*str);
 319   return str;
 320 }
 321
 322 static struct dsc$descriptor_s fildevdsc =
 323   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 324 static struct dsc$descriptor_s crtlenvdsc =
 325   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 326 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 327 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 328 static struct dsc$descriptor_s **env_tables = defenv;
 329 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 330
 331 /* True if we shouldn't treat barewords as logicals during directory */
 332 /* munching */
 333 static int no_translate_barewords;
 334
 335 #ifndef RTL_USES_UTC
 336 static int tz_updated = 1;
 337 #endif
 338
 339 /* DECC Features that may need to affect how Perl interprets
 340  * displays filename information
 341  */
 342 static int decc_disable_to_vms_logname_translation = 1;
 343 static int decc_disable_posix_root = 1;
 344 int decc_efs_case_preserve = 0;
 345 static int decc_efs_charset = 0;
 346 static int decc_filename_unix_no_version = 0;
 347 static int decc_filename_unix_only = 0;
 348 int decc_filename_unix_report = 0;
 349 int decc_posix_compliant_pathnames = 0;
 350 int decc_readdir_dropdotnotype = 0;
 351 static int vms_process_case_tolerant = 1;
 352 int vms_vtf7_filenames = 0;
 353 int gnv_unix_shell = 0;
 354 static int vms_unlink_all_versions = 0;
 355
 356 /* bug workarounds if needed */
 357 int decc_bug_readdir_efs1 = 0;
 358 int decc_bug_devnull = 1;
 359 int decc_bug_fgetname = 0;
 360 int decc_dir_barename = 0;
 361
 362 static int vms_debug_on_exception = 0;
 363
 364 /* Is this a UNIX file specification?
 365  *   No longer a simple check with EFS file specs
 366  *   For now, not a full check, but need to
 367  *   handle POSIX ^UP^ specifications
 368  *   Fixing to handle ^/ cases would require
 369  *   changes to many other conversion routines.
 370  */
 371
 372 static int is_unix_filespec(const char *path)
 373 {
 374 int ret_val;
 375 const char * pch1;
 376
 377     ret_val = 0;
 378     if (strncmp(path,"\"^UP^",5) != 0) {
 379         pch1 = strchr(path, '/');
 380         if (pch1 != NULL)
 381             ret_val = 1;
 382         else {
 383
 384             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 385             if (decc_filename_unix_report || decc_filename_unix_only) {
 386             if (strcmp(path,".") == 0)
 387                 ret_val = 1;
 388             }
 389         }
 390     }
 391     return ret_val;
 392 }
 393
 394 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 395  */
 396
 397 static void ucs2_to_vtf7
 398    (char *outspec,
 399     unsigned long ucs2_char,
 400     int * output_cnt)
 401 {
 402 unsigned char * ucs_ptr;
 403 int hex;
 404
 405     ucs_ptr = (unsigned char *)&ucs2_char;
 406
 407     outspec[0] = '^';
 408     outspec[1] = 'U';
 409     hex = (ucs_ptr[1] >> 4) & 0xf;
 410     if (hex < 0xA)
 411         outspec[2] = hex + '0';
 412     else
 413         outspec[2] = (hex - 9) + 'A';
 414     hex = ucs_ptr[1] & 0xF;
 415     if (hex < 0xA)
 416         outspec[3] = hex + '0';
 417     else {
 418         outspec[3] = (hex - 9) + 'A';
 419     }
 420     hex = (ucs_ptr[0] >> 4) & 0xf;
 421     if (hex < 0xA)
 422         outspec[4] = hex + '0';
 423     else
 424         outspec[4] = (hex - 9) + 'A';
 425     hex = ucs_ptr[1] & 0xF;
 426     if (hex < 0xA)
 427         outspec[5] = hex + '0';
 428     else {
 429         outspec[5] = (hex - 9) + 'A';
 430     }
 431     *output_cnt = 6;
 432 }
 433
 434
 435 /* This handles the conversion of a UNIX extended character set to a ^
 436  * escaped VMS character.
 437  * in a UNIX file specification.
 438  *
 439  * The output count variable contains the number of characters added
 440  * to the output string.
 441  *
 442  * The return value is the number of characters read from the input string
 443  */
 444 static int copy_expand_unix_filename_escape
 445   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 446 {
 447 int count;
 448 int scnt;
 449 int utf8_flag;
 450
 451     utf8_flag = 0;
 452     if (utf8_fl)
 453       utf8_flag = *utf8_fl;
 454
 455     count = 0;
 456     *output_cnt = 0;
 457     if (*inspec >= 0x80) {
 458         if (utf8_fl && vms_vtf7_filenames) {
 459         unsigned long ucs_char;
 460
 461             ucs_char = 0;
 462
 463             if ((*inspec & 0xE0) == 0xC0) {
 464                 /* 2 byte Unicode */
 465                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 466                 if (ucs_char >= 0x80) {
 467                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 468                     return 2;
 469                 }
 470             } else if ((*inspec & 0xF0) == 0xE0) {
 471                 /* 3 byte Unicode */
 472                 ucs_char = ((inspec[0] & 0xF) << 12) +
 473                    ((inspec[1] & 0x3f) << 6) +
 474                    (inspec[2] & 0x3f);
 475                 if (ucs_char >= 0x800) {
 476                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 477                     return 3;
 478                 }
 479
 480 #if 0 /* I do not see longer sequences supported by OpenVMS */
 481       /* Maybe some one can fix this later */
 482             } else if ((*inspec & 0xF8) == 0xF0) {
 483                 /* 4 byte Unicode */
 484                 /* UCS-4 to UCS-2 */
 485             } else if ((*inspec & 0xFC) == 0xF8) {
 486                 /* 5 byte Unicode */
 487                 /* UCS-4 to UCS-2 */
 488             } else if ((*inspec & 0xFE) == 0xFC) {
 489                 /* 6 byte Unicode */
 490                 /* UCS-4 to UCS-2 */
 491 #endif
 492             }
 493         }
 494
 495         /* High bit set, but not a Unicode character! */
 496
 497         /* Non printing DECMCS or ISO Latin-1 character? */
 498         if (*inspec <= 0x9F) {
 499         int hex;
 500             outspec[0] = '^';
 501             outspec++;
 502             hex = (*inspec >> 4) & 0xF;
 503             if (hex < 0xA)
 504                 outspec[1] = hex + '0';
 505             else {
 506                 outspec[1] = (hex - 9) + 'A';
 507             }
 508             hex = *inspec & 0xF;
 509             if (hex < 0xA)
 510                 outspec[2] = hex + '0';
 511             else {
 512                 outspec[2] = (hex - 9) + 'A';
 513             }
 514             *output_cnt = 3;
 515             return 1;
 516         } else if (*inspec == 0xA0) {
 517             outspec[0] = '^';
 518             outspec[1] = 'A';
 519             outspec[2] = '0';
 520             *output_cnt = 3;
 521             return 1;
 522         } else if (*inspec == 0xFF) {
 523             outspec[0] = '^';
 524             outspec[1] = 'F';
 525             outspec[2] = 'F';
 526             *output_cnt = 3;
 527             return 1;
 528         }
 529         *outspec = *inspec;
 530         *output_cnt = 1;
 531         return 1;
 532     }
 533
 534     /* Is this a macro that needs to be passed through?
 535      * Macros start with $( and an alpha character, followed
 536      * by a string of alpha numeric characters ending with a )
 537      * If this does not match, then encode it as ODS-5.
 538      */
 539     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 540     int tcnt;
 541
 542         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 543             tcnt = 3;
 544             outspec[0] = inspec[0];
 545             outspec[1] = inspec[1];
 546             outspec[2] = inspec[2];
 547
 548             while(isalnum(inspec[tcnt]) ||
 549                   (inspec[2] == '.') || (inspec[2] == '_')) {
 550                 outspec[tcnt] = inspec[tcnt];
 551                 tcnt++;
 552             }
 553             if (inspec[tcnt] == ')') {
 554                 outspec[tcnt] = inspec[tcnt];
 555                 tcnt++;
 556                 *output_cnt = tcnt;
 557                 return tcnt;
 558             }
 559         }
 560     }
 561
 562     switch (*inspec) {
 563     case 0x7f:
 564         outspec[0] = '^';
 565         outspec[1] = '7';
 566         outspec[2] = 'F';
 567         *output_cnt = 3;
 568         return 1;
 569         break;
 570     case '?':
 571         if (decc_efs_charset == 0)
 572           outspec[0] = '%';
 573         else
 574           outspec[0] = '?';
 575         *output_cnt = 1;
 576         return 1;
 577         break;
 578     case '.':
 579     case '~':
 580     case '!':
 581     case '#':
 582     case '&':
 583     case '\'':
 584     case '`':
 585     case '(':
 586     case ')':
 587     case '+':
 588     case '@':
 589     case '{':
 590     case '}':
 591     case ',':
 592     case ';':
 593     case '[':
 594     case ']':
 595     case '%':
 596     case '^':
 597         /* Don't escape again if following character is
 598          * already something we escape.
 599          */
 600         if (strchr(".~!#&\'`()+@{},;[]%^=_", *(inspec+1))) {
 601             *outspec = *inspec;
 602             *output_cnt = 1;
 603             return 1;
 604             break;
 605         }
 606         /* But otherwise fall through and escape it. */
 607     case '=':
 608         /* Assume that this is to be escaped */
 609         outspec[0] = '^';
 610         outspec[1] = *inspec;
 611         *output_cnt = 2;
 612         return 1;
 613         break;
 614     case ' ': /* space */
 615         /* Assume that this is to be escaped */
 616         outspec[0] = '^';
 617         outspec[1] = '_';
 618         *output_cnt = 2;
 619         return 1;
 620         break;
 621     default:
 622         *outspec = *inspec;
 623         *output_cnt = 1;
 624         return 1;
 625         break;
 626     }
 627 }
 628
 629
 630 /* This handles the expansion of a '^' prefix to the proper character
 631  * in a UNIX file specification.
 632  *
 633  * The output count variable contains the number of characters added
 634  * to the output string.
 635  *
 636  * The return value is the number of characters read from the input
 637  * string
 638  */
 639 static int copy_expand_vms_filename_escape
 640   (char *outspec, const char *inspec, int *output_cnt)
 641 {
 642 int count;
 643 int scnt;
 644
 645     count = 0;
 646     *output_cnt = 0;
 647     if (*inspec == '^') {
 648         inspec++;
 649         switch (*inspec) {
 650         /* Spaces and non-trailing dots should just be passed through,
 651          * but eat the escape character.
 652          */
 653         case '.':
 654             *outspec = *inspec;
 655             count += 2;
 656             (*output_cnt)++;
 657             break;
 658         case '_': /* space */
 659             *outspec = ' ';
 660             count += 2;
 661             (*output_cnt)++;
 662             break;
 663         case '^':
 664             /* Hmm.  Better leave the escape escaped. */
 665             outspec[0] = '^';
 666             outspec[1] = '^';
 667             count += 2;
 668             (*output_cnt) += 2;
 669             break;
 670         case 'U': /* Unicode - FIX-ME this is wrong. */
 671             inspec++;
 672             count++;
 673             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 674             if (scnt == 4) {
 675                 unsigned int c1, c2;
 676                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 677                 outspec[0] == c1 & 0xff;
 678                 outspec[1] == c2 & 0xff;
 679                 if (scnt > 1) {
 680                     (*output_cnt) += 2;
 681                     count += 4;
 682                 }
 683             }
 684             else {
 685                 /* Error - do best we can to continue */
 686                 *outspec = 'U';
 687                 outspec++;
 688                 (*output_cnt++);
 689                 *outspec = *inspec;
 690                 count++;
 691                 (*output_cnt++);
 692             }
 693             break;
 694         default:
 695             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 696             if (scnt == 2) {
 697                 /* Hex encoded */
 698                 unsigned int c1;
 699                 scnt = sscanf(inspec, "%2x", &c1);
 700                 outspec[0] = c1 & 0xff;
 701                 if (scnt > 0) {
 702                     (*output_cnt++);
 703                     count += 2;
 704                 }
 705             }
 706             else {
 707                 *outspec = *inspec;
 708                 count++;
 709                 (*output_cnt++);
 710             }
 711         }
 712     }
 713     else {
 714         *outspec = *inspec;
 715         count++;
 716         (*output_cnt)++;
 717     }
 718     return count;
 719 }
 720
 721 #ifdef sys$filescan
 722 #undef sys$filescan
 723 int sys$filescan
 724    (const struct dsc$descriptor_s * srcstr,
 725     struct filescan_itmlst_2 * valuelist,
 726     unsigned long * fldflags,
 727     struct dsc$descriptor_s *auxout,
 728     unsigned short * retlen);
 729 #endif
 730
 731 /* vms_split_path - Verify that the input file specification is a
 732  * VMS format file specification, and provide pointers to the components of
 733  * it.  With EFS format filenames, this is virtually the only way to
 734  * parse a VMS path specification into components.
 735  *
 736  * If the sum of the components do not add up to the length of the
 737  * string, then the passed file specification is probably a UNIX style
 738  * path.
 739  */
 740 static int vms_split_path
 741    (const char * path,
 742     char * * volume,
 743     int * vol_len,
 744     char * * root,
 745     int * root_len,
 746     char * * dir,
 747     int * dir_len,
 748     char * * name,
 749     int * name_len,
 750     char * * ext,
 751     int * ext_len,
 752     char * * version,
 753     int * ver_len)
 754 {
 755 struct dsc$descriptor path_desc;
 756 int status;
 757 unsigned long flags;
 758 int ret_stat;
 759 struct filescan_itmlst_2 item_list[9];
 760 const int filespec = 0;
 761 const int nodespec = 1;
 762 const int devspec = 2;
 763 const int rootspec = 3;
 764 const int dirspec = 4;
 765 const int namespec = 5;
 766 const int typespec = 6;
 767 const int verspec = 7;
 768
 769     /* Assume the worst for an easy exit */
 770     ret_stat = -1;
 771     *volume = NULL;
 772     *vol_len = 0;
 773     *root = NULL;
 774     *root_len = 0;
 775     *dir = NULL;
 776     *dir_len;
 777     *name = NULL;
 778     *name_len = 0;
 779     *ext = NULL;
 780     *ext_len = 0;
 781     *version = NULL;
 782     *ver_len = 0;
 783
 784     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 785     path_desc.dsc$w_length = strlen(path);
 786     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 787     path_desc.dsc$b_class = DSC$K_CLASS_S;
 788
 789     /* Get the total length, if it is shorter than the string passed
 790      * then this was probably not a VMS formatted file specification
 791      */
 792     item_list[filespec].itmcode = FSCN$_FILESPEC;
 793     item_list[filespec].length = 0;
 794     item_list[filespec].component = NULL;
 795
 796     /* If the node is present, then it gets considered as part of the
 797      * volume name to hopefully make things simple.
 798      */
 799     item_list[nodespec].itmcode = FSCN$_NODE;
 800     item_list[nodespec].length = 0;
 801     item_list[nodespec].component = NULL;
 802
 803     item_list[devspec].itmcode = FSCN$_DEVICE;
 804     item_list[devspec].length = 0;
 805     item_list[devspec].component = NULL;
 806
 807     /* root is a special case,  adding it to either the directory or
 808      * the device components will probalby complicate things for the
 809      * callers of this routine, so leave it separate.
 810      */
 811     item_list[rootspec].itmcode = FSCN$_ROOT;
 812     item_list[rootspec].length = 0;
 813     item_list[rootspec].component = NULL;
 814
 815     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 816     item_list[dirspec].length = 0;
 817     item_list[dirspec].component = NULL;
 818
 819     item_list[namespec].itmcode = FSCN$_NAME;
 820     item_list[namespec].length = 0;
 821     item_list[namespec].component = NULL;
 822
 823     item_list[typespec].itmcode = FSCN$_TYPE;
 824     item_list[typespec].length = 0;
 825     item_list[typespec].component = NULL;
 826
 827     item_list[verspec].itmcode = FSCN$_VERSION;
 828     item_list[verspec].length = 0;
 829     item_list[verspec].component = NULL;
 830
 831     item_list[8].itmcode = 0;
 832     item_list[8].length = 0;
 833     item_list[8].component = NULL;
 834
 835     status = sys$filescan
 836        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 837         &flags, NULL, NULL);
 838     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 839
 840     /* If we parsed it successfully these two lengths should be the same */
 841     if (path_desc.dsc$w_length != item_list[filespec].length)
 842         return ret_stat;
 843
 844     /* If we got here, then it is a VMS file specification */
 845     ret_stat = 0;
 846
 847     /* set the volume name */
 848     if (item_list[nodespec].length > 0) {
 849         *volume = item_list[nodespec].component;
 850         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 851     }
 852     else {
 853         *volume = item_list[devspec].component;
 854         *vol_len = item_list[devspec].length;
 855     }
 856
 857     *root = item_list[rootspec].component;
 858     *root_len = item_list[rootspec].length;
 859
 860     *dir = item_list[dirspec].component;
 861     *dir_len = item_list[dirspec].length;
 862
 863     /* Now fun with versions and EFS file specifications
 864      * The parser can not tell the difference when a "." is a version
 865      * delimiter or a part of the file specification.
 866      */
 867     if ((decc_efs_charset) &&
 868         (item_list[verspec].length > 0) &&
 869         (item_list[verspec].component[0] == '.')) {
 870         *name = item_list[namespec].component;
 871         *name_len = item_list[namespec].length + item_list[typespec].length;
 872         *ext = item_list[verspec].component;
 873         *ext_len = item_list[verspec].length;
 874         *version = NULL;
 875         *ver_len = 0;
 876     }
 877     else {
 878         *name = item_list[namespec].component;
 879         *name_len = item_list[namespec].length;
 880         *ext = item_list[typespec].component;
 881         *ext_len = item_list[typespec].length;
 882         *version = item_list[verspec].component;
 883         *ver_len = item_list[verspec].length;
 884     }
 885     return ret_stat;
 886 }
 887
 888
 889 /* my_maxidx
 890  * Routine to retrieve the maximum equivalence index for an input
 891  * logical name.  Some calls to this routine have no knowledge if
 892  * the variable is a logical or not.  So on error we return a max
 893  * index of zero.
 894  */
 895 /*{{{int my_maxidx(const char *lnm) */
 896 static int
 897 my_maxidx(const char *lnm)
 898 {
 899     int status;
 900     int midx;
 901     int attr = LNM$M_CASE_BLIND;
 902     struct dsc$descriptor lnmdsc;
 903     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 904                                 {0, 0, 0, 0}};
 905
 906     lnmdsc.dsc$w_length = strlen(lnm);
 907     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 908     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 909     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 910
 911     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 912     if ((status & 1) == 0)
 913        midx = 0;
 914
 915     return (midx);
 916 }
 917 /*}}}*/
 918
 919 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 920 int
 921 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 922   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 923 {
 924     const char *cp1;
 925     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 926     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 927     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 928     int midx;
 929     unsigned char acmode;
 930     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 931                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 932     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 933                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 934                                  {0, 0, 0, 0}};
 935     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 936 #if defined(PERL_IMPLICIT_CONTEXT)
 937     pTHX = NULL;
 938     if (PL_curinterp) {
 939       aTHX = PERL_GET_INTERP;
 940     } else {
 941       aTHX = NULL;
 942     }
 943 #endif
 944
 945     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 946       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 947     }
 948     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 949       *cp2 = _toupper(*cp1);
 950       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 951         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 952         return 0;
 953       }
 954     }
 955     lnmdsc.dsc$w_length = cp1 - lnm;
 956     lnmdsc.dsc$a_pointer = uplnm;
 957     uplnm[lnmdsc.dsc$w_length] = '\0';
 958     secure = flags & PERL__TRNENV_SECURE;
 959     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 960     if (!tabvec || !*tabvec) tabvec = env_tables;
 961
 962     for (curtab = 0; tabvec[curtab]; curtab++) {
 963       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 964         if (!ivenv && !secure) {
 965           char *eq, *end;
 966           int i;
 967           if (!environ) {
 968             ivenv = 1;
 969             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 970             continue;
 971           }
 972           retsts = SS$_NOLOGNAM;
 973           for (i = 0; environ[i]; i++) {
 974             if ((eq = strchr(environ[i],'=')) &&
 975                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 976                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 977               eq++;
 978               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 979               if (!eqvlen) continue;
 980               retsts = SS$_NORMAL;
 981               break;
 982             }
 983           }
 984           if (retsts != SS$_NOLOGNAM) break;
 985         }
 986       }
 987       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 988                !str$case_blind_compare(&tmpdsc,&clisym)) {
 989         if (!ivsym && !secure) {
 990           unsigned short int deflen = LNM$C_NAMLENGTH;
 991           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 992           /* dynamic dsc to accomodate possible long value */
 993           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 994           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 995           if (retsts & 1) {
 996             if (eqvlen > MAX_DCL_SYMBOL) {
 997               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 998               eqvlen = MAX_DCL_SYMBOL;
 999               /* Special hack--we might be called before the interpreter's */
1000               /* fully initialized, in which case either thr or PL_curcop */
1001               /* might be bogus. We have to check, since ckWARN needs them */
1002               /* both to be valid if running threaded */
1003                 if (ckWARN(WARN_MISC)) {
1004                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
1005                 }
1006             }
1007             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
1008           }
1009           _ckvmssts(lib$sfree1_dd(&eqvdsc));
1010           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1011           if (retsts == LIB$_NOSUCHSYM) continue;
1012           break;
1013         }
1014       }
1015       else if (!ivlnm) {
1016         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
1017           midx = my_maxidx(lnm);
1018           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1019             lnmlst[1].bufadr = cp2;
1020             eqvlen = 0;
1021             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1022             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1023             if (retsts == SS$_NOLOGNAM) break;
1024             /* PPFs have a prefix */
1025             if (
1026 #if INTSIZE == 4
1027                  *((int *)uplnm) == *((int *)"SYS$")                    &&
1028 #endif
1029                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
1030                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
1031                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
1032                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
1033                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
1034               memmove(eqv,eqv+4,eqvlen-4);
1035               eqvlen -= 4;
1036             }
1037             cp2 += eqvlen;
1038             *cp2 = '\0';
1039           }
1040           if ((retsts == SS$_IVLOGNAM) ||
1041               (retsts == SS$_NOLOGNAM)) { continue; }
1042         }
1043         else {
1044           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1045           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1046           if (retsts == SS$_NOLOGNAM) continue;
1047           eqv[eqvlen] = '\0';
1048         }
1049         eqvlen = strlen(eqv);
1050         break;
1051       }
1052     }
1053     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1054     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1055              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
1056              retsts == SS$_NOLOGNAM) {
1057       set_errno(EINVAL);  set_vaxc_errno(retsts);
1058     }
1059     else _ckvmssts(retsts);
1060     return 0;
1061 }  /* end of vmstrnenv */
1062 /*}}}*/
1063
1064 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1065 /* Define as a function so we can access statics. */
1066 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1067 {
1068   return vmstrnenv(lnm,eqv,idx,fildev,
1069 #ifdef SECURE_INTERNAL_GETENV
1070                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
1071 #else
1072                    0
1073 #endif
1074                                                                               );
1075 }
1076 /*}}}*/
1077
1078 /* my_getenv
1079  * Note: Uses Perl temp to store result so char * can be returned to
1080  * caller; this pointer will be invalidated at next Perl statement
1081  * transition.
1082  * We define this as a function rather than a macro in terms of my_getenv_len()
1083  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1084  * allocate SVs).
1085  */
1086 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1087 char *
1088 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1089 {
1090     const char *cp1;
1091     static char *__my_getenv_eqv = NULL;
1092     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1093     unsigned long int idx = 0;
1094     int trnsuccess, success, secure, saverr, savvmserr;
1095     int midx, flags;
1096     SV *tmpsv;
1097
1098     midx = my_maxidx(lnm) + 1;
1099
1100     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1101       /* Set up a temporary buffer for the return value; Perl will
1102        * clean it up at the next statement transition */
1103       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1104       if (!tmpsv) return NULL;
1105       eqv = SvPVX(tmpsv);
1106     }
1107     else {
1108       /* Assume no interpreter ==> single thread */
1109       if (__my_getenv_eqv != NULL) {
1110         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1111       }
1112       else {
1113         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1114       }
1115       eqv = __my_getenv_eqv;
1116     }
1117
1118     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1119     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1120       int len;
1121       getcwd(eqv,LNM$C_NAMLENGTH);
1122
1123       len = strlen(eqv);
1124
1125       /* Get rid of "000000/ in rooted filespecs */
1126       if (len > 7) {
1127         char * zeros;
1128         zeros = strstr(eqv, "/000000/");
1129         if (zeros != NULL) {
1130           int mlen;
1131           mlen = len - (zeros - eqv) - 7;
1132           memmove(zeros, &zeros[7], mlen);
1133           len = len - 7;
1134           eqv[len] = '\0';
1135         }
1136       }
1137       return eqv;
1138     }
1139     else {
1140       /* Impose security constraints only if tainting */
1141       if (sys) {
1142         /* Impose security constraints only if tainting */
1143         secure = PL_curinterp ? PL_tainting : will_taint;
1144         saverr = errno;  savvmserr = vaxc$errno;
1145       }
1146       else {
1147         secure = 0;
1148       }
1149
1150       flags =
1151 #ifdef SECURE_INTERNAL_GETENV
1152               secure ? PERL__TRNENV_SECURE : 0
1153 #else
1154               0
1155 #endif
1156       ;
1157
1158       /* For the getenv interface we combine all the equivalence names
1159        * of a search list logical into one value to acquire a maximum
1160        * value length of 255*128 (assuming %ENV is using logicals).
1161        */
1162       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1163
1164       /* If the name contains a semicolon-delimited index, parse it
1165        * off and make sure we only retrieve the equivalence name for
1166        * that index.  */
1167       if ((cp2 = strchr(lnm,';')) != NULL) {
1168         strcpy(uplnm,lnm);
1169         uplnm[cp2-lnm] = '\0';
1170         idx = strtoul(cp2+1,NULL,0);
1171         lnm = uplnm;
1172         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1173       }
1174
1175       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1176
1177       /* Discard NOLOGNAM on internal calls since we're often looking
1178        * for an optional name, and this "error" often shows up as the
1179        * (bogus) exit status for a die() call later on.  */
1180       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1181       return success ? eqv : Nullch;
1182     }
1183
1184 }  /* end of my_getenv() */
1185 /*}}}*/
1186
1187
1188 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1189 char *
1190 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1191 {
1192     const char *cp1;
1193     char *buf, *cp2;
1194     unsigned long idx = 0;
1195     int midx, flags;
1196     static char *__my_getenv_len_eqv = NULL;
1197     int secure, saverr, savvmserr;
1198     SV *tmpsv;
1199
1200     midx = my_maxidx(lnm) + 1;
1201
1202     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1203       /* Set up a temporary buffer for the return value; Perl will
1204        * clean it up at the next statement transition */
1205       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1206       if (!tmpsv) return NULL;
1207       buf = SvPVX(tmpsv);
1208     }
1209     else {
1210       /* Assume no interpreter ==> single thread */
1211       if (__my_getenv_len_eqv != NULL) {
1212         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1213       }
1214       else {
1215         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1216       }
1217       buf = __my_getenv_len_eqv;
1218     }
1219
1220     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1221     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1222     char * zeros;
1223
1224       getcwd(buf,LNM$C_NAMLENGTH);
1225       *len = strlen(buf);
1226
1227       /* Get rid of "000000/ in rooted filespecs */
1228       if (*len > 7) {
1229       zeros = strstr(buf, "/000000/");
1230       if (zeros != NULL) {
1231         int mlen;
1232         mlen = *len - (zeros - buf) - 7;
1233         memmove(zeros, &zeros[7], mlen);
1234         *len = *len - 7;
1235         buf[*len] = '\0';
1236         }
1237       }
1238       return buf;
1239     }
1240     else {
1241       if (sys) {
1242         /* Impose security constraints only if tainting */
1243         secure = PL_curinterp ? PL_tainting : will_taint;
1244         saverr = errno;  savvmserr = vaxc$errno;
1245       }
1246       else {
1247         secure = 0;
1248       }
1249
1250       flags =
1251 #ifdef SECURE_INTERNAL_GETENV
1252               secure ? PERL__TRNENV_SECURE : 0
1253 #else
1254               0
1255 #endif
1256       ;
1257
1258       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1259
1260       if ((cp2 = strchr(lnm,';')) != NULL) {
1261         strcpy(buf,lnm);
1262         buf[cp2-lnm] = '\0';
1263         idx = strtoul(cp2+1,NULL,0);
1264         lnm = buf;
1265         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1266       }
1267
1268       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1269
1270       /* Get rid of "000000/ in rooted filespecs */
1271       if (*len > 7) {
1272       char * zeros;
1273         zeros = strstr(buf, "/000000/");
1274         if (zeros != NULL) {
1275           int mlen;
1276           mlen = *len - (zeros - buf) - 7;
1277           memmove(zeros, &zeros[7], mlen);
1278           *len = *len - 7;
1279           buf[*len] = '\0';
1280         }
1281       }
1282
1283       /* Discard NOLOGNAM on internal calls since we're often looking
1284        * for an optional name, and this "error" often shows up as the
1285        * (bogus) exit status for a die() call later on.  */
1286       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1287       return *len ? buf : Nullch;
1288     }
1289
1290 }  /* end of my_getenv_len() */
1291 /*}}}*/
1292
1293 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
1294
1295 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1296
1297 /*{{{ void prime_env_iter() */
1298 void
1299 prime_env_iter(void)
1300 /* Fill the %ENV associative array with all logical names we can
1301  * find, in preparation for iterating over it.
1302  */
1303 {
1304   static int primed = 0;
1305   HV *seenhv = NULL, *envhv;
1306   SV *sv = NULL;
1307   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
1308   unsigned short int chan;
1309 #ifndef CLI$M_TRUSTED
1310 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1311 #endif
1312   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1313   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1314   long int i;
1315   bool have_sym = FALSE, have_lnm = FALSE;
1316   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1317   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1318   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1319   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1320   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1321 #if defined(PERL_IMPLICIT_CONTEXT)
1322   pTHX;
1323 #endif
1324 #if defined(USE_ITHREADS)
1325   static perl_mutex primenv_mutex;
1326   MUTEX_INIT(&primenv_mutex);
1327 #endif
1328
1329 #if defined(PERL_IMPLICIT_CONTEXT)
1330     /* We jump through these hoops because we can be called at */
1331     /* platform-specific initialization time, which is before anything is */
1332     /* set up--we can't even do a plain dTHX since that relies on the */
1333     /* interpreter structure to be initialized */
1334     if (PL_curinterp) {
1335       aTHX = PERL_GET_INTERP;
1336     } else {
1337       aTHX = NULL;
1338     }
1339 #endif
1340
1341   if (primed || !PL_envgv) return;
1342   MUTEX_LOCK(&primenv_mutex);
1343   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1344   envhv = GvHVn(PL_envgv);
1345   /* Perform a dummy fetch as an lval to insure that the hash table is
1346    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1347   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1348
1349   for (i = 0; env_tables[i]; i++) {
1350      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1351          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1352      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1353   }
1354   if (have_sym || have_lnm) {
1355     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1356     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1357     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1358     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1359   }
1360
1361   for (i--; i >= 0; i--) {
1362     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1363       char *start;
1364       int j;
1365       for (j = 0; environ[j]; j++) {
1366         if (!(start = strchr(environ[j],'='))) {
1367           if (ckWARN(WARN_INTERNAL))
1368             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1369         }
1370         else {
1371           start++;
1372           sv = newSVpv(start,0);
1373           SvTAINTED_on(sv);
1374           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1375         }
1376       }
1377       continue;
1378     }
1379     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1380              !str$case_blind_compare(&tmpdsc,&clisym)) {
1381       strcpy(cmd,"Show Symbol/Global *");
1382       cmddsc.dsc$w_length = 20;
1383       if (env_tables[i]->dsc$w_length == 12 &&
1384           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1385           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1386       flags = defflags | CLI$M_NOLOGNAM;
1387     }
1388     else {
1389       strcpy(cmd,"Show Logical *");
1390       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1391         strcat(cmd," /Table=");
1392         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1393         cmddsc.dsc$w_length = strlen(cmd);
1394       }
1395       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1396       flags = defflags | CLI$M_NOCLISYM;
1397     }
1398
1399     /* Create a new subprocess to execute each command, to exclude the
1400      * remote possibility that someone could subvert a mbx or file used
1401      * to write multiple commands to a single subprocess.
1402      */
1403     do {
1404       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1405                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1406       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1407       defflags &= ~CLI$M_TRUSTED;
1408     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1409     _ckvmssts(retsts);
1410     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1411     if (seenhv) SvREFCNT_dec(seenhv);
1412     seenhv = newHV();
1413     while (1) {
1414       char *cp1, *cp2, *key;
1415       unsigned long int sts, iosb[2], retlen, keylen;
1416       register U32 hash;
1417
1418       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1419       if (sts & 1) sts = iosb[0] & 0xffff;
1420       if (sts == SS$_ENDOFFILE) {
1421         int wakect = 0;
1422         while (substs == 0) { sys$hiber(); wakect++;}
1423         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1424         _ckvmssts(substs);
1425         break;
1426       }
1427       _ckvmssts(sts);
1428       retlen = iosb[0] >> 16;
1429       if (!retlen) continue;  /* blank line */
1430       buf[retlen] = '\0';
1431       if (iosb[1] != subpid) {
1432         if (iosb[1]) {
1433           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1434         }
1435         continue;
1436       }
1437       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1438         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1439
1440       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1441       if (*cp1 == '(' || /* Logical name table name */
1442           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1443       if (*cp1 == '"') cp1++;
1444       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1445       key = cp1;  keylen = cp2 - cp1;
1446       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1447       while (*cp2 && *cp2 != '=') cp2++;
1448       while (*cp2 && *cp2 == '=') cp2++;
1449       while (*cp2 && *cp2 == ' ') cp2++;
1450       if (*cp2 == '"') {  /* String translation; may embed "" */
1451         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1452         cp2++;  cp1--; /* Skip "" surrounding translation */
1453       }
1454       else {  /* Numeric translation */
1455         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1456         cp1--;  /* stop on last non-space char */
1457       }
1458       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1459         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1460         continue;
1461       }
1462       PERL_HASH(hash,key,keylen);
1463
1464       if (cp1 == cp2 && *cp2 == '.') {
1465         /* A single dot usually means an unprintable character, such as a null
1466          * to indicate a zero-length value.  Get the actual value to make sure.
1467          */
1468         char lnm[LNM$C_NAMLENGTH+1];
1469         char eqv[MAX_DCL_SYMBOL+1];
1470         int trnlen;
1471         strncpy(lnm, key, keylen);
1472         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1473         sv = newSVpvn(eqv, strlen(eqv));
1474       }
1475       else {
1476         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1477       }
1478
1479       SvTAINTED_on(sv);
1480       hv_store(envhv,key,keylen,sv,hash);
1481       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1482     }
1483     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1484       /* get the PPFs for this process, not the subprocess */
1485       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1486       char eqv[LNM$C_NAMLENGTH+1];
1487       int trnlen, i;
1488       for (i = 0; ppfs[i]; i++) {
1489         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1490         sv = newSVpv(eqv,trnlen);
1491         SvTAINTED_on(sv);
1492         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1493       }
1494     }
1495   }
1496   primed = 1;
1497   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1498   if (buf) Safefree(buf);
1499   if (seenhv) SvREFCNT_dec(seenhv);
1500   MUTEX_UNLOCK(&primenv_mutex);
1501   return;
1502
1503 }  /* end of prime_env_iter */
1504 /*}}}*/
1505
1506
1507 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1508 /* Define or delete an element in the same "environment" as
1509  * vmstrnenv().  If an element is to be deleted, it's removed from
1510  * the first place it's found.  If it's to be set, it's set in the
1511  * place designated by the first element of the table vector.
1512  * Like setenv() returns 0 for success, non-zero on error.
1513  */
1514 int
1515 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1516 {
1517     const char *cp1;
1518     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1519     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1520     int nseg = 0, j;
1521     unsigned long int retsts, usermode = PSL$C_USER;
1522     struct itmlst_3 *ile, *ilist;
1523     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1524                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1525                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1526     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1527     $DESCRIPTOR(local,"_LOCAL");
1528
1529     if (!lnm) {
1530         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1531         return SS$_IVLOGNAM;
1532     }
1533
1534     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1535       *cp2 = _toupper(*cp1);
1536       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1537         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1538         return SS$_IVLOGNAM;
1539       }
1540     }
1541     lnmdsc.dsc$w_length = cp1 - lnm;
1542     if (!tabvec || !*tabvec) tabvec = env_tables;
1543
1544     if (!eqv) {  /* we're deleting n element */
1545       for (curtab = 0; tabvec[curtab]; curtab++) {
1546         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1547         int i;
1548           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1549             if ((cp1 = strchr(environ[i],'=')) &&
1550                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1551                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1552 #ifdef HAS_SETENV
1553               return setenv(lnm,"",1) ? vaxc$errno : 0;
1554             }
1555           }
1556           ivenv = 1; retsts = SS$_NOLOGNAM;
1557 #else
1558               if (ckWARN(WARN_INTERNAL))
1559                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1560               ivenv = 1; retsts = SS$_NOSUCHPGM;
1561               break;
1562             }
1563           }
1564 #endif
1565         }
1566         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1567                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1568           unsigned int symtype;
1569           if (tabvec[curtab]->dsc$w_length == 12 &&
1570               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1571               !str$case_blind_compare(&tmpdsc,&local))
1572             symtype = LIB$K_CLI_LOCAL_SYM;
1573           else symtype = LIB$K_CLI_GLOBAL_SYM;
1574           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1575           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1576           if (retsts == LIB$_NOSUCHSYM) continue;
1577           break;
1578         }
1579         else if (!ivlnm) {
1580           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1581           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1582           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1583           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1584           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1585         }
1586       }
1587     }
1588     else {  /* we're defining a value */
1589       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1590 #ifdef HAS_SETENV
1591         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1592 #else
1593         if (ckWARN(WARN_INTERNAL))
1594           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1595         retsts = SS$_NOSUCHPGM;
1596 #endif
1597       }
1598       else {
1599         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1600         eqvdsc.dsc$w_length  = strlen(eqv);
1601         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1602             !str$case_blind_compare(&tmpdsc,&clisym)) {
1603           unsigned int symtype;
1604           if (tabvec[0]->dsc$w_length == 12 &&
1605               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1606                !str$case_blind_compare(&tmpdsc,&local))
1607             symtype = LIB$K_CLI_LOCAL_SYM;
1608           else symtype = LIB$K_CLI_GLOBAL_SYM;
1609           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1610         }
1611         else {
1612           if (!*eqv) eqvdsc.dsc$w_length = 1;
1613           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1614
1615             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1616             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1617               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1618                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1619               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1620               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1621             }
1622
1623             Newx(ilist,nseg+1,struct itmlst_3);
1624             ile = ilist;
1625             if (!ile) {
1626               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1627               return SS$_INSFMEM;
1628             }
1629             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1630
1631             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1632               ile->itmcode = LNM$_STRING;
1633               ile->bufadr = c;
1634               if ((j+1) == nseg) {
1635                 ile->buflen = strlen(c);
1636                 /* in case we are truncating one that's too long */
1637                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1638               }
1639               else {
1640                 ile->buflen = LNM$C_NAMLENGTH;
1641               }
1642             }
1643
1644             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1645             Safefree (ilist);
1646           }
1647           else {
1648             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1649           }
1650         }
1651       }
1652     }
1653     if (!(retsts & 1)) {
1654       switch (retsts) {
1655         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1656         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1657           set_errno(EVMSERR); break;
1658         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1659         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1660           set_errno(EINVAL); break;
1661         case SS$_NOPRIV:
1662           set_errno(EACCES); break;
1663         default:
1664           _ckvmssts(retsts);
1665           set_errno(EVMSERR);
1666        }
1667        set_vaxc_errno(retsts);
1668        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1669     }
1670     else {
1671       /* We reset error values on success because Perl does an hv_fetch()
1672        * before each hv_store(), and if the thing we're setting didn't
1673        * previously exist, we've got a leftover error message.  (Of course,
1674        * this fails in the face of
1675        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1676        * in that the error reported in $! isn't spurious,
1677        * but it's right more often than not.)
1678        */
1679       set_errno(0); set_vaxc_errno(retsts);
1680       return 0;
1681     }
1682
1683 }  /* end of vmssetenv() */
1684 /*}}}*/
1685
1686 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1687 /* This has to be a function since there's a prototype for it in proto.h */
1688 void
1689 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1690 {
1691     if (lnm && *lnm) {
1692       int len = strlen(lnm);
1693       if  (len == 7) {
1694         char uplnm[8];
1695         int i;
1696         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1697         if (!strcmp(uplnm,"DEFAULT")) {
1698           if (eqv && *eqv) my_chdir(eqv);
1699           return;
1700         }
1701     }
1702 #ifndef RTL_USES_UTC
1703     if (len == 6 || len == 2) {
1704       char uplnm[7];
1705       int i;
1706       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1707       uplnm[len] = '\0';
1708       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1709       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1710     }
1711 #endif
1712   }
1713   (void) vmssetenv(lnm,eqv,NULL);
1714 }
1715 /*}}}*/
1716
1717 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1718 /*  vmssetuserlnm
1719  *  sets a user-mode logical in the process logical name table
1720  *  used for redirection of sys$error
1721  */
1722 void
1723 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1724 {
1725     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1726     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1727     unsigned long int iss, attr = LNM$M_CONFINE;
1728     unsigned char acmode = PSL$C_USER;
1729     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1730                                  {0, 0, 0, 0}};
1731     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1732     d_name.dsc$w_length = strlen(name);
1733
1734     lnmlst[0].buflen = strlen(eqv);
1735     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1736
1737     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1738     if (!(iss&1)) lib$signal(iss);
1739 }
1740 /*}}}*/
1741
1742
1743 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1744 /* my_crypt - VMS password hashing
1745  * my_crypt() provides an interface compatible with the Unix crypt()
1746  * C library function, and uses sys$hash_password() to perform VMS
1747  * password hashing.  The quadword hashed password value is returned
1748  * as a NUL-terminated 8 character string.  my_crypt() does not change
1749  * the case of its string arguments; in order to match the behavior
1750  * of LOGINOUT et al., alphabetic characters in both arguments must
1751  *  be upcased by the caller.
1752  *
1753  * - fix me to call ACM services when available
1754  */
1755 char *
1756 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1757 {
1758 #   ifndef UAI$C_PREFERRED_ALGORITHM
1759 #     define UAI$C_PREFERRED_ALGORITHM 127
1760 #   endif
1761     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1762     unsigned short int salt = 0;
1763     unsigned long int sts;
1764     struct const_dsc {
1765         unsigned short int dsc$w_length;
1766         unsigned char      dsc$b_type;
1767         unsigned char      dsc$b_class;
1768         const char *       dsc$a_pointer;
1769     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1770        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1771     struct itmlst_3 uailst[3] = {
1772         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1773         { sizeof salt, UAI$_SALT,    &salt, 0},
1774         { 0,           0,            NULL,  NULL}};
1775     static char hash[9];
1776
1777     usrdsc.dsc$w_length = strlen(usrname);
1778     usrdsc.dsc$a_pointer = usrname;
1779     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1780       switch (sts) {
1781         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1782           set_errno(EACCES);
1783           break;
1784         case RMS$_RNF:
1785           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1786           break;
1787         default:
1788           set_errno(EVMSERR);
1789       }
1790       set_vaxc_errno(sts);
1791       if (sts != RMS$_RNF) return NULL;
1792     }
1793
1794     txtdsc.dsc$w_length = strlen(textpasswd);
1795     txtdsc.dsc$a_pointer = textpasswd;
1796     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1797       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1798     }
1799
1800     return (char *) hash;
1801
1802 }  /* end of my_crypt() */
1803 /*}}}*/
1804
1805
1806 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1807 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1808 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1809
1810 /* fixup barenames that are directories for internal use.
1811  * There have been problems with the consistent handling of UNIX
1812  * style directory names when routines are presented with a name that
1813  * has no directory delimitors at all.  So this routine will eventually
1814  * fix the issue.
1815  */
1816 static char * fixup_bare_dirnames(const char * name)
1817 {
1818   if (decc_disable_to_vms_logname_translation) {
1819 /* fix me */
1820   }
1821   return NULL;
1822 }
1823
1824 /* 8.3, remove() is now broken on symbolic links */
1825 static int rms_erase(const char * vmsname);
1826
1827
1828 /* mp_do_kill_file
1829  * A little hack to get around a bug in some implemenation of remove()
1830  * that do not know how to delete a directory
1831  *
1832  * Delete any file to which user has control access, regardless of whether
1833  * delete access is explicitly allowed.
1834  * Limitations: User must have write access to parent directory.
1835  *              Does not block signals or ASTs; if interrupted in midstream
1836  *              may leave file with an altered ACL.
1837  * HANDLE WITH CARE!
1838  */
1839 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1840 static int
1841 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1842 {
1843     char *vmsname;
1844     char *rslt;
1845     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1846     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1847     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1848     struct myacedef {
1849       unsigned char myace$b_length;
1850       unsigned char myace$b_type;
1851       unsigned short int myace$w_flags;
1852       unsigned long int myace$l_access;
1853       unsigned long int myace$l_ident;
1854     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1855                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1856       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1857      struct itmlst_3
1858        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1859                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1860        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1861        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1862        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1863        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1864
1865     /* Expand the input spec using RMS, since the CRTL remove() and
1866      * system services won't do this by themselves, so we may miss
1867      * a file "hiding" behind a logical name or search list. */
1868     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1869     if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1870
1871     rslt = do_rmsexpand(name,
1872                         vmsname,
1873                         0,
1874                         NULL,
1875                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
1876                         NULL,
1877                         NULL);
1878     if (rslt == NULL) {
1879         PerlMem_free(vmsname);
1880         return -1;
1881       }
1882
1883     /* Erase the file */
1884     rmsts = rms_erase(vmsname);
1885
1886     /* Did it succeed */
1887     if ($VMS_STATUS_SUCCESS(rmsts)) {
1888         PerlMem_free(vmsname);
1889         return 0;
1890       }
1891
1892     /* If not, can changing protections help? */
1893     if (rmsts != RMS$_PRV) {
1894       set_vaxc_errno(rmsts);
1895       PerlMem_free(vmsname);
1896       return -1;
1897     }
1898
1899     /* No, so we get our own UIC to use as a rights identifier,
1900      * and the insert an ACE at the head of the ACL which allows us
1901      * to delete the file.
1902      */
1903     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1904     fildsc.dsc$w_length = strlen(vmsname);
1905     fildsc.dsc$a_pointer = vmsname;
1906     cxt = 0;
1907     newace.myace$l_ident = oldace.myace$l_ident;
1908     rmsts = -1;
1909     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1910       switch (aclsts) {
1911         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1912           set_errno(ENOENT); break;
1913         case RMS$_DIR:
1914           set_errno(ENOTDIR); break;
1915         case RMS$_DEV:
1916           set_errno(ENODEV); break;
1917         case RMS$_SYN: case SS$_INVFILFOROP:
1918           set_errno(EINVAL); break;
1919         case RMS$_PRV:
1920           set_errno(EACCES); break;
1921         default:
1922           _ckvmssts(aclsts);
1923       }
1924       set_vaxc_errno(aclsts);
1925       PerlMem_free(vmsname);
1926       return -1;
1927     }
1928     /* Grab any existing ACEs with this identifier in case we fail */
1929     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1930     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1931                     || fndsts == SS$_NOMOREACE ) {
1932       /* Add the new ACE . . . */
1933       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1934         goto yourroom;
1935
1936       rmsts = rms_erase(vmsname);
1937       if ($VMS_STATUS_SUCCESS(rmsts)) {
1938         rmsts = 0;
1939         }
1940         else {
1941         rmsts = -1;
1942         /* We blew it - dir with files in it, no write priv for
1943          * parent directory, etc.  Put things back the way they were. */
1944         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1945           goto yourroom;
1946         if (fndsts & 1) {
1947           addlst[0].bufadr = &oldace;
1948           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1949             goto yourroom;
1950         }
1951       }
1952     }
1953
1954     yourroom:
1955     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1956     /* We just deleted it, so of course it's not there.  Some versions of
1957      * VMS seem to return success on the unlock operation anyhow (after all
1958      * the unlock is successful), but others don't.
1959      */
1960     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1961     if (aclsts & 1) aclsts = fndsts;
1962     if (!(aclsts & 1)) {
1963       set_errno(EVMSERR);
1964       set_vaxc_errno(aclsts);
1965     }
1966
1967     PerlMem_free(vmsname);
1968     return rmsts;
1969
1970 }  /* end of kill_file() */
1971 /*}}}*/
1972
1973
1974 /*{{{int do_rmdir(char *name)*/
1975 int
1976 Perl_do_rmdir(pTHX_ const char *name)
1977 {
1978     char * dirfile;
1979     int retval;
1980     Stat_t st;
1981
1982     dirfile = PerlMem_malloc(VMS_MAXRSS + 1);
1983     if (dirfile == NULL)
1984         _ckvmssts(SS$_INSFMEM);
1985
1986     /* Force to a directory specification */
1987     if (do_fileify_dirspec(name, dirfile, 0, NULL) == NULL) {
1988         PerlMem_free(dirfile);
1989         return -1;
1990     }
1991     if (Perl_flex_lstat(aTHX_ dirfile, &st) || !S_ISDIR(st.st_mode)) {
1992         errno = ENOTDIR;
1993         retval = -1;
1994     }
1995     else
1996         retval = mp_do_kill_file(aTHX_ dirfile, 1);
1997
1998     PerlMem_free(dirfile);
1999     return retval;
2000
2001 }  /* end of do_rmdir */
2002 /*}}}*/
2003
2004 /* kill_file
2005  * Delete any file to which user has control access, regardless of whether
2006  * delete access is explicitly allowed.
2007  * Limitations: User must have write access to parent directory.
2008  *              Does not block signals or ASTs; if interrupted in midstream
2009  *              may leave file with an altered ACL.
2010  * HANDLE WITH CARE!
2011  */
2012 /*{{{int kill_file(char *name)*/
2013 int
2014 Perl_kill_file(pTHX_ const char *name)
2015 {
2016     char rspec[NAM$C_MAXRSS+1];
2017     char *tspec;
2018     Stat_t st;
2019     int rmsts;
2020
2021    /* Remove() is allowed to delete directories, according to the X/Open
2022     * specifications.
2023     * This may need special handling to work with the ACL hacks.
2024      */
2025    if ((flex_lstat(name, &st) == 0) && S_ISDIR(st.st_mode)) {
2026         rmsts = Perl_do_rmdir(aTHX_ name);
2027         return rmsts;
2028     }
2029
2030    rmsts = mp_do_kill_file(aTHX_ name, 0);
2031
2032     return rmsts;
2033
2034 }  /* end of kill_file() */
2035 /*}}}*/
2036
2037
2038 /*{{{int my_mkdir(char *,Mode_t)*/
2039 int
2040 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2041 {
2042   STRLEN dirlen = strlen(dir);
2043
2044   /* zero length string sometimes gives ACCVIO */
2045   if (dirlen == 0) return -1;
2046
2047   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2048    * null file name/type.  However, it's commonplace under Unix,
2049    * so we'll allow it for a gain in portability.
2050    */
2051   if (dir[dirlen-1] == '/') {
2052     char *newdir = savepvn(dir,dirlen-1);
2053     int ret = mkdir(newdir,mode);
2054     Safefree(newdir);
2055     return ret;
2056   }
2057   else return mkdir(dir,mode);
2058 }  /* end of my_mkdir */
2059 /*}}}*/
2060
2061 /*{{{int my_chdir(char *)*/
2062 int
2063 Perl_my_chdir(pTHX_ const char *dir)
2064 {
2065   STRLEN dirlen = strlen(dir);
2066
2067   /* zero length string sometimes gives ACCVIO */
2068   if (dirlen == 0) return -1;
2069   const char *dir1;
2070
2071   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2072    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2073    * so that existing scripts do not need to be changed.
2074    */
2075   dir1 = dir;
2076   while ((dirlen > 0) && (*dir1 == ' ')) {
2077     dir1++;
2078     dirlen--;
2079   }
2080
2081   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2082    * that implies
2083    * null file name/type.  However, it's commonplace under Unix,
2084    * so we'll allow it for a gain in portability.
2085    *
2086    * - Preview- '/' will be valid soon on VMS
2087    */
2088   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2089     char *newdir = savepvn(dir1,dirlen-1);
2090     int ret = chdir(newdir);
2091     Safefree(newdir);
2092     return ret;
2093   }
2094   else return chdir(dir1);
2095 }  /* end of my_chdir */
2096 /*}}}*/
2097
2098
2099 /*{{{int my_chmod(char *, mode_t)*/
2100 int
2101 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2102 {
2103   STRLEN speclen = strlen(file_spec);
2104
2105   /* zero length string sometimes gives ACCVIO */
2106   if (speclen == 0) return -1;
2107
2108   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2109    * that implies null file name/type.  However, it's commonplace under Unix,
2110    * so we'll allow it for a gain in portability.
2111    *
2112    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2113    * in VMS file.dir notation.
2114    */
2115   if ((speclen > 1) && (file_spec[speclen-1] == '/')) {
2116     char *vms_src, *vms_dir, *rslt;
2117     int ret = -1;
2118     errno = EIO;
2119
2120     /* First convert this to a VMS format specification */
2121     vms_src = PerlMem_malloc(VMS_MAXRSS);
2122     if (vms_src == NULL)
2123         _ckvmssts(SS$_INSFMEM);
2124
2125     rslt = do_tovmsspec(file_spec, vms_src, 0, NULL);
2126     if (rslt == NULL) {
2127         /* If we fail, then not a file specification */
2128         PerlMem_free(vms_src);
2129         errno = EIO;
2130         return -1;
2131     }
2132
2133     /* Now make it a directory spec so chmod is happy */
2134     vms_dir = PerlMem_malloc(VMS_MAXRSS + 1);
2135     if (vms_dir == NULL)
2136         _ckvmssts(SS$_INSFMEM);
2137     rslt = do_fileify_dirspec(vms_src, vms_dir, 0, NULL);
2138     PerlMem_free(vms_src);
2139
2140     /* Now do it */
2141     if (rslt != NULL) {
2142         ret = chmod(vms_dir, mode);
2143     } else {
2144         errno = EIO;
2145     }
2146     PerlMem_free(vms_dir);
2147     return ret;
2148   }
2149   else return chmod(file_spec, mode);
2150 }  /* end of my_chmod */
2151 /*}}}*/
2152
2153
2154 /*{{{FILE *my_tmpfile()*/
2155 FILE *
2156 my_tmpfile(void)
2157 {
2158   FILE *fp;
2159   char *cp;
2160
2161   if ((fp = tmpfile())) return fp;
2162
2163   cp = PerlMem_malloc(L_tmpnam+24);
2164   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2165
2166   if (decc_filename_unix_only == 0)
2167     strcpy(cp,"Sys$Scratch:");
2168   else
2169     strcpy(cp,"/tmp/");
2170   tmpnam(cp+strlen(cp));
2171   strcat(cp,".Perltmp");
2172   fp = fopen(cp,"w+","fop=dlt");
2173   PerlMem_free(cp);
2174   return fp;
2175 }
2176 /*}}}*/
2177
2178
2179 #ifndef HOMEGROWN_POSIX_SIGNALS
2180 /*
2181  * The C RTL's sigaction fails to check for invalid signal numbers so we
2182  * help it out a bit.  The docs are correct, but the actual routine doesn't
2183  * do what the docs say it will.
2184  */
2185 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2186 int
2187 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2188                    struct sigaction* oact)
2189 {
2190   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2191         SETERRNO(EINVAL, SS$_INVARG);
2192         return -1;
2193   }
2194   return sigaction(sig, act, oact);
2195 }
2196 /*}}}*/
2197 #endif
2198
2199 #ifdef KILL_BY_SIGPRC
2200 #include <errnodef.h>
2201
2202 /* We implement our own kill() using the undocumented system service
2203    sys$sigprc for one of two reasons:
2204
2205    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2206    target process to do a sys$exit, which usually can't be handled
2207    gracefully...certainly not by Perl and the %SIG{} mechanism.
2208
2209    2.) If the kill() in the CRTL can't be called from a signal
2210    handler without disappearing into the ether, i.e., the signal
2211    it purportedly sends is never trapped. Still true as of VMS 7.3.
2212
2213    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2214    in the target process rather than calling sys$exit.
2215
2216    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2217    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2218    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2219    with condition codes C$_SIG0+nsig*8, catching the exception on the
2220    target process and resignaling with appropriate arguments.
2221
2222    But we don't have that VMS 7.0+ exception handler, so if you
2223    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2224
2225    Also note that SIGTERM is listed in the docs as being "unimplemented",
2226    yet always seems to be signaled with a VMS condition code of 4 (and
2227    correctly handled for that code).  So we hardwire it in.
2228
2229    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2230    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2231    than signalling with an unrecognized (and unhandled by CRTL) code.
2232 */
2233
2234 #define _MY_SIG_MAX 28
2235
2236 static unsigned int
2237 Perl_sig_to_vmscondition_int(int sig)
2238 {
2239     static unsigned int sig_code[_MY_SIG_MAX+1] =
2240     {
2241         0,                  /*  0 ZERO     */
2242         SS$_HANGUP,         /*  1 SIGHUP   */
2243         SS$_CONTROLC,       /*  2 SIGINT   */
2244         SS$_CONTROLY,       /*  3 SIGQUIT  */
2245         SS$_RADRMOD,        /*  4 SIGILL   */
2246         SS$_BREAK,          /*  5 SIGTRAP  */
2247         SS$_OPCCUS,         /*  6 SIGABRT  */
2248         SS$_COMPAT,         /*  7 SIGEMT   */
2249 #ifdef __VAX
2250         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2251 #else
2252         SS$_HPARITH,        /*  8 SIGFPE AXP */
2253 #endif
2254         SS$_ABORT,          /*  9 SIGKILL  */
2255         SS$_ACCVIO,         /* 10 SIGBUS   */
2256         SS$_ACCVIO,         /* 11 SIGSEGV  */
2257         SS$_BADPARAM,       /* 12 SIGSYS   */
2258         SS$_NOMBX,          /* 13 SIGPIPE  */
2259         SS$_ASTFLT,         /* 14 SIGALRM  */
2260         4,                  /* 15 SIGTERM  */
2261         0,                  /* 16 SIGUSR1  */
2262         0,                  /* 17 SIGUSR2  */
2263         0,                  /* 18 */
2264         0,                  /* 19 */
2265         0,                  /* 20 SIGCHLD  */
2266         0,                  /* 21 SIGCONT  */
2267         0,                  /* 22 SIGSTOP  */
2268         0,                  /* 23 SIGTSTP  */
2269         0,                  /* 24 SIGTTIN  */
2270         0,                  /* 25 SIGTTOU  */
2271         0,                  /* 26 */
2272         0,                  /* 27 */
2273         0                   /* 28 SIGWINCH  */
2274     };
2275
2276 #if __VMS_VER >= 60200000
2277     static int initted = 0;
2278     if (!initted) {
2279         initted = 1;
2280         sig_code[16] = C$_SIGUSR1;
2281         sig_code[17] = C$_SIGUSR2;
2282 #if __CRTL_VER >= 70000000
2283         sig_code[20] = C$_SIGCHLD;
2284 #endif
2285 #if __CRTL_VER >= 70300000
2286         sig_code[28] = C$_SIGWINCH;
2287 #endif
2288     }
2289 #endif
2290
2291     if (sig < _SIG_MIN) return 0;
2292     if (sig > _MY_SIG_MAX) return 0;
2293     return sig_code[sig];
2294 }
2295
2296 unsigned int
2297 Perl_sig_to_vmscondition(int sig)
2298 {
2299 #ifdef SS$_DEBUG
2300     if (vms_debug_on_exception != 0)
2301         lib$signal(SS$_DEBUG);
2302 #endif
2303     return Perl_sig_to_vmscondition_int(sig);
2304 }
2305
2306
2307 int
2308 Perl_my_kill(int pid, int sig)
2309 {
2310     dTHX;
2311     int iss;
2312     unsigned int code;
2313     int sys$sigprc(unsigned int *pidadr,
2314                      struct dsc$descriptor_s *prcname,
2315                      unsigned int code);
2316
2317      /* sig 0 means validate the PID */
2318     /*------------------------------*/
2319     if (sig == 0) {
2320         const unsigned long int jpicode = JPI$_PID;
2321         pid_t ret_pid;
2322         int status;
2323         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2324         if ($VMS_STATUS_SUCCESS(status))
2325            return 0;
2326         switch (status) {
2327         case SS$_NOSUCHNODE:
2328         case SS$_UNREACHABLE:
2329         case SS$_NONEXPR:
2330            errno = ESRCH;
2331            break;
2332         case SS$_NOPRIV:
2333            errno = EPERM;
2334            break;
2335         default:
2336            errno = EVMSERR;
2337         }
2338         vaxc$errno=status;
2339         return -1;
2340     }
2341
2342     code = Perl_sig_to_vmscondition_int(sig);
2343
2344     if (!code) {
2345         SETERRNO(EINVAL, SS$_BADPARAM);
2346         return -1;
2347     }
2348
2349     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2350      * signals are to be sent to multiple processes.
2351      *  pid = 0 - all processes in group except ones that the system exempts
2352      *  pid = -1 - all processes except ones that the system exempts
2353      *  pid = -n - all processes in group (abs(n)) except ...
2354      * For now, just report as not supported.
2355      */
2356
2357     if (pid <= 0) {
2358         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2359         return -1;
2360     }
2361
2362     iss = sys$sigprc((unsigned int *)&pid,0,code);
2363     if (iss&1) return 0;
2364
2365     switch (iss) {
2366       case SS$_NOPRIV:
2367         set_errno(EPERM);  break;
2368       case SS$_NONEXPR:
2369       case SS$_NOSUCHNODE:
2370       case SS$_UNREACHABLE:
2371         set_errno(ESRCH);  break;
2372       case SS$_INSFMEM:
2373         set_errno(ENOMEM); break;
2374       default:
2375         _ckvmssts(iss);
2376         set_errno(EVMSERR);
2377     }
2378     set_vaxc_errno(iss);
2379
2380     return -1;
2381 }
2382 #endif
2383
2384 /* Routine to convert a VMS status code to a UNIX status code.
2385 ** More tricky than it appears because of conflicting conventions with
2386 ** existing code.
2387 **
2388 ** VMS status codes are a bit mask, with the least significant bit set for
2389 ** success.
2390 **
2391 ** Special UNIX status of EVMSERR indicates that no translation is currently
2392 ** available, and programs should check the VMS status code.
2393 **
2394 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2395 ** decoding.
2396 */
2397
2398 #ifndef C_FACILITY_NO
2399 #define C_FACILITY_NO 0x350000
2400 #endif
2401 #ifndef DCL_IVVERB
2402 #define DCL_IVVERB 0x38090
2403 #endif
2404
2405 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2406 {
2407 int facility;
2408 int fac_sp;
2409 int msg_no;
2410 int msg_status;
2411 int unix_status;
2412
2413   /* Assume the best or the worst */
2414   if (vms_status & STS$M_SUCCESS)
2415     unix_status = 0;
2416   else
2417     unix_status = EVMSERR;
2418
2419   msg_status = vms_status & ~STS$M_CONTROL;
2420
2421   facility = vms_status & STS$M_FAC_NO;
2422   fac_sp = vms_status & STS$M_FAC_SP;
2423   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2424
2425   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2426     switch(msg_no) {
2427     case SS$_NORMAL:
2428         unix_status = 0;
2429         break;
2430     case SS$_ACCVIO:
2431         unix_status = EFAULT;
2432         break;
2433     case SS$_DEVOFFLINE:
2434         unix_status = EBUSY;
2435         break;
2436     case SS$_CLEARED:
2437         unix_status = ENOTCONN;
2438         break;
2439     case SS$_IVCHAN:
2440     case SS$_IVLOGNAM:
2441     case SS$_BADPARAM:
2442     case SS$_IVLOGTAB:
2443     case SS$_NOLOGNAM:
2444     case SS$_NOLOGTAB:
2445     case SS$_INVFILFOROP:
2446     case SS$_INVARG:
2447     case SS$_NOSUCHID:
2448     case SS$_IVIDENT:
2449         unix_status = EINVAL;
2450         break;
2451     case SS$_UNSUPPORTED:
2452         unix_status = ENOTSUP;
2453         break;
2454     case SS$_FILACCERR:
2455     case SS$_NOGRPPRV:
2456     case SS$_NOSYSPRV:
2457         unix_status = EACCES;
2458         break;
2459     case SS$_DEVICEFULL:
2460         unix_status = ENOSPC;
2461         break;
2462     case SS$_NOSUCHDEV:
2463         unix_status = ENODEV;
2464         break;
2465     case SS$_NOSUCHFILE:
2466     case SS$_NOSUCHOBJECT:
2467         unix_status = ENOENT;
2468         break;
2469     case SS$_ABORT:                                 /* Fatal case */
2470     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2471     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2472         unix_status = EINTR;
2473         break;
2474     case SS$_BUFFEROVF:
2475         unix_status = E2BIG;
2476         break;
2477     case SS$_INSFMEM:
2478         unix_status = ENOMEM;
2479         break;
2480     case SS$_NOPRIV:
2481         unix_status = EPERM;
2482         break;
2483     case SS$_NOSUCHNODE:
2484     case SS$_UNREACHABLE:
2485         unix_status = ESRCH;
2486         break;
2487     case SS$_NONEXPR:
2488         unix_status = ECHILD;
2489         break;
2490     default:
2491         if ((facility == 0) && (msg_no < 8)) {
2492           /* These are not real VMS status codes so assume that they are
2493           ** already UNIX status codes
2494           */
2495           unix_status = msg_no;
2496           break;
2497         }
2498     }
2499   }
2500   else {
2501     /* Translate a POSIX exit code to a UNIX exit code */
2502     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2503         unix_status = (msg_no & 0x07F8) >> 3;
2504     }
2505     else {
2506
2507          /* Documented traditional behavior for handling VMS child exits */
2508         /*--------------------------------------------------------------*/
2509         if (child_flag != 0) {
2510
2511              /* Success / Informational return 0 */
2512             /*----------------------------------*/
2513             if (msg_no & STS$K_SUCCESS)
2514                 return 0;
2515
2516              /* Warning returns 1 */
2517             /*-------------------*/
2518             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2519                 return 1;
2520
2521              /* Everything else pass through the severity bits */
2522             /*------------------------------------------------*/
2523             return (msg_no & STS$M_SEVERITY);
2524         }
2525
2526          /* Normal VMS status to ERRNO mapping attempt */
2527         /*--------------------------------------------*/
2528         switch(msg_status) {
2529         /* case RMS$_EOF: */ /* End of File */
2530         case RMS$_FNF:  /* File Not Found */
2531         case RMS$_DNF:  /* Dir Not Found */
2532                 unix_status = ENOENT;
2533                 break;
2534         case RMS$_RNF:  /* Record Not Found */
2535                 unix_status = ESRCH;
2536                 break;
2537         case RMS$_DIR:
2538                 unix_status = ENOTDIR;
2539                 break;
2540         case RMS$_DEV:
2541                 unix_status = ENODEV;
2542                 break;
2543         case RMS$_IFI:
2544         case RMS$_FAC:
2545         case RMS$_ISI:
2546                 unix_status = EBADF;
2547                 break;
2548         case RMS$_FEX:
2549                 unix_status = EEXIST;
2550                 break;
2551         case RMS$_SYN:
2552         case RMS$_FNM:
2553         case LIB$_INVSTRDES:
2554         case LIB$_INVARG:
2555         case LIB$_NOSUCHSYM:
2556         case LIB$_INVSYMNAM:
2557         case DCL_IVVERB:
2558                 unix_status = EINVAL;
2559                 break;
2560         case CLI$_BUFOVF:
2561         case RMS$_RTB:
2562         case CLI$_TKNOVF:
2563         case CLI$_RSLOVF:
2564                 unix_status = E2BIG;
2565                 break;
2566         case RMS$_PRV:  /* No privilege */
2567         case RMS$_ACC:  /* ACP file access failed */
2568         case RMS$_WLK:  /* Device write locked */
2569                 unix_status = EACCES;
2570                 break;
2571         /* case RMS$_NMF: */  /* No more files */
2572         }
2573     }
2574   }
2575
2576   return unix_status;
2577 }
2578
2579 /* Try to guess at what VMS error status should go with a UNIX errno
2580  * value.  This is hard to do as there could be many possible VMS
2581  * error statuses that caused the errno value to be set.
2582  */
2583
2584 int Perl_unix_status_to_vms(int unix_status)
2585 {
2586 int test_unix_status;
2587
2588      /* Trivial cases first */
2589     /*---------------------*/
2590     if (unix_status == EVMSERR)
2591         return vaxc$errno;
2592
2593      /* Is vaxc$errno sane? */
2594     /*---------------------*/
2595     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2596     if (test_unix_status == unix_status)
2597         return vaxc$errno;
2598
2599      /* If way out of range, must be VMS code already */
2600     /*-----------------------------------------------*/
2601     if (unix_status > EVMSERR)
2602         return unix_status;
2603
2604      /* If out of range, punt */
2605     /*-----------------------*/
2606     if (unix_status > __ERRNO_MAX)
2607         return SS$_ABORT;
2608
2609
2610      /* Ok, now we have to do it the hard way. */
2611     /*----------------------------------------*/
2612     switch(unix_status) {
2613     case 0:     return SS$_NORMAL;
2614     case EPERM: return SS$_NOPRIV;
2615     case ENOENT: return SS$_NOSUCHOBJECT;
2616     case ESRCH: return SS$_UNREACHABLE;
2617     case EINTR: return SS$_ABORT;
2618     /* case EIO: */
2619     /* case ENXIO:  */
2620     case E2BIG: return SS$_BUFFEROVF;
2621     /* case ENOEXEC */
2622     case EBADF: return RMS$_IFI;
2623     case ECHILD: return SS$_NONEXPR;
2624     /* case EAGAIN */
2625     case ENOMEM: return SS$_INSFMEM;
2626     case EACCES: return SS$_FILACCERR;
2627     case EFAULT: return SS$_ACCVIO;
2628     /* case ENOTBLK */
2629     case EBUSY: return SS$_DEVOFFLINE;
2630     case EEXIST: return RMS$_FEX;
2631     /* case EXDEV */
2632     case ENODEV: return SS$_NOSUCHDEV;
2633     case ENOTDIR: return RMS$_DIR;
2634     /* case EISDIR */
2635     case EINVAL: return SS$_INVARG;
2636     /* case ENFILE */
2637     /* case EMFILE */
2638     /* case ENOTTY */
2639     /* case ETXTBSY */
2640     /* case EFBIG */
2641     case ENOSPC: return SS$_DEVICEFULL;
2642     case ESPIPE: return LIB$_INVARG;
2643     /* case EROFS: */
2644     /* case EMLINK: */
2645     /* case EPIPE: */
2646     /* case EDOM */
2647     case ERANGE: return LIB$_INVARG;
2648     /* case EWOULDBLOCK */
2649     /* case EINPROGRESS */
2650     /* case EALREADY */
2651     /* case ENOTSOCK */
2652     /* case EDESTADDRREQ */
2653     /* case EMSGSIZE */
2654     /* case EPROTOTYPE */
2655     /* case ENOPROTOOPT */
2656     /* case EPROTONOSUPPORT */
2657     /* case ESOCKTNOSUPPORT */
2658     /* case EOPNOTSUPP */
2659     /* case EPFNOSUPPORT */
2660     /* case EAFNOSUPPORT */
2661     /* case EADDRINUSE */
2662     /* case EADDRNOTAVAIL */
2663     /* case ENETDOWN */
2664     /* case ENETUNREACH */
2665     /* case ENETRESET */
2666     /* case ECONNABORTED */
2667     /* case ECONNRESET */
2668     /* case ENOBUFS */
2669     /* case EISCONN */
2670     case ENOTCONN: return SS$_CLEARED;
2671     /* case ESHUTDOWN */
2672     /* case ETOOMANYREFS */
2673     /* case ETIMEDOUT */
2674     /* case ECONNREFUSED */
2675     /* case ELOOP */
2676     /* case ENAMETOOLONG */
2677     /* case EHOSTDOWN */
2678     /* case EHOSTUNREACH */
2679     /* case ENOTEMPTY */
2680     /* case EPROCLIM */
2681     /* case EUSERS  */
2682     /* case EDQUOT  */
2683     /* case ENOMSG  */
2684     /* case EIDRM */
2685     /* case EALIGN */
2686     /* case ESTALE */
2687     /* case EREMOTE */
2688     /* case ENOLCK */
2689     /* case ENOSYS */
2690     /* case EFTYPE */
2691     /* case ECANCELED */
2692     /* case EFAIL */
2693     /* case EINPROG */
2694     case ENOTSUP:
2695         return SS$_UNSUPPORTED;
2696     /* case EDEADLK */
2697     /* case ENWAIT */
2698     /* case EILSEQ */
2699     /* case EBADCAT */
2700     /* case EBADMSG */
2701     /* case EABANDONED */
2702     default:
2703         return SS$_ABORT; /* punt */
2704     }
2705
2706   return SS$_ABORT; /* Should not get here */
2707 }
2708
2709
2710 /* default piping mailbox size */
2711 #define PERL_BUFSIZ        512
2712
2713
2714 static void
2715 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2716 {
2717   unsigned long int mbxbufsiz;
2718   static unsigned long int syssize = 0;
2719   unsigned long int dviitm = DVI$_DEVNAM;
2720   char csize[LNM$C_NAMLENGTH+1];
2721   int sts;
2722
2723   if (!syssize) {
2724     unsigned long syiitm = SYI$_MAXBUF;
2725     /*
2726      * Get the SYSGEN parameter MAXBUF
2727      *
2728      * If the logical 'PERL_MBX_SIZE' is defined
2729      * use the value of the logical instead of PERL_BUFSIZ, but
2730      * keep the size between 128 and MAXBUF.
2731      *
2732      */
2733     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2734   }
2735
2736   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2737       mbxbufsiz = atoi(csize);
2738   } else {
2739       mbxbufsiz = PERL_BUFSIZ;
2740   }
2741   if (mbxbufsiz < 128) mbxbufsiz = 128;
2742   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2743
2744   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2745
2746   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2747   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2748
2749 }  /* end of create_mbx() */
2750
2751
2752 /*{{{  my_popen and my_pclose*/
2753
2754 typedef struct _iosb           IOSB;
2755 typedef struct _iosb*         pIOSB;
2756 typedef struct _pipe           Pipe;
2757 typedef struct _pipe*         pPipe;
2758 typedef struct pipe_details    Info;
2759 typedef struct pipe_details*  pInfo;
2760 typedef struct _srqp            RQE;
2761 typedef struct _srqp*          pRQE;
2762 typedef struct _tochildbuf      CBuf;
2763 typedef struct _tochildbuf*    pCBuf;
2764
2765 struct _iosb {
2766     unsigned short status;
2767     unsigned short count;
2768     unsigned long  dvispec;
2769 };
2770
2771 #pragma member_alignment save
2772 #pragma nomember_alignment quadword
2773 struct _srqp {          /* VMS self-relative queue entry */
2774     unsigned long qptr[2];
2775 };
2776 #pragma member_alignment restore
2777 static RQE  RQE_ZERO = {0,0};
2778
2779 struct _tochildbuf {
2780     RQE             q;
2781     int             eof;
2782     unsigned short  size;
2783     char            *buf;
2784 };
2785
2786 struct _pipe {
2787     RQE            free;
2788     RQE            wait;
2789     int            fd_out;
2790     unsigned short chan_in;
2791     unsigned short chan_out;
2792     char          *buf;
2793     unsigned int   bufsize;
2794     IOSB           iosb;
2795     IOSB           iosb2;
2796     int           *pipe_done;
2797     int            retry;
2798     int            type;
2799     int            shut_on_empty;
2800     int            need_wake;
2801     pPipe         *home;
2802     pInfo          info;
2803     pCBuf          curr;
2804     pCBuf          curr2;
2805 #if defined(PERL_IMPLICIT_CONTEXT)
2806     void            *thx;           /* Either a thread or an interpreter */
2807                                     /* pointer, depending on how we're built */
2808 #endif
2809 };
2810
2811
2812 struct pipe_details
2813 {
2814     pInfo           next;
2815     PerlIO *fp;  /* file pointer to pipe mailbox */
2816     int useFILE; /* using stdio, not perlio */
2817     int pid;   /* PID of subprocess */
2818     int mode;  /* == 'r' if pipe open for reading */
2819     int done;  /* subprocess has completed */
2820     int waiting; /* waiting for completion/closure */
2821     int             closing;        /* my_pclose is closing this pipe */
2822     unsigned long   completion;     /* termination status of subprocess */
2823     pPipe           in;             /* pipe in to sub */
2824     pPipe           out;            /* pipe out of sub */
2825     pPipe           err;            /* pipe of sub's sys$error */
2826     int             in_done;        /* true when in pipe finished */
2827     int             out_done;
2828     int             err_done;
2829     unsigned short  xchan;          /* channel to debug xterm */
2830     unsigned short  xchan_valid;    /* channel is assigned */
2831 };
2832
2833 struct exit_control_block
2834 {
2835     struct exit_control_block *flink;
2836     unsigned long int   (*exit_routine)();
2837     unsigned long int arg_count;
2838     unsigned long int *status_address;
2839     unsigned long int exit_status;
2840 };
2841
2842 typedef struct _closed_pipes    Xpipe;
2843 typedef struct _closed_pipes*  pXpipe;
2844
2845 struct _closed_pipes {
2846     int             pid;            /* PID of subprocess */
2847     unsigned long   completion;     /* termination status of subprocess */
2848 };
2849 #define NKEEPCLOSED 50
2850 static Xpipe closed_list[NKEEPCLOSED];
2851 static int   closed_index = 0;
2852 static int   closed_num = 0;
2853
2854 #define RETRY_DELAY     "0 ::0.20"
2855 #define MAX_RETRY              50
2856
2857 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2858 static unsigned long mypid;
2859 static unsigned long delaytime[2];
2860
2861 static pInfo open_pipes = NULL;
2862 static $DESCRIPTOR(nl_desc, "NL:");
2863
2864 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2865
2866
2867
2868 static unsigned long int
2869 pipe_exit_routine(pTHX)
2870 {
2871     pInfo info;
2872     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2873     int sts, did_stuff, need_eof, j;
2874
2875    /*
2876     * Flush any pending i/o, but since we are in process run-down, be
2877     * careful about referencing PerlIO structures that may already have
2878     * been deallocated.  We may not even have an interpreter anymore.
2879     */
2880     info = open_pipes;
2881     while (info) {
2882         if (info->fp) {
2883            if (!info->useFILE
2884 #if defined(USE_ITHREADS)
2885              && my_perl
2886 #endif
2887              && PL_perlio_fd_refcnt)
2888                PerlIO_flush(info->fp);
2889            else
2890                fflush((FILE *)info->fp);
2891         }
2892         info = info->next;
2893     }
2894
2895     /*
2896      next we try sending an EOF...ignore if doesn't work, make sure we
2897      don't hang
2898     */
2899     did_stuff = 0;
2900     info = open_pipes;
2901
2902     while (info) {
2903       int need_eof;
2904       _ckvmssts_noperl(sys$setast(0));
2905       if (info->in && !info->in->shut_on_empty) {
2906         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2907                           0, 0, 0, 0, 0, 0));
2908         info->waiting = 1;
2909         did_stuff = 1;
2910       }
2911       _ckvmssts_noperl(sys$setast(1));
2912       info = info->next;
2913     }
2914
2915     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2916
2917     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2918         int nwait = 0;
2919
2920         info = open_pipes;
2921         while (info) {
2922           _ckvmssts_noperl(sys$setast(0));
2923           if (info->waiting && info->done)
2924                 info->waiting = 0;
2925           nwait += info->waiting;
2926           _ckvmssts_noperl(sys$setast(1));
2927           info = info->next;
2928         }
2929         if (!nwait) break;
2930         sleep(1);
2931     }
2932
2933     did_stuff = 0;
2934     info = open_pipes;
2935     while (info) {
2936       _ckvmssts_noperl(sys$setast(0));
2937       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2938         sts = sys$forcex(&info->pid,0,&abort);
2939         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2940         did_stuff = 1;
2941       }
2942       _ckvmssts_noperl(sys$setast(1));
2943       info = info->next;
2944     }
2945
2946     /* again, wait for effect */
2947
2948     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2949         int nwait = 0;
2950
2951         info = open_pipes;
2952         while (info) {
2953           _ckvmssts_noperl(sys$setast(0));
2954           if (info->waiting && info->done)
2955                 info->waiting = 0;
2956           nwait += info->waiting;
2957           _ckvmssts_noperl(sys$setast(1));
2958           info = info->next;
2959         }
2960         if (!nwait) break;
2961         sleep(1);
2962     }
2963
2964     info = open_pipes;
2965     while (info) {
2966       _ckvmssts_noperl(sys$setast(0));
2967       if (!info->done) {  /* We tried to be nice . . . */
2968         sts = sys$delprc(&info->pid,0);
2969         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2970         info->done = 1;  /* sys$delprc is as done as we're going to get. */
2971       }
2972       _ckvmssts_noperl(sys$setast(1));
2973       info = info->next;
2974     }
2975
2976     while(open_pipes) {
2977       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2978       else if (!(sts & 1)) retsts = sts;
2979     }
2980     return retsts;
2981 }
2982
2983 static struct exit_control_block pipe_exitblock =
2984        {(struct exit_control_block *) 0,
2985         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2986
2987 static void pipe_mbxtofd_ast(pPipe p);
2988 static void pipe_tochild1_ast(pPipe p);
2989 static void pipe_tochild2_ast(pPipe p);
2990
2991 static void
2992 popen_completion_ast(pInfo info)
2993 {
2994   pInfo i = open_pipes;
2995   int iss;
2996   int sts;
2997   pXpipe x;
2998
2999   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3000   closed_list[closed_index].pid = info->pid;
3001   closed_list[closed_index].completion = info->completion;
3002   closed_index++;
3003   if (closed_index == NKEEPCLOSED)
3004     closed_index = 0;
3005   closed_num++;
3006
3007   while (i) {
3008     if (i == info) break;
3009     i = i->next;
3010   }
3011   if (!i) return;       /* unlinked, probably freed too */
3012
3013   info->done = TRUE;
3014
3015 /*
3016     Writing to subprocess ...
3017             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3018
3019             chan_out may be waiting for "done" flag, or hung waiting
3020             for i/o completion to child...cancel the i/o.  This will
3021             put it into "snarf mode" (done but no EOF yet) that discards
3022             input.
3023
3024     Output from subprocess (stdout, stderr) needs to be flushed and
3025     shut down.   We try sending an EOF, but if the mbx is full the pipe
3026     routine should still catch the "shut_on_empty" flag, telling it to
3027     use immediate-style reads so that "mbx empty" -> EOF.
3028
3029
3030 */
3031   if (info->in && !info->in_done) {               /* only for mode=w */
3032         if (info->in->shut_on_empty && info->in->need_wake) {
3033             info->in->need_wake = FALSE;
3034             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3035         } else {
3036             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3037         }
3038   }
3039
3040   if (info->out && !info->out_done) {             /* were we also piping output? */
3041       info->out->shut_on_empty = TRUE;
3042       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3043       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3044       _ckvmssts_noperl(iss);
3045   }
3046
3047   if (info->err && !info->err_done) {        /* we were piping stderr */
3048         info->err->shut_on_empty = TRUE;
3049         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3050         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3051         _ckvmssts_noperl(iss);
3052   }
3053   _ckvmssts_noperl(sys$setef(pipe_ef));
3054
3055 }
3056
3057 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3058 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3059
3060 /*
3061     we actually differ from vmstrnenv since we use this to
3062     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3063     are pointing to the same thing
3064 */
3065
3066 static unsigned short
3067 popen_translate(pTHX_ char *logical, char *result)
3068 {
3069     int iss;
3070     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3071     $DESCRIPTOR(d_log,"");
3072     struct _il3 {
3073         unsigned short length;
3074         unsigned short code;
3075         char *         buffer_addr;
3076         unsigned short *retlenaddr;
3077     } itmlst[2];
3078     unsigned short l, ifi;
3079
3080     d_log.dsc$a_pointer = logical;
3081     d_log.dsc$w_length  = strlen(logical);
3082
3083     itmlst[0].code = LNM$_STRING;
3084     itmlst[0].length = 255;
3085     itmlst[0].buffer_addr = result;
3086     itmlst[0].retlenaddr = &l;
3087
3088     itmlst[1].code = 0;
3089     itmlst[1].length = 0;
3090     itmlst[1].buffer_addr = 0;
3091     itmlst[1].retlenaddr = 0;
3092
3093     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3094     if (iss == SS$_NOLOGNAM) {
3095         iss = SS$_NORMAL;
3096         l = 0;
3097     }
3098     if (!(iss&1)) lib$signal(iss);
3099     result[l] = '\0';
3100 /*
3101     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
3102     strip it off and return the ifi, if any
3103 */
3104     ifi  = 0;
3105     if (result[0] == 0x1b && result[1] == 0x00) {
3106         memmove(&ifi,result+2,2);
3107         strcpy(result,result+4);
3108     }
3109     return ifi;     /* this is the RMS internal file id */
3110 }
3111
3112 static void pipe_infromchild_ast(pPipe p);
3113
3114 /*
3115     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3116     inside an AST routine without worrying about reentrancy and which Perl
3117     memory allocator is being used.
3118
3119     We read data and queue up the buffers, then spit them out one at a
3120     time to the output mailbox when the output mailbox is ready for one.
3121
3122 */
3123 #define INITIAL_TOCHILDQUEUE  2
3124
3125 static pPipe
3126 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3127 {
3128     pPipe p;
3129     pCBuf b;
3130     char mbx1[64], mbx2[64];
3131     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3132                                       DSC$K_CLASS_S, mbx1},
3133                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3134                                       DSC$K_CLASS_S, mbx2};
3135     unsigned int dviitm = DVI$_DEVBUFSIZ;
3136     int j, n;
3137
3138     n = sizeof(Pipe);
3139     _ckvmssts(lib$get_vm(&n, &p));
3140
3141     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3142     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3143     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3144
3145     p->buf           = 0;
3146     p->shut_on_empty = FALSE;
3147     p->need_wake     = FALSE;
3148     p->type          = 0;
3149     p->retry         = 0;
3150     p->iosb.status   = SS$_NORMAL;
3151     p->iosb2.status  = SS$_NORMAL;
3152     p->free          = RQE_ZERO;
3153     p->wait          = RQE_ZERO;
3154     p->curr          = 0;
3155     p->curr2         = 0;
3156     p->info          = 0;
3157 #ifdef PERL_IMPLICIT_CONTEXT
3158     p->thx           = aTHX;
3159 #endif
3160
3161     n = sizeof(CBuf) + p->bufsize;
3162
3163     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3164         _ckvmssts(lib$get_vm(&n, &b));
3165         b->buf = (char *) b + sizeof(CBuf);
3166         _ckvmssts(lib$insqhi(b, &p->free));
3167     }
3168
3169     pipe_tochild2_ast(p);
3170     pipe_tochild1_ast(p);
3171     strcpy(wmbx, mbx1);
3172     strcpy(rmbx, mbx2);
3173     return p;
3174 }
3175
3176 /*  reads the MBX Perl is writing, and queues */
3177
3178 static void
3179 pipe_tochild1_ast(pPipe p)
3180 {
3181     pCBuf b = p->curr;
3182     int iss = p->iosb.status;
3183     int eof = (iss == SS$_ENDOFFILE);
3184     int sts;
3185 #ifdef PERL_IMPLICIT_CONTEXT
3186     pTHX = p->thx;
3187 #endif
3188
3189     if (p->retry) {
3190         if (eof) {
3191             p->shut_on_empty = TRUE;
3192             b->eof     = TRUE;
3193             _ckvmssts(sys$dassgn(p->chan_in));
3194         } else  {
3195             _ckvmssts(iss);
3196         }
3197
3198         b->eof  = eof;
3199         b->size = p->iosb.count;
3200         _ckvmssts(sts = lib$insqhi(b, &p->wait));
3201         if (p->need_wake) {
3202             p->need_wake = FALSE;
3203             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3204         }
3205     } else {
3206         p->retry = 1;   /* initial call */
3207     }
3208
3209     if (eof) {                  /* flush the free queue, return when done */
3210         int n = sizeof(CBuf) + p->bufsize;
3211         while (1) {
3212             iss = lib$remqti(&p->free, &b);
3213             if (iss == LIB$_QUEWASEMP) return;
3214             _ckvmssts(iss);
3215             _ckvmssts(lib$free_vm(&n, &b));
3216         }
3217     }
3218
3219     iss = lib$remqti(&p->free, &b);
3220     if (iss == LIB$_QUEWASEMP) {
3221         int n = sizeof(CBuf) + p->bufsize;
3222         _ckvmssts(lib$get_vm(&n, &b));
3223         b->buf = (char *) b + sizeof(CBuf);
3224     } else {
3225        _ckvmssts(iss);
3226     }
3227
3228     p->curr = b;
3229     iss = sys$qio(0,p->chan_in,
3230              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3231              &p->iosb,
3232              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3233     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3234     _ckvmssts(iss);
3235 }
3236
3237
3238 /* writes queued buffers to output, waits for each to complete before
3239    doing the next */
3240
3241 static void
3242 pipe_tochild2_ast(pPipe p)
3243 {
3244     pCBuf b = p->curr2;
3245     int iss = p->iosb2.status;
3246     int n = sizeof(CBuf) + p->bufsize;
3247     int done = (p->info && p->info->done) ||
3248               iss == SS$_CANCEL || iss == SS$_ABORT;
3249 #if defined(PERL_IMPLICIT_CONTEXT)
3250     pTHX = p->thx;
3251 #endif
3252
3253     do {
3254         if (p->type) {         /* type=1 has old buffer, dispose */
3255             if (p->shut_on_empty) {
3256                 _ckvmssts(lib$free_vm(&n, &b));
3257             } else {
3258                 _ckvmssts(lib$insqhi(b, &p->free));
3259             }
3260             p->type = 0;
3261         }
3262
3263         iss = lib$remqti(&p->wait, &b);
3264         if (iss == LIB$_QUEWASEMP) {
3265             if (p->shut_on_empty) {
3266                 if (done) {
3267                     _ckvmssts(sys$dassgn(p->chan_out));
3268                     *p->pipe_done = TRUE;
3269                     _ckvmssts(sys$setef(pipe_ef));
3270                 } else {
3271                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3272                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3273                 }
3274                 return;
3275             }
3276             p->need_wake = TRUE;
3277             return;
3278         }
3279         _ckvmssts(iss);
3280         p->type = 1;
3281     } while (done);
3282
3283
3284     p->curr2 = b;
3285     if (b->eof) {
3286         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3287             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3288     } else {
3289         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3290             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3291     }
3292
3293     return;
3294
3295 }
3296
3297
3298 static pPipe
3299 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3300 {
3301     pPipe p;
3302     char mbx1[64], mbx2[64];
3303     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3304                                       DSC$K_CLASS_S, mbx1},
3305                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3306                                       DSC$K_CLASS_S, mbx2};
3307     unsigned int dviitm = DVI$_DEVBUFSIZ;
3308
3309     int n = sizeof(Pipe);
3310     _ckvmssts(lib$get_vm(&n, &p));
3311     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3312     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3313
3314     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3315     n = p->bufsize * sizeof(char);
3316     _ckvmssts(lib$get_vm(&n, &p->buf));
3317     p->shut_on_empty = FALSE;
3318     p->info   = 0;
3319     p->type   = 0;
3320     p->iosb.status = SS$_NORMAL;
3321 #if defined(PERL_IMPLICIT_CONTEXT)
3322     p->thx = aTHX;
3323 #endif
3324     pipe_infromchild_ast(p);
3325
3326     strcpy(wmbx, mbx1);
3327     strcpy(rmbx, mbx2);
3328     return p;
3329 }
3330
3331 static void
3332 pipe_infromchild_ast(pPipe p)
3333 {
3334     int iss = p->iosb.status;
3335     int eof = (iss == SS$_ENDOFFILE);
3336     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3337     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3338 #if defined(PERL_IMPLICIT_CONTEXT)
3339     pTHX = p->thx;
3340 #endif
3341
3342     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3343         _ckvmssts(sys$dassgn(p->chan_out));
3344         p->chan_out = 0;
3345     }
3346
3347     /* read completed:
3348             input shutdown if EOF from self (done or shut_on_empty)
3349             output shutdown if closing flag set (my_pclose)
3350             send data/eof from child or eof from self
3351             otherwise, re-read (snarf of data from child)
3352     */
3353
3354     if (p->type == 1) {
3355         p->type = 0;
3356         if (myeof && p->chan_in) {                  /* input shutdown */
3357             _ckvmssts(sys$dassgn(p->chan_in));
3358             p->chan_in = 0;
3359         }
3360
3361         if (p->chan_out) {
3362             if (myeof || kideof) {      /* pass EOF to parent */
3363                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3364                               pipe_infromchild_ast, p,
3365                               0, 0, 0, 0, 0, 0));
3366                 return;
3367             } else if (eof) {       /* eat EOF --- fall through to read*/
3368
3369             } else {                /* transmit data */
3370                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3371                               pipe_infromchild_ast,p,
3372                               p->buf, p->iosb.count, 0, 0, 0, 0));
3373                 return;
3374             }
3375         }
3376     }
3377
3378     /*  everything shut? flag as done */
3379
3380     if (!p->chan_in && !p->chan_out) {
3381         *p->pipe_done = TRUE;
3382         _ckvmssts(sys$setef(pipe_ef));
3383         return;
3384     }
3385
3386     /* write completed (or read, if snarfing from child)
3387             if still have input active,
3388                queue read...immediate mode if shut_on_empty so we get EOF if empty
3389             otherwise,
3390                check if Perl reading, generate EOFs as needed
3391     */
3392
3393     if (p->type == 0) {
3394         p->type = 1;
3395         if (p->chan_in) {
3396             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3397                           pipe_infromchild_ast,p,
3398                           p->buf, p->bufsize, 0, 0, 0, 0);
3399             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3400             _ckvmssts(iss);
3401         } else {           /* send EOFs for extra reads */
3402             p->iosb.status = SS$_ENDOFFILE;
3403             p->iosb.dvispec = 0;
3404             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3405                       0, 0, 0,
3406                       pipe_infromchild_ast, p, 0, 0, 0, 0));
3407         }
3408     }
3409 }
3410
3411 static pPipe
3412 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3413 {
3414     pPipe p;
3415     char mbx[64];
3416     unsigned long dviitm = DVI$_DEVBUFSIZ;
3417     struct stat s;
3418     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3419                                       DSC$K_CLASS_S, mbx};
3420     int n = sizeof(Pipe);
3421
3422     /* things like terminals and mbx's don't need this filter */
3423     if (fd && fstat(fd,&s) == 0) {
3424         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3425         char device[65];
3426         unsigned short dev_len;
3427         struct dsc$descriptor_s d_dev;
3428         char * cptr;
3429         struct item_list_3 items[3];
3430         int status;
3431         unsigned short dvi_iosb[4];
3432
3433         cptr = getname(fd, out, 1);
3434         if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3435         d_dev.dsc$a_pointer = out;
3436         d_dev.dsc$w_length = strlen(out);
3437         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3438         d_dev.dsc$b_class = DSC$K_CLASS_S;
3439
3440         items[0].len = 4;
3441         items[0].code = DVI$_DEVCHAR;
3442         items[0].bufadr = &devchar;
3443         items[0].retadr = NULL;
3444         items[1].len = 64;
3445         items[1].code = DVI$_FULLDEVNAM;
3446         items[1].bufadr = device;
3447         items[1].retadr = &dev_len;
3448         items[2].len = 0;
3449         items[2].code = 0;
3450
3451         status = sys$getdviw
3452                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3453         _ckvmssts(status);
3454         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3455             device[dev_len] = 0;
3456
3457             if (!(devchar & DEV$M_DIR)) {
3458                 strcpy(out, device);
3459                 return 0;
3460             }
3461         }
3462     }
3463
3464     _ckvmssts(lib$get_vm(&n, &p));
3465     p->fd_out = dup(fd);
3466     create_mbx(aTHX_ &p->chan_in, &d_mbx);
3467     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3468     n = (p->bufsize+1) * sizeof(char);
3469     _ckvmssts(lib$get_vm(&n, &p->buf));
3470     p->shut_on_empty = FALSE;
3471     p->retry = 0;
3472     p->info  = 0;
3473     strcpy(out, mbx);
3474
3475     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3476                   pipe_mbxtofd_ast, p,
3477                   p->buf, p->bufsize, 0, 0, 0, 0));
3478
3479     return p;
3480 }
3481
3482 static void
3483 pipe_mbxtofd_ast(pPipe p)
3484 {
3485     int iss = p->iosb.status;
3486     int done = p->info->done;
3487     int iss2;
3488     int eof = (iss == SS$_ENDOFFILE);
3489     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3490     int err = !(iss&1) && !eof;
3491 #if defined(PERL_IMPLICIT_CONTEXT)
3492     pTHX = p->thx;
3493 #endif
3494
3495     if (done && myeof) {               /* end piping */
3496         close(p->fd_out);
3497         sys$dassgn(p->chan_in);
3498         *p->pipe_done = TRUE;
3499         _ckvmssts(sys$setef(pipe_ef));
3500         return;
3501     }
3502
3503     if (!err && !eof) {             /* good data to send to file */
3504         p->buf[p->iosb.count] = '\n';
3505         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3506         if (iss2 < 0) {
3507             p->retry++;
3508             if (p->retry < MAX_RETRY) {
3509                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3510                 return;
3511             }
3512         }
3513         p->retry = 0;
3514     } else if (err) {
3515         _ckvmssts(iss);
3516     }
3517
3518
3519     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3520           pipe_mbxtofd_ast, p,
3521           p->buf, p->bufsize, 0, 0, 0, 0);
3522     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3523     _ckvmssts(iss);
3524 }
3525
3526
3527 typedef struct _pipeloc     PLOC;
3528 typedef struct _pipeloc*   pPLOC;
3529
3530 struct _pipeloc {
3531     pPLOC   next;
3532     char    dir[NAM$C_MAXRSS+1];
3533 };
3534 static pPLOC  head_PLOC = 0;
3535
3536 void
3537 free_pipelocs(pTHX_ void *head)
3538 {
3539     pPLOC p, pnext;
3540     pPLOC *pHead = (pPLOC *)head;
3541
3542     p = *pHead;
3543     while (p) {
3544         pnext = p->next;
3545         PerlMem_free(p);
3546         p = pnext;
3547     }
3548     *pHead = 0;
3549 }
3550
3551 static void
3552 store_pipelocs(pTHX)
3553 {
3554     int    i;
3555     pPLOC  p;
3556     AV    *av = 0;
3557     SV    *dirsv;
3558     GV    *gv;
3559     char  *dir, *x;
3560     char  *unixdir;
3561     char  temp[NAM$C_MAXRSS+1];
3562     STRLEN n_a;
3563
3564     if (head_PLOC)
3565         free_pipelocs(aTHX_ &head_PLOC);
3566
3567 /*  the . directory from @INC comes last */
3568
3569     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3570     if (p == NULL) _ckvmssts(SS$_INSFMEM);
3571     p->next = head_PLOC;
3572     head_PLOC = p;
3573     strcpy(p->dir,"./");
3574
3575 /*  get the directory from $^X */
3576
3577     unixdir = PerlMem_malloc(VMS_MAXRSS);
3578     if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3579
3580 #ifdef PERL_IMPLICIT_CONTEXT
3581     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3582 #else
3583     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3584 #endif
3585         strcpy(temp, PL_origargv[0]);
3586         x = strrchr(temp,']');
3587         if (x == NULL) {
3588         x = strrchr(temp,'>');
3589           if (x == NULL) {
3590             /* It could be a UNIX path */
3591             x = strrchr(temp,'/');
3592           }
3593         }
3594         if (x)
3595           x[1] = '\0';
3596         else {
3597           /* Got a bare name, so use default directory */
3598           temp[0] = '.';
3599           temp[1] = '\0';
3600         }
3601
3602         if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
3603             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3604             if (p == NULL) _ckvmssts(SS$_INSFMEM);
3605             p->next = head_PLOC;
3606             head_PLOC = p;
3607             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3608             p->dir[NAM$C_MAXRSS] = '\0';
3609         }
3610     }
3611
3612 /*  reverse order of @INC entries, skip "." since entered above */
3613
3614 #ifdef PERL_IMPLICIT_CONTEXT
3615     if (aTHX)
3616 #endif
3617     if (PL_incgv) av = GvAVn(PL_incgv);
3618
3619     for (i = 0; av && i <= AvFILL(av); i++) {
3620         dirsv = *av_fetch(av,i,TRUE);
3621
3622         if (SvROK(dirsv)) continue;
3623         dir = SvPVx(dirsv,n_a);
3624         if (strcmp(dir,".") == 0) continue;
3625         if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
3626             continue;
3627
3628         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3629         p->next = head_PLOC;
3630         head_PLOC = p;
3631         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3632         p->dir[NAM$C_MAXRSS] = '\0';
3633     }
3634
3635 /* most likely spot (ARCHLIB) put first in the list */
3636
3637 #ifdef ARCHLIB_EXP
3638     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
3639         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3640         if (p == NULL) _ckvmssts(SS$_INSFMEM);
3641         p->next = head_PLOC;
3642         head_PLOC = p;
3643         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3644         p->dir[NAM$C_MAXRSS] = '\0';
3645     }
3646 #endif
3647     PerlMem_free(unixdir);
3648 }
3649
3650 static I32
3651 Perl_cando_by_name_int
3652    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3653 #if !defined(PERL_IMPLICIT_CONTEXT)
3654 #define cando_by_name_int               Perl_cando_by_name_int
3655 #else
3656 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3657 #endif
3658
3659 static char *
3660 find_vmspipe(pTHX)
3661 {
3662     static int   vmspipe_file_status = 0;
3663     static char  vmspipe_file[NAM$C_MAXRSS+1];
3664
3665     /* already found? Check and use ... need read+execute permission */
3666
3667     if (vmspipe_file_status == 1) {
3668         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3669          && cando_by_name_int
3670            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3671             return vmspipe_file;
3672         }
3673         vmspipe_file_status = 0;
3674     }
3675
3676     /* scan through stored @INC, $^X */
3677
3678     if (vmspipe_file_status == 0) {
3679         char file[NAM$C_MAXRSS+1];
3680         pPLOC  p = head_PLOC;
3681
3682         while (p) {
3683             char * exp_res;
3684             int dirlen;
3685             strcpy(file, p->dir);
3686             dirlen = strlen(file);
3687             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3688             file[NAM$C_MAXRSS] = '\0';
3689             p = p->next;
3690
3691             exp_res = do_rmsexpand
3692                 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3693             if (!exp_res) continue;
3694
3695             if (cando_by_name_int
3696                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3697              && cando_by_name_int
3698                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3699                 vmspipe_file_status = 1;
3700                 return vmspipe_file;
3701             }
3702         }
3703         vmspipe_file_status = -1;   /* failed, use tempfiles */
3704     }
3705
3706     return 0;
3707 }
3708
3709 static FILE *
3710 vmspipe_tempfile(pTHX)
3711 {
3712     char file[NAM$C_MAXRSS+1];
3713     FILE *fp;
3714     static int index = 0;
3715     Stat_t s0, s1;
3716     int cmp_result;
3717
3718     /* create a tempfile */
3719
3720     /* we can't go from   W, shr=get to  R, shr=get without
3721        an intermediate vulnerable state, so don't bother trying...
3722
3723        and lib$spawn doesn't shr=put, so have to close the write
3724
3725        So... match up the creation date/time and the FID to
3726        make sure we're dealing with the same file
3727
3728     */
3729
3730     index++;
3731     if (!decc_filename_unix_only) {
3732       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3733       fp = fopen(file,"w");
3734       if (!fp) {
3735         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3736         fp = fopen(file,"w");
3737         if (!fp) {
3738             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3739             fp = fopen(file,"w");
3740         }
3741       }
3742      }
3743      else {
3744       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3745       fp = fopen(file,"w");
3746       if (!fp) {
3747         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3748         fp = fopen(file,"w");
3749         if (!fp) {
3750           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3751           fp = fopen(file,"w");
3752         }
3753       }
3754     }
3755     if (!fp) return 0;  /* we're hosed */
3756
3757     fprintf(fp,"$! 'f$verify(0)'\n");
3758     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3759     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3760     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3761     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3762     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3763     fprintf(fp,"$ perl_del    = \"delete\"\n");
3764     fprintf(fp,"$ pif         = \"if\"\n");
3765     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3766     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3767     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3768     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3769     fprintf(fp,"$!  --- build command line to get max possible length\n");
3770     fprintf(fp,"$c=perl_popen_cmd0\n");
3771     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3772     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3773     fprintf(fp,"$x=perl_popen_cmd3\n");
3774     fprintf(fp,"$c=c+x\n");
3775     fprintf(fp,"$ perl_on\n");
3776     fprintf(fp,"$ 'c'\n");
3777     fprintf(fp,"$ perl_status = $STATUS\n");
3778     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3779     fprintf(fp,"$ perl_exit 'perl_status'\n");
3780     fsync(fileno(fp));
3781
3782     fgetname(fp, file, 1);
3783     fstat(fileno(fp), (struct stat *)&s0);
3784     fclose(fp);
3785
3786     if (decc_filename_unix_only)
3787         do_tounixspec(file, file, 0, NULL);
3788     fp = fopen(file,"r","shr=get");
3789     if (!fp) return 0;
3790     fstat(fileno(fp), (struct stat *)&s1);
3791
3792     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3793     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3794         fclose(fp);
3795         return 0;
3796     }
3797
3798     return fp;
3799 }
3800
3801
3802 static int vms_is_syscommand_xterm(void)
3803 {
3804     const static struct dsc$descriptor_s syscommand_dsc =
3805       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3806
3807     const static struct dsc$descriptor_s decwdisplay_dsc =
3808       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3809
3810     struct item_list_3 items[2];
3811     unsigned short dvi_iosb[4];
3812     unsigned long devchar;
3813     unsigned long devclass;
3814     int status;
3815
3816     /* Very simple check to guess if sys$command is a decterm? */
3817     /* First see if the DECW$DISPLAY: device exists */
3818     items[0].len = 4;
3819     items[0].code = DVI$_DEVCHAR;
3820     items[0].bufadr = &devchar;
3821     items[0].retadr = NULL;
3822     items[1].len = 0;
3823     items[1].code = 0;
3824
3825     status = sys$getdviw
3826         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3827
3828     if ($VMS_STATUS_SUCCESS(status)) {
3829         status = dvi_iosb[0];
3830     }
3831
3832     if (!$VMS_STATUS_SUCCESS(status)) {
3833         SETERRNO(EVMSERR, status);
3834         return -1;
3835     }
3836
3837     /* If it does, then for now assume that we are on a workstation */
3838     /* Now verify that SYS$COMMAND is a terminal */
3839     /* for creating the debugger DECTerm */
3840
3841     items[0].len = 4;
3842     items[0].code = DVI$_DEVCLASS;
3843     items[0].bufadr = &devclass;
3844     items[0].retadr = NULL;
3845     items[1].len = 0;
3846     items[1].code = 0;
3847
3848     status = sys$getdviw
3849         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3850
3851     if ($VMS_STATUS_SUCCESS(status)) {
3852         status = dvi_iosb[0];
3853     }
3854
3855     if (!$VMS_STATUS_SUCCESS(status)) {
3856         SETERRNO(EVMSERR, status);
3857         return -1;
3858     }
3859     else {
3860         if (devclass == DC$_TERM) {
3861             return 0;
3862         }
3863     }
3864     return -1;
3865 }
3866
3867 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3868 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3869 {
3870     int status;
3871     int ret_stat;
3872     char * ret_char;
3873     char device_name[65];
3874     unsigned short device_name_len;
3875     struct dsc$descriptor_s customization_dsc;
3876     struct dsc$descriptor_s device_name_dsc;
3877     const char * cptr;
3878     char * tptr;
3879     char customization[200];
3880     char title[40];
3881     pInfo info = NULL;
3882     char mbx1[64];
3883     unsigned short p_chan;
3884     int n;
3885     unsigned short iosb[4];
3886     struct item_list_3 items[2];
3887     const char * cust_str =
3888         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3889     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3890                                           DSC$K_CLASS_S, mbx1};
3891
3892      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3893     /*---------------------------------------*/
3894     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
3895
3896
3897     /* Make sure that this is from the Perl debugger */
3898     ret_char = strstr(cmd," xterm ");
3899     if (ret_char == NULL)
3900         return NULL;
3901     cptr = ret_char + 7;
3902     ret_char = strstr(cmd,"tty");
3903     if (ret_char == NULL)
3904         return NULL;
3905     ret_char = strstr(cmd,"sleep");
3906     if (ret_char == NULL)
3907         return NULL;
3908
3909     if (decw_term_port == 0) {
3910         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3911         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3912         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3913
3914        status = lib$find_image_symbol
3915                                (&filename1_dsc,
3916                                 &decw_term_port_dsc,
3917                                 (void *)&decw_term_port,
3918                                 NULL,
3919                                 0);
3920
3921         /* Try again with the other image name */
3922         if (!$VMS_STATUS_SUCCESS(status)) {
3923
3924            status = lib$find_image_symbol
3925                                (&filename2_dsc,
3926                                 &decw_term_port_dsc,
3927                                 (void *)&decw_term_port,
3928                                 NULL,
3929                                 0);
3930
3931         }
3932
3933     }
3934
3935
3936     /* No decw$term_port, give it up */
3937     if (!$VMS_STATUS_SUCCESS(status))
3938         return NULL;
3939
3940     /* Are we on a workstation? */
3941     /* to do: capture the rows / columns and pass their properties */
3942     ret_stat = vms_is_syscommand_xterm();
3943     if (ret_stat < 0)
3944         return NULL;
3945
3946     /* Make the title: */
3947     ret_char = strstr(cptr,"-title");
3948     if (ret_char != NULL) {
3949         while ((*cptr != 0) && (*cptr != '\"')) {
3950             cptr++;
3951         }
3952         if (*cptr == '\"')
3953             cptr++;
3954         n = 0;
3955         while ((*cptr != 0) && (*cptr != '\"')) {
3956             title[n] = *cptr;
3957             n++;
3958             if (n == 39) {
3959                 title[39] == 0;
3960                 break;
3961             }
3962             cptr++;
3963         }
3964         title[n] = 0;
3965     }
3966     else {
3967             /* Default title */
3968             strcpy(title,"Perl Debug DECTerm");
3969     }
3970     sprintf(customization, cust_str, title);
3971
3972     customization_dsc.dsc$a_pointer = customization;
3973     customization_dsc.dsc$w_length = strlen(customization);
3974     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3975     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3976
3977     device_name_dsc.dsc$a_pointer = device_name;
3978     device_name_dsc.dsc$w_length = sizeof device_name -1;
3979     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3980     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3981
3982     device_name_len = 0;
3983
3984     /* Try to create the window */
3985      status = (*decw_term_port)
3986        (NULL,
3987         NULL,
3988         &customization_dsc,
3989         &device_name_dsc,
3990         &device_name_len,
3991         NULL,
3992         NULL,
3993         NULL);
3994     if (!$VMS_STATUS_SUCCESS(status)) {
3995         SETERRNO(EVMSERR, status);
3996         return NULL;
3997     }
3998
3999     device_name[device_name_len] = '\0';
4000
4001     /* Need to set this up to look like a pipe for cleanup */
4002     n = sizeof(Info);
4003     status = lib$get_vm(&n, &info);
4004     if (!$VMS_STATUS_SUCCESS(status)) {
4005         SETERRNO(ENOMEM, status);
4006         return NULL;
4007     }
4008
4009     info->mode = *mode;
4010     info->done = FALSE;
4011     info->completion = 0;
4012     info->closing    = FALSE;
4013     info->in         = 0;
4014     info->out        = 0;
4015     info->err        = 0;
4016     info->fp         = Nullfp;
4017     info->useFILE    = 0;
4018     info->waiting    = 0;
4019     info->in_done    = TRUE;
4020     info->out_done   = TRUE;
4021     info->err_done   = TRUE;
4022
4023     /* Assign a channel on this so that it will persist, and not login */
4024     /* We stash this channel in the info structure for reference. */
4025     /* The created xterm self destructs when the last channel is removed */
4026     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4027     /* So leave this assigned. */
4028     device_name_dsc.dsc$w_length = device_name_len;
4029     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4030     if (!$VMS_STATUS_SUCCESS(status)) {
4031         SETERRNO(EVMSERR, status);
4032         return NULL;
4033     }
4034     info->xchan_valid = 1;
4035
4036     /* Now create a mailbox to be read by the application */
4037
4038     create_mbx(aTHX_ &p_chan, &d_mbx1);
4039
4040     /* write the name of the created terminal to the mailbox */
4041     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4042             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4043
4044     if (!$VMS_STATUS_SUCCESS(status)) {
4045         SETERRNO(EVMSERR, status);
4046         return NULL;
4047     }
4048
4049     info->fp  = PerlIO_open(mbx1, mode);
4050
4051     /* Done with this channel */
4052     sys$dassgn(p_chan);
4053
4054     /* If any errors, then clean up */
4055     if (!info->fp) {
4056         n = sizeof(Info);
4057         _ckvmssts(lib$free_vm(&n, &info));
4058         return NULL;
4059         }
4060
4061     /* All done */
4062     return info->fp;
4063 }
4064
4065 static PerlIO *
4066 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4067 {
4068     static int handler_set_up = FALSE;
4069     unsigned long int sts, flags = CLI$M_NOWAIT;
4070     /* The use of a GLOBAL table (as was done previously) rendered
4071      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4072      * environment.  Hence we've switched to LOCAL symbol table.
4073      */
4074     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4075     int j, wait = 0, n;
4076     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4077     char *in, *out, *err, mbx[512];
4078     FILE *tpipe = 0;
4079     char tfilebuf[NAM$C_MAXRSS+1];
4080     pInfo info = NULL;
4081     char cmd_sym_name[20];
4082     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4083                                       DSC$K_CLASS_S, symbol};
4084     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4085                                       DSC$K_CLASS_S, 0};
4086     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4087                                       DSC$K_CLASS_S, cmd_sym_name};
4088     struct dsc$descriptor_s *vmscmd;
4089     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4090     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4091     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4092
4093     /* Check here for Xterm create request.  This means looking for
4094      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4095      *  is possible to create an xterm.
4096      */
4097     if (*in_mode == 'r') {
4098         PerlIO * xterm_fd;
4099
4100         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4101         if (xterm_fd != Nullfp)
4102             return xterm_fd;
4103     }
4104
4105     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4106
4107     /* once-per-program initialization...
4108        note that the SETAST calls and the dual test of pipe_ef
4109        makes sure that only the FIRST thread through here does
4110        the initialization...all other threads wait until it's
4111        done.
4112
4113        Yeah, uglier than a pthread call, it's got all the stuff inline
4114        rather than in a separate routine.
4115     */
4116
4117     if (!pipe_ef) {
4118         _ckvmssts(sys$setast(0));
4119         if (!pipe_ef) {
4120             unsigned long int pidcode = JPI$_PID;
4121             $DESCRIPTOR(d_delay, RETRY_DELAY);
4122             _ckvmssts(lib$get_ef(&pipe_ef));
4123             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4124             _ckvmssts(sys$bintim(&d_delay, delaytime));
4125         }
4126         if (!handler_set_up) {
4127           _ckvmssts(sys$dclexh(&pipe_exitblock));
4128           handler_set_up = TRUE;
4129         }
4130         _ckvmssts(sys$setast(1));
4131     }
4132
4133     /* see if we can find a VMSPIPE.COM */
4134
4135     tfilebuf[0] = '@';
4136     vmspipe = find_vmspipe(aTHX);
4137     if (vmspipe) {
4138         strcpy(tfilebuf+1,vmspipe);
4139     } else {        /* uh, oh...we're in tempfile hell */
4140         tpipe = vmspipe_tempfile(aTHX);
4141         if (!tpipe) {       /* a fish popular in Boston */
4142             if (ckWARN(WARN_PIPE)) {
4143                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4144             }
4145         return Nullfp;
4146         }
4147         fgetname(tpipe,tfilebuf+1,1);
4148     }
4149     vmspipedsc.dsc$a_pointer = tfilebuf;
4150     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4151
4152     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4153     if (!(sts & 1)) {
4154       switch (sts) {
4155         case RMS$_FNF:  case RMS$_DNF:
4156           set_errno(ENOENT); break;
4157         case RMS$_DIR:
4158           set_errno(ENOTDIR); break;
4159         case RMS$_DEV:
4160           set_errno(ENODEV); break;
4161         case RMS$_PRV:
4162           set_errno(EACCES); break;
4163         case RMS$_SYN:
4164           set_errno(EINVAL); break;
4165         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4166           set_errno(E2BIG); break;
4167         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4168           _ckvmssts(sts); /* fall through */
4169         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4170           set_errno(EVMSERR);
4171       }
4172       set_vaxc_errno(sts);
4173       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4174         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4175       }
4176       *psts = sts;
4177       return Nullfp;
4178     }
4179     n = sizeof(Info);
4180     _ckvmssts(lib$get_vm(&n, &info));
4181
4182     strcpy(mode,in_mode);
4183     info->mode = *mode;
4184     info->done = FALSE;
4185     info->completion = 0;
4186     info->closing    = FALSE;
4187     info->in         = 0;
4188     info->out        = 0;
4189     info->err        = 0;
4190     info->fp         = Nullfp;
4191     info->useFILE    = 0;
4192     info->waiting    = 0;
4193     info->in_done    = TRUE;
4194     info->out_done   = TRUE;
4195     info->err_done   = TRUE;
4196     info->xchan      = 0;
4197     info->xchan_valid = 0;
4198
4199     in = PerlMem_malloc(VMS_MAXRSS);
4200     if (in == NULL) _ckvmssts(SS$_INSFMEM);
4201     out = PerlMem_malloc(VMS_MAXRSS);
4202     if (out == NULL) _ckvmssts(SS$_INSFMEM);
4203     err = PerlMem_malloc(VMS_MAXRSS);
4204     if (err == NULL) _ckvmssts(SS$_INSFMEM);
4205
4206     in[0] = out[0] = err[0] = '\0';
4207
4208     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4209         info->useFILE = 1;
4210         strcpy(p,p+1);
4211     }
4212     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4213         wait = 1;
4214         strcpy(p,p+1);
4215     }
4216
4217     if (*mode == 'r') {             /* piping from subroutine */
4218
4219         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4220         if (info->out) {
4221             info->out->pipe_done = &info->out_done;
4222             info->out_done = FALSE;
4223             info->out->info = info;
4224         }
4225         if (!info->useFILE) {
4226             info->fp  = PerlIO_open(mbx, mode);
4227         } else {
4228             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4229             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4230         }
4231
4232         if (!info->fp && info->out) {
4233             sys$cancel(info->out->chan_out);
4234
4235             while (!info->out_done) {
4236                 int done;
4237                 _ckvmssts(sys$setast(0));
4238                 done = info->out_done;
4239                 if (!done) _ckvmssts(sys$clref(pipe_ef));
4240                 _ckvmssts(sys$setast(1));
4241                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4242             }
4243
4244             if (info->out->buf) {
4245                 n = info->out->bufsize * sizeof(char);
4246                 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4247             }
4248             n = sizeof(Pipe);
4249             _ckvmssts(lib$free_vm(&n, &info->out));
4250             n = sizeof(Info);
4251             _ckvmssts(lib$free_vm(&n, &info));
4252             *psts = RMS$_FNF;
4253             return Nullfp;
4254         }
4255
4256         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4257         if (info->err) {
4258             info->err->pipe_done = &info->err_done;
4259             info->err_done = FALSE;
4260             info->err->info = info;
4261         }
4262
4263     } else if (*mode == 'w') {      /* piping to subroutine */
4264
4265         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4266         if (info->out) {
4267             info->out->pipe_done = &info->out_done;
4268             info->out_done = FALSE;
4269             info->out->info = info;
4270         }
4271
4272         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4273         if (info->err) {
4274             info->err->pipe_done = &info->err_done;
4275             info->err_done = FALSE;
4276             info->err->info = info;
4277         }
4278
4279         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4280         if (!info->useFILE) {
4281             info->fp  = PerlIO_open(mbx, mode);
4282         } else {
4283             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4284             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4285         }
4286
4287         if (info->in) {
4288             info->in->pipe_done = &info->in_done;
4289             info->in_done = FALSE;
4290             info->in->info = info;
4291         }
4292
4293         /* error cleanup */
4294         if (!info->fp && info->in) {
4295             info->done = TRUE;
4296             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4297                               0, 0, 0, 0, 0, 0, 0, 0));
4298
4299             while (!info->in_done) {
4300                 int done;
4301                 _ckvmssts(sys$setast(0));
4302                 done = info->in_done;
4303                 if (!done) _ckvmssts(sys$clref(pipe_ef));
4304                 _ckvmssts(sys$setast(1));
4305                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4306             }
4307
4308             if (info->in->buf) {
4309                 n = info->in->bufsize * sizeof(char);
4310                 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4311             }
4312             n = sizeof(Pipe);
4313             _ckvmssts(lib$free_vm(&n, &info->in));
4314             n = sizeof(Info);
4315             _ckvmssts(lib$free_vm(&n, &info));
4316             *psts = RMS$_FNF;
4317             return Nullfp;
4318         }
4319
4320
4321     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4322         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), 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
4329         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4330         if (info->err) {
4331             info->err->pipe_done = &info->err_done;
4332             info->err_done = FALSE;
4333             info->err->info = info;
4334         }
4335     }
4336
4337     symbol[MAX_DCL_SYMBOL] = '\0';
4338
4339     strncpy(symbol, in, MAX_DCL_SYMBOL);
4340     d_symbol.dsc$w_length = strlen(symbol);
4341     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4342
4343     strncpy(symbol, err, MAX_DCL_SYMBOL);
4344     d_symbol.dsc$w_length = strlen(symbol);
4345     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4346
4347     strncpy(symbol, out, MAX_DCL_SYMBOL);
4348     d_symbol.dsc$w_length = strlen(symbol);
4349     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4350
4351     /* Done with the names for the pipes */
4352     PerlMem_free(err);
4353     PerlMem_free(out);
4354     PerlMem_free(in);
4355
4356     p = vmscmd->dsc$a_pointer;
4357     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4358     if (*p == '$') p++;                         /* remove leading $ */
4359     while (*p == ' ' || *p == '\t') p++;
4360
4361     for (j = 0; j < 4; j++) {
4362         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4363         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4364
4365     strncpy(symbol, p, MAX_DCL_SYMBOL);
4366     d_symbol.dsc$w_length = strlen(symbol);
4367     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4368
4369         if (strlen(p) > MAX_DCL_SYMBOL) {
4370             p += MAX_DCL_SYMBOL;
4371         } else {
4372             p += strlen(p);
4373         }
4374     }
4375     _ckvmssts(sys$setast(0));
4376     info->next=open_pipes;  /* prepend to list */
4377     open_pipes=info;
4378     _ckvmssts(sys$setast(1));
4379     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4380      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4381      * have SYS$COMMAND if we need it.
4382      */
4383     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4384                       0, &info->pid, &info->completion,
4385                       0, popen_completion_ast,info,0,0,0));
4386
4387     /* if we were using a tempfile, close it now */
4388
4389     if (tpipe) fclose(tpipe);
4390
4391     /* once the subprocess is spawned, it has copied the symbols and
4392        we can get rid of ours */
4393
4394     for (j = 0; j < 4; j++) {
4395         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4396         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4397     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4398     }
4399     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
4400     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4401     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4402     vms_execfree(vmscmd);
4403
4404 #ifdef PERL_IMPLICIT_CONTEXT
4405     if (aTHX)
4406 #endif
4407     PL_forkprocess = info->pid;
4408
4409     if (wait) {
4410          int done = 0;
4411          while (!done) {
4412              _ckvmssts(sys$setast(0));
4413              done = info->done;
4414              if (!done) _ckvmssts(sys$clref(pipe_ef));
4415              _ckvmssts(sys$setast(1));
4416              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4417          }
4418         *psts = info->completion;
4419 /* Caller thinks it is open and tries to close it. */
4420 /* This causes some problems, as it changes the error status */
4421 /*        my_pclose(info->fp); */
4422     } else {
4423         *psts = info->pid;
4424     }
4425     return info->fp;
4426 }  /* end of safe_popen */
4427
4428
4429 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4430 PerlIO *
4431 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4432 {
4433     int sts;
4434     TAINT_ENV();
4435     TAINT_PROPER("popen");
4436     PERL_FLUSHALL_FOR_CHILD;
4437     return safe_popen(aTHX_ cmd,mode,&sts);
4438 }
4439
4440 /*}}}*/
4441
4442 /*{{{  I32 my_pclose(PerlIO *fp)*/
4443 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4444 {
4445     pInfo info, last = NULL;
4446     unsigned long int retsts;
4447     int done, iss, n;
4448     int status;
4449
4450     for (info = open_pipes; info != NULL; last = info, info = info->next)
4451         if (info->fp == fp) break;
4452
4453     if (info == NULL) {  /* no such pipe open */
4454       set_errno(ECHILD); /* quoth POSIX */
4455       set_vaxc_errno(SS$_NONEXPR);
4456       return -1;
4457     }
4458
4459     /* If we were writing to a subprocess, insure that someone reading from
4460      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4461      * produce an EOF record in the mailbox.
4462      *
4463      *  well, at least sometimes it *does*, so we have to watch out for
4464      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4465      */
4466      if (info->fp) {
4467         if (!info->useFILE
4468 #if defined(USE_ITHREADS)
4469           && my_perl
4470 #endif
4471           && PL_perlio_fd_refcnt)
4472             PerlIO_flush(info->fp);
4473         else
4474             fflush((FILE *)info->fp);
4475     }
4476
4477     _ckvmssts(sys$setast(0));
4478      info->closing = TRUE;
4479      done = info->done && info->in_done && info->out_done && info->err_done;
4480      /* hanging on write to Perl's input? cancel it */
4481      if (info->mode == 'r' && info->out && !info->out_done) {
4482         if (info->out->chan_out) {
4483             _ckvmssts(sys$cancel(info->out->chan_out));
4484             if (!info->out->chan_in) {   /* EOF generation, need AST */
4485                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4486             }
4487         }
4488      }
4489      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4490          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4491                            0, 0, 0, 0, 0, 0));
4492     _ckvmssts(sys$setast(1));
4493     if (info->fp) {
4494      if (!info->useFILE
4495 #if defined(USE_ITHREADS)
4496          && my_perl
4497 #endif
4498          && PL_perlio_fd_refcnt)
4499         PerlIO_close(info->fp);
4500      else
4501         fclose((FILE *)info->fp);
4502     }
4503      /*
4504         we have to wait until subprocess completes, but ALSO wait until all
4505         the i/o completes...otherwise we'll be freeing the "info" structure
4506         that the i/o ASTs could still be using...
4507      */
4508
4509      while (!done) {
4510          _ckvmssts(sys$setast(0));
4511          done = info->done && info->in_done && info->out_done && info->err_done;
4512          if (!done) _ckvmssts(sys$clref(pipe_ef));
4513          _ckvmssts(sys$setast(1));
4514          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4515      }
4516      retsts = info->completion;
4517
4518     /* remove from list of open pipes */
4519     _ckvmssts(sys$setast(0));
4520     if (last) last->next = info->next;
4521     else open_pipes = info->next;
4522     _ckvmssts(sys$setast(1));
4523
4524     /* free buffers and structures */
4525
4526     if (info->in) {
4527         if (info->in->buf) {
4528             n = info->in->bufsize * sizeof(char);
4529             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4530         }
4531         n = sizeof(Pipe);
4532         _ckvmssts(lib$free_vm(&n, &info->in));
4533     }
4534     if (info->out) {
4535         if (info->out->buf) {
4536             n = info->out->bufsize * sizeof(char);
4537             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4538         }
4539         n = sizeof(Pipe);
4540         _ckvmssts(lib$free_vm(&n, &info->out));
4541     }
4542     if (info->err) {
4543         if (info->err->buf) {
4544             n = info->err->bufsize * sizeof(char);
4545             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4546         }
4547         n = sizeof(Pipe);
4548         _ckvmssts(lib$free_vm(&n, &info->err));
4549     }
4550     n = sizeof(Info);
4551     _ckvmssts(lib$free_vm(&n, &info));
4552
4553     return retsts;
4554
4555 }  /* end of my_pclose() */
4556
4557 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4558   /* Roll our own prototype because we want this regardless of whether
4559    * _VMS_WAIT is defined.
4560    */
4561   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4562 #endif
4563 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4564    created with popen(); otherwise partially emulate waitpid() unless
4565    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4566    Also check processes not considered by the CRTL waitpid().
4567  */
4568 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4569 Pid_t
4570 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4571 {
4572     pInfo info;
4573     int done;
4574     int sts;
4575     int j;
4576
4577     if (statusp) *statusp = 0;
4578
4579     for (info = open_pipes; info != NULL; info = info->next)
4580         if (info->pid == pid) break;
4581
4582     if (info != NULL) {  /* we know about this child */
4583       while (!info->done) {
4584           _ckvmssts(sys$setast(0));
4585           done = info->done;
4586           if (!done) _ckvmssts(sys$clref(pipe_ef));
4587           _ckvmssts(sys$setast(1));
4588           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4589       }
4590
4591       if (statusp) *statusp = info->completion;
4592       return pid;
4593     }
4594
4595     /* child that already terminated? */
4596
4597     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4598         if (closed_list[j].pid == pid) {
4599             if (statusp) *statusp = closed_list[j].completion;
4600             return pid;
4601         }
4602     }
4603
4604     /* fall through if this child is not one of our own pipe children */
4605
4606 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4607
4608       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4609        * in 7.2 did we get a version that fills in the VMS completion
4610        * status as Perl has always tried to do.
4611        */
4612
4613       sts = __vms_waitpid( pid, statusp, flags );
4614
4615       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4616          return sts;
4617
4618       /* If the real waitpid tells us the child does not exist, we
4619        * fall through here to implement waiting for a child that
4620        * was created by some means other than exec() (say, spawned
4621        * from DCL) or to wait for a process that is not a subprocess
4622        * of the current process.
4623        */
4624
4625 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4626
4627     {
4628       $DESCRIPTOR(intdsc,"0 00:00:01");
4629       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4630       unsigned long int pidcode = JPI$_PID, mypid;
4631       unsigned long int interval[2];
4632       unsigned int jpi_iosb[2];
4633       struct itmlst_3 jpilist[2] = {
4634           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4635           {                      0,         0,                 0, 0}
4636       };
4637
4638       if (pid <= 0) {
4639         /* Sorry folks, we don't presently implement rooting around for
4640            the first child we can find, and we definitely don't want to
4641            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4642          */
4643         set_errno(ENOTSUP);
4644         return -1;
4645       }
4646
4647       /* Get the owner of the child so I can warn if it's not mine. If the
4648        * process doesn't exist or I don't have the privs to look at it,
4649        * I can go home early.
4650        */
4651       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4652       if (sts & 1) sts = jpi_iosb[0];
4653       if (!(sts & 1)) {
4654         switch (sts) {
4655             case SS$_NONEXPR:
4656                 set_errno(ECHILD);
4657                 break;
4658             case SS$_NOPRIV:
4659                 set_errno(EACCES);
4660                 break;
4661             default:
4662                 _ckvmssts(sts);
4663         }
4664         set_vaxc_errno(sts);
4665         return -1;
4666       }
4667
4668       if (ckWARN(WARN_EXEC)) {
4669         /* remind folks they are asking for non-standard waitpid behavior */
4670         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4671         if (ownerpid != mypid)
4672           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4673                       "waitpid: process %x is not a child of process %x",
4674                       pid,mypid);
4675       }
4676
4677       /* simply check on it once a second until it's not there anymore. */
4678
4679       _ckvmssts(sys$bintim(&intdsc,interval));
4680       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4681             _ckvmssts(sys$schdwk(0,0,interval,0));
4682             _ckvmssts(sys$hiber());
4683       }
4684       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4685
4686       _ckvmssts(sts);
4687       return pid;
4688     }
4689 }  /* end of waitpid() */
4690 /*}}}*/
4691 /*}}}*/
4692 /*}}}*/
4693
4694 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4695 char *
4696 my_gconvert(double val, int ndig, int trail, char *buf)
4697 {
4698   static char __gcvtbuf[DBL_DIG+1];
4699   char *loc;
4700
4701   loc = buf ? buf : __gcvtbuf;
4702
4703 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4704   if (val < 1) {
4705     sprintf(loc,"%.*g",ndig,val);
4706     return loc;
4707   }
4708 #endif
4709
4710   if (val) {
4711     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4712     return gcvt(val,ndig,loc);
4713   }
4714   else {
4715     loc[0] = '0'; loc[1] = '\0';
4716     return loc;
4717   }
4718
4719 }
4720 /*}}}*/
4721
4722 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4723 static int rms_free_search_context(struct FAB * fab)
4724 {
4725 struct NAM * nam;
4726
4727     nam = fab->fab$l_nam;
4728     nam->nam$b_nop |= NAM$M_SYNCHK;
4729     nam->nam$l_rlf = NULL;
4730     fab->fab$b_dns = 0;
4731     return sys$parse(fab, NULL, NULL);
4732 }
4733
4734 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4735 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4736 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4737 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4738 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4739 #define rms_nam_esll(nam) nam.nam$b_esl
4740 #define rms_nam_esl(nam) nam.nam$b_esl
4741 #define rms_nam_name(nam) nam.nam$l_name
4742 #define rms_nam_namel(nam) nam.nam$l_name
4743 #define rms_nam_type(nam) nam.nam$l_type
4744 #define rms_nam_typel(nam) nam.nam$l_type
4745 #define rms_nam_ver(nam) nam.nam$l_ver
4746 #define rms_nam_verl(nam) nam.nam$l_ver
4747 #define rms_nam_rsll(nam) nam.nam$b_rsl
4748 #define rms_nam_rsl(nam) nam.nam$b_rsl
4749 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4750 #define rms_set_fna(fab, nam, name, size) \
4751         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4752 #define rms_get_fna(fab, nam) fab.fab$l_fna
4753 #define rms_set_dna(fab, nam, name, size) \
4754         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4755 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4756 #define rms_set_esa(nam, name, size) \
4757         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4758 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4759         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4760 #define rms_set_rsa(nam, name, size) \
4761         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4762 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4763         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4764 #define rms_nam_name_type_l_size(nam) \
4765         (nam.nam$b_name + nam.nam$b_type)
4766 #else
4767 static int rms_free_search_context(struct FAB * fab)
4768 {
4769 struct NAML * nam;
4770
4771     nam = fab->fab$l_naml;
4772     nam->naml$b_nop |= NAM$M_SYNCHK;
4773     nam->naml$l_rlf = NULL;
4774     nam->naml$l_long_defname_size = 0;
4775
4776     fab->fab$b_dns = 0;
4777     return sys$parse(fab, NULL, NULL);
4778 }
4779
4780 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4781 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4782 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4783 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4784 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4785 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4786 #define rms_nam_esl(nam) nam.naml$b_esl
4787 #define rms_nam_name(nam) nam.naml$l_name
4788 #define rms_nam_namel(nam) nam.naml$l_long_name
4789 #define rms_nam_type(nam) nam.naml$l_type
4790 #define rms_nam_typel(nam) nam.naml$l_long_type
4791 #define rms_nam_ver(nam) nam.naml$l_ver
4792 #define rms_nam_verl(nam) nam.naml$l_long_ver
4793 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4794 #define rms_nam_rsl(nam) nam.naml$b_rsl
4795 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4796 #define rms_set_fna(fab, nam, name, size) \
4797         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4798         nam.naml$l_long_filename_size = size; \
4799         nam.naml$l_long_filename = name;}
4800 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4801 #define rms_set_dna(fab, nam, name, size) \
4802         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4803         nam.naml$l_long_defname_size = size; \
4804         nam.naml$l_long_defname = name; }
4805 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4806 #define rms_set_esa(nam, name, size) \
4807         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4808         nam.naml$l_long_expand_alloc = size; \
4809         nam.naml$l_long_expand = name; }
4810 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4811         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4812         nam.naml$l_long_expand = l_name; \
4813         nam.naml$l_long_expand_alloc = l_size; }
4814 #define rms_set_rsa(nam, name, size) \
4815         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4816         nam.naml$l_long_result = name; \
4817         nam.naml$l_long_result_alloc = size; }
4818 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4819         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4820         nam.naml$l_long_result = l_name; \
4821         nam.naml$l_long_result_alloc = l_size; }
4822 #define rms_nam_name_type_l_size(nam) \
4823         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4824 #endif
4825
4826
4827 /* rms_erase
4828  * The CRTL for 8.3 and later can create symbolic links in any mode,
4829  * however in 8.3 the unlink/remove/delete routines will only properly handle
4830  * them if one of the PCP modes is active.
4831  */
4832 static int rms_erase(const char * vmsname)
4833 {
4834   int status;
4835   struct FAB myfab = cc$rms_fab;
4836   rms_setup_nam(mynam);
4837
4838   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4839   rms_bind_fab_nam(myfab, mynam);
4840
4841   /* Are we removing all versions? */
4842   if (vms_unlink_all_versions == 1) {
4843     const char * defspec = ";*";
4844     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4845   }
4846
4847 #ifdef NAML$M_OPEN_SPECIAL
4848   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4849 #endif
4850
4851   status = sys$erase(&myfab, 0, 0);
4852
4853   return status;
4854 }
4855
4856
4857 static int
4858 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4859                     const struct dsc$descriptor_s * vms_dst_dsc,
4860                     unsigned long flags)
4861 {
4862     /*  VMS and UNIX handle file permissions differently and the
4863      * the same ACL trick may be needed for renaming files,
4864      * especially if they are directories.
4865      */
4866
4867    /* todo: get kill_file and rename to share common code */
4868    /* I can not find online documentation for $change_acl
4869     * it appears to be replaced by $set_security some time ago */
4870
4871 const unsigned int access_mode = 0;
4872 $DESCRIPTOR(obj_file_dsc,"FILE");
4873 char *vmsname;
4874 char *rslt;
4875 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
4876 int aclsts, fndsts, rnsts = -1;
4877 unsigned int ctx = 0;
4878 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4879 struct dsc$descriptor_s * clean_dsc;
4880
4881 struct myacedef {
4882     unsigned char myace$b_length;
4883     unsigned char myace$b_type;
4884     unsigned short int myace$w_flags;
4885     unsigned long int myace$l_access;
4886     unsigned long int myace$l_ident;
4887 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
4888              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
4889              0},
4890              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
4891
4892 struct item_list_3
4893         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
4894                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
4895                       {0,0,0,0}},
4896         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
4897         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
4898                      {0,0,0,0}};
4899
4900
4901     /* Expand the input spec using RMS, since we do not want to put
4902      * ACLs on the target of a symbolic link */
4903     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
4904     if (vmsname == NULL)
4905         return SS$_INSFMEM;
4906
4907     rslt = do_rmsexpand(vms_src_dsc->dsc$a_pointer,
4908                         vmsname,
4909                         0,
4910                         NULL,
4911                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
4912                         NULL,
4913                         NULL);
4914     if (rslt == NULL) {
4915         PerlMem_free(vmsname);
4916         return SS$_INSFMEM;
4917     }
4918
4919     /* So we get our own UIC to use as a rights identifier,
4920      * and the insert an ACE at the head of the ACL which allows us
4921      * to delete the file.
4922      */
4923     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
4924
4925     fildsc.dsc$w_length = strlen(vmsname);
4926     fildsc.dsc$a_pointer = vmsname;
4927     ctx = 0;
4928     newace.myace$l_ident = oldace.myace$l_ident;
4929     rnsts = SS$_ABORT;
4930
4931     /* Grab any existing ACEs with this identifier in case we fail */
4932     clean_dsc = &fildsc;
4933     aclsts = fndsts = sys$get_security(&obj_file_dsc,
4934                                &fildsc,
4935                                NULL,
4936                                OSS$M_WLOCK,
4937                                findlst,
4938                                &ctx,
4939                                &access_mode);
4940
4941     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
4942         /* Add the new ACE . . . */
4943
4944         /* if the sys$get_security succeeded, then ctx is valid, and the
4945          * object/file descriptors will be ignored.  But otherwise they
4946          * are needed
4947          */
4948         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
4949                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
4950         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4951             set_errno(EVMSERR);
4952             set_vaxc_errno(aclsts);
4953             PerlMem_free(vmsname);
4954             return aclsts;
4955         }
4956
4957         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
4958                                 NULL, NULL,
4959                                 &flags,
4960                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
4961
4962         if ($VMS_STATUS_SUCCESS(rnsts)) {
4963             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
4964         }
4965
4966         /* Put things back the way they were. */
4967         ctx = 0;
4968         aclsts = sys$get_security(&obj_file_dsc,
4969                                   clean_dsc,
4970                                   NULL,
4971                                   OSS$M_WLOCK,
4972                                   findlst,
4973                                   &ctx,
4974                                   &access_mode);
4975
4976         if ($VMS_STATUS_SUCCESS(aclsts)) {
4977         int sec_flags;
4978
4979             sec_flags = 0;
4980             if (!$VMS_STATUS_SUCCESS(fndsts))
4981                 sec_flags = OSS$M_RELCTX;
4982
4983             /* Get rid of the new ACE */
4984             aclsts = sys$set_security(NULL, NULL, NULL,
4985                                   sec_flags, dellst, &ctx, &access_mode);
4986
4987             /* If there was an old ACE, put it back */
4988             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
4989                 addlst[0].bufadr = &oldace;
4990                 aclsts = sys$set_security(NULL, NULL, NULL,
4991                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
4992                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4993                     set_errno(EVMSERR);
4994                     set_vaxc_errno(aclsts);
4995                     rnsts = aclsts;
4996                 }
4997             } else {
4998             int aclsts2;
4999
5000                 /* Try to clear the lock on the ACL list */
5001                 aclsts2 = sys$set_security(NULL, NULL, NULL,
5002                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
5003
5004                 /* Rename errors are most important */
5005                 if (!$VMS_STATUS_SUCCESS(rnsts))
5006                     aclsts = rnsts;
5007                 set_errno(EVMSERR);
5008                 set_vaxc_errno(aclsts);
5009                 rnsts = aclsts;
5010             }
5011         }
5012         else {
5013             if (aclsts != SS$_ACLEMPTY)
5014                 rnsts = aclsts;
5015         }
5016     }
5017     else
5018         rnsts = fndsts;
5019
5020     PerlMem_free(vmsname);
5021     return rnsts;
5022 }
5023
5024
5025 /*{{{int rename(const char *, const char * */
5026 /* Not exactly what X/Open says to do, but doing it absolutely right
5027  * and efficiently would require a lot more work.  This should be close
5028  * enough to pass all but the most strict X/Open compliance test.
5029  */
5030 int
5031 Perl_rename(pTHX_ const char *src, const char * dst)
5032 {
5033 int retval;
5034 int pre_delete = 0;
5035 int src_sts;
5036 int dst_sts;
5037 Stat_t src_st;
5038 Stat_t dst_st;
5039
5040     /* Validate the source file */
5041     src_sts = flex_lstat(src, &src_st);
5042     if (src_sts != 0) {
5043
5044         /* No source file or other problem */
5045         return src_sts;
5046     }
5047
5048     dst_sts = flex_lstat(dst, &dst_st);
5049     if (dst_sts == 0) {
5050
5051         if (dst_st.st_dev != src_st.st_dev) {
5052             /* Must be on the same device */
5053             errno = EXDEV;
5054             return -1;
5055         }
5056
5057         /* VMS_INO_T_COMPARE is true if the inodes are different
5058          * to match the output of memcmp
5059          */
5060
5061         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5062             /* That was easy, the files are the same! */
5063             return 0;
5064         }
5065
5066         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5067             /* If source is a directory, so must be dest */
5068                 errno = EISDIR;
5069                 return -1;
5070         }
5071
5072     }
5073
5074
5075     if ((dst_sts == 0) &&
5076         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5077
5078         /* We have issues here if vms_unlink_all_versions is set
5079          * If the destination exists, and is not a directory, then
5080          * we must delete in advance.
5081          *
5082          * If the src is a directory, then we must always pre-delete
5083          * the destination.
5084          *
5085          * If we successfully delete the dst in advance, and the rename fails
5086          * X/Open requires that errno be EIO.
5087          *
5088          */
5089
5090         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5091             int d_sts;
5092             d_sts = mp_do_kill_file(aTHX_ dst, S_ISDIR(dst_st.st_mode));
5093             if (d_sts != 0)
5094                 return d_sts;
5095
5096             /* We killed the destination, so only errno now is EIO */
5097             pre_delete = 1;
5098         }
5099     }
5100
5101     /* Originally the idea was to call the CRTL rename() and only
5102      * try the lib$rename_file if it failed.
5103      * It turns out that there are too many variants in what the
5104      * the CRTL rename might do, so only use lib$rename_file
5105      */
5106     retval = -1;
5107
5108     {
5109         /* Is the source and dest both in VMS format */
5110         /* if the source is a directory, then need to fileify */
5111         /*  and dest must be a directory or non-existant. */
5112
5113         char * vms_src;
5114         char * vms_dst;
5115         int sts;
5116         char * ret_str;
5117         unsigned long flags;
5118         struct dsc$descriptor_s old_file_dsc;
5119         struct dsc$descriptor_s new_file_dsc;
5120
5121         /* We need to modify the src and dst depending
5122          * on if one or more of them are directories.
5123          */
5124
5125         vms_src = PerlMem_malloc(VMS_MAXRSS);
5126         if (vms_src == NULL)
5127             _ckvmssts(SS$_INSFMEM);
5128
5129         /* Source is always a VMS format file */
5130         ret_str = do_tovmsspec(src, vms_src, 0, NULL);
5131         if (ret_str == NULL) {
5132             PerlMem_free(vms_src);
5133             errno = EIO;
5134             return -1;
5135         }
5136
5137         vms_dst = PerlMem_malloc(VMS_MAXRSS);
5138         if (vms_dst == NULL)
5139             _ckvmssts(SS$_INSFMEM);
5140
5141         if (S_ISDIR(src_st.st_mode)) {
5142         char * ret_str;
5143         char * vms_dir_file;
5144
5145             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5146             if (vms_dir_file == NULL)
5147                 _ckvmssts(SS$_INSFMEM);
5148
5149             /* The source must be a file specification */
5150             ret_str = do_fileify_dirspec(vms_src, vms_dir_file, 0, NULL);
5151             if (ret_str == NULL) {
5152                 PerlMem_free(vms_src);
5153                 PerlMem_free(vms_dst);
5154                 PerlMem_free(vms_dir_file);
5155                 errno = EIO;
5156                 return -1;
5157             }
5158             PerlMem_free(vms_src);
5159             vms_src = vms_dir_file;
5160
5161             /* If the dest is a directory, we must remove it
5162             if (dst_sts == 0) {
5163                 int d_sts;
5164                 d_sts = mp_do_kill_file(aTHX_ dst, 1);
5165                 if (d_sts != 0) {
5166                     PerlMem_free(vms_src);
5167                     PerlMem_free(vms_dst);
5168                     errno = EIO;
5169                     return sts;
5170                 }
5171
5172                 pre_delete = 1;
5173             }
5174
5175            /* The dest must be a VMS file specification */
5176            ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
5177            if (ret_str == NULL) {
5178                 PerlMem_free(vms_src);
5179                 PerlMem_free(vms_dst);
5180                 errno = EIO;
5181                 return -1;
5182            }
5183
5184             /* The source must be a file specification */
5185             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5186             if (vms_dir_file == NULL)
5187                 _ckvmssts(SS$_INSFMEM);
5188
5189             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5190             if (ret_str == NULL) {
5191                 PerlMem_free(vms_src);
5192                 PerlMem_free(vms_dst);
5193                 PerlMem_free(vms_dir_file);
5194                 errno = EIO;
5195                 return -1;
5196             }
5197             PerlMem_free(vms_dst);
5198             vms_dst = vms_dir_file;
5199
5200         } else {
5201             /* File to file or file to new dir */
5202
5203             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5204                 /* VMS pathify a dir target */
5205                 ret_str = do_tovmspath(dst, vms_dst, 0, NULL);
5206                 if (ret_str == NULL) {
5207                     PerlMem_free(vms_src);
5208                     PerlMem_free(vms_dst);
5209                     errno = EIO;
5210                     return -1;
5211                 }
5212             } else {
5213
5214                 /* fileify a target VMS file specification */
5215                 ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
5216                 if (ret_str == NULL) {
5217                     PerlMem_free(vms_src);
5218                     PerlMem_free(vms_dst);
5219                     errno = EIO;
5220                     return -1;
5221                 }
5222             }
5223         }
5224
5225         old_file_dsc.dsc$a_pointer = vms_src;
5226         old_file_dsc.dsc$w_length = strlen(vms_src);
5227         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5228         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5229
5230         new_file_dsc.dsc$a_pointer = vms_dst;
5231         new_file_dsc.dsc$w_length = strlen(vms_dst);
5232         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5233         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5234
5235         flags = 0;
5236 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5237         flags |= 2; /* LIB$M_FIL_LONG_NAMES */
5238 #endif
5239
5240         sts = lib$rename_file(&old_file_dsc,
5241                               &new_file_dsc,
5242                               NULL, NULL,
5243                               &flags,
5244                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5245         if (!$VMS_STATUS_SUCCESS(sts)) {
5246
5247            /* We could have failed because VMS style permissions do not
5248             * permit renames that UNIX will allow.  Just like the hack
5249             * in for kill_file.
5250             */
5251            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5252         }
5253
5254         PerlMem_free(vms_src);
5255         PerlMem_free(vms_dst);
5256         if (!$VMS_STATUS_SUCCESS(sts)) {
5257             errno = EIO;
5258             return -1;
5259         }
5260         retval = 0;
5261     }
5262
5263     if (vms_unlink_all_versions) {
5264         /* Now get rid of any previous versions of the source file that
5265          * might still exist
5266          */
5267         int save_errno;
5268         save_errno = errno;
5269         src_sts = mp_do_kill_file(aTHX_ src, S_ISDIR(src_st.st_mode));
5270         errno = save_errno;
5271     }
5272
5273     /* We deleted the destination, so must force the error to be EIO */
5274     if ((retval != 0) && (pre_delete != 0))
5275         errno = EIO;
5276
5277     return retval;
5278 }
5279 /*}}}*/
5280
5281
5282 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5283 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5284  * to expand file specification.  Allows for a single default file
5285  * specification and a simple mask of options.  If outbuf is non-NULL,
5286  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5287  * the resultant file specification is placed.  If outbuf is NULL, the
5288  * resultant file specification is placed into a static buffer.
5289  * The third argument, if non-NULL, is taken to be a default file
5290  * specification string.  The fourth argument is unused at present.
5291  * rmesexpand() returns the address of the resultant string if
5292  * successful, and NULL on error.
5293  *
5294  * New functionality for previously unused opts value:
5295  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5296  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5297  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5298  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5299  */
5300 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5301
5302 static char *
5303 mp_do_rmsexpand
5304    (pTHX_ const char *filespec,
5305     char *outbuf,
5306     int ts,
5307     const char *defspec,
5308     unsigned opts,
5309     int * fs_utf8,
5310     int * dfs_utf8)
5311 {
5312   static char __rmsexpand_retbuf[VMS_MAXRSS];
5313   char * vmsfspec, *tmpfspec;
5314   char * esa, *cp, *out = NULL;
5315   char * tbuf;
5316   char * esal = NULL;
5317   char * outbufl;
5318   struct FAB myfab = cc$rms_fab;
5319   rms_setup_nam(mynam);
5320   STRLEN speclen;
5321   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5322   int sts;
5323
5324   /* temp hack until UTF8 is actually implemented */
5325   if (fs_utf8 != NULL)
5326     *fs_utf8 = 0;
5327
5328   if (!filespec || !*filespec) {
5329     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5330     return NULL;
5331   }
5332   if (!outbuf) {
5333     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
5334     else    outbuf = __rmsexpand_retbuf;
5335   }
5336
5337   vmsfspec = NULL;
5338   tmpfspec = NULL;
5339   outbufl = NULL;
5340
5341   isunix = 0;
5342   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5343     isunix = is_unix_filespec(filespec);
5344     if (isunix) {
5345       vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5346       if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
5347       if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
5348         PerlMem_free(vmsfspec);
5349         if (out)
5350            Safefree(out);
5351         return NULL;
5352       }
5353       filespec = vmsfspec;
5354
5355       /* Unless we are forcing to VMS format, a UNIX input means
5356        * UNIX output, and that requires long names to be used
5357        */
5358 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5359       if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5360         opts |= PERL_RMSEXPAND_M_LONG;
5361       else
5362 #endif
5363         isunix = 0;
5364       }
5365     }
5366
5367   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
5368   rms_bind_fab_nam(myfab, mynam);
5369
5370   if (defspec && *defspec) {
5371     int t_isunix;
5372     t_isunix = is_unix_filespec(defspec);
5373     if (t_isunix) {
5374       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5375       if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5376       if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
5377         PerlMem_free(tmpfspec);
5378         if (vmsfspec != NULL)
5379             PerlMem_free(vmsfspec);
5380         if (out)
5381            Safefree(out);
5382         return NULL;
5383       }
5384       defspec = tmpfspec;
5385     }
5386     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
5387   }
5388
5389   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5390   if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5391 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5392   esal = PerlMem_malloc(VMS_MAXRSS);
5393   if (esal == NULL) _ckvmssts(SS$_INSFMEM);
5394 #endif
5395   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5396
5397   /* If a NAML block is used RMS always writes to the long and short
5398    * addresses unless you suppress the short name.
5399    */
5400 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5401   outbufl = PerlMem_malloc(VMS_MAXRSS);
5402   if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
5403 #endif
5404    rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5405
5406 #ifdef NAM$M_NO_SHORT_UPCASE
5407   if (decc_efs_case_preserve)
5408     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5409 #endif
5410
5411    /* We may not want to follow symbolic links */
5412 #ifdef NAML$M_OPEN_SPECIAL
5413   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5414     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5415 #endif
5416
5417   /* First attempt to parse as an existing file */
5418   retsts = sys$parse(&myfab,0,0);
5419   if (!(retsts & STS$K_SUCCESS)) {
5420
5421     /* Could not find the file, try as syntax only if error is not fatal */
5422     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5423     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
5424       retsts = sys$parse(&myfab,0,0);
5425       if (retsts & STS$K_SUCCESS) goto expanded;
5426     }
5427
5428      /* Still could not parse the file specification */
5429     /*----------------------------------------------*/
5430     sts = rms_free_search_context(&myfab); /* Free search context */
5431     if (out) Safefree(out);
5432     if (tmpfspec != NULL)
5433         PerlMem_free(tmpfspec);
5434     if (vmsfspec != NULL)
5435         PerlMem_free(vmsfspec);
5436     if (outbufl != NULL)
5437         PerlMem_free(outbufl);
5438     PerlMem_free(esa);
5439     if (esal != NULL)
5440         PerlMem_free(esal);
5441     set_vaxc_errno(retsts);
5442     if      (retsts == RMS$_PRV) set_errno(EACCES);
5443     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5444     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5445     else                         set_errno(EVMSERR);
5446     return NULL;
5447   }
5448   retsts = sys$search(&myfab,0,0);
5449   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5450     sts = rms_free_search_context(&myfab); /* Free search context */
5451     if (out) Safefree(out);
5452     if (tmpfspec != NULL)
5453         PerlMem_free(tmpfspec);
5454     if (vmsfspec != NULL)
5455         PerlMem_free(vmsfspec);
5456     if (outbufl != NULL)
5457         PerlMem_free(outbufl);
5458     PerlMem_free(esa);
5459     if (esal != NULL)
5460         PerlMem_free(esal);
5461     set_vaxc_errno(retsts);
5462     if      (retsts == RMS$_PRV) set_errno(EACCES);
5463     else                         set_errno(EVMSERR);
5464     return NULL;
5465   }
5466
5467   /* If the input filespec contained any lowercase characters,
5468    * downcase the result for compatibility with Unix-minded code. */
5469   expanded:
5470   if (!decc_efs_case_preserve) {
5471     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5472       if (islower(*tbuf)) { haslower = 1; break; }
5473   }
5474
5475    /* Is a long or a short name expected */
5476   /*------------------------------------*/
5477   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5478     if (rms_nam_rsll(mynam)) {
5479         tbuf = outbufl;
5480         speclen = rms_nam_rsll(mynam);
5481     }
5482     else {
5483         tbuf = esal; /* Not esa */
5484         speclen = rms_nam_esll(mynam);
5485     }
5486   }
5487   else {
5488     if (rms_nam_rsl(mynam)) {
5489         tbuf = outbuf;
5490         speclen = rms_nam_rsl(mynam);
5491     }
5492     else {
5493         tbuf = esa; /* Not esal */
5494         speclen = rms_nam_esl(mynam);
5495     }
5496   }
5497   tbuf[speclen] = '\0';
5498
5499   /* Trim off null fields added by $PARSE
5500    * If type > 1 char, must have been specified in original or default spec
5501    * (not true for version; $SEARCH may have added version of existing file).
5502    */
5503   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5504   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5505     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5506              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5507   }
5508   else {
5509     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5510              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5511   }
5512   if (trimver || trimtype) {
5513     if (defspec && *defspec) {
5514       char *defesal = NULL;
5515       char *defesa = NULL;
5516       defesa = PerlMem_malloc(VMS_MAXRSS + 1);
5517       if (defesa != NULL) {
5518 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5519         defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5520         if (defesal == NULL) _ckvmssts(SS$_INSFMEM);
5521 #endif
5522         struct FAB deffab = cc$rms_fab;
5523         rms_setup_nam(defnam);
5524
5525         rms_bind_fab_nam(deffab, defnam);
5526
5527         /* Cast ok */
5528         rms_set_fna
5529             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5530
5531         /* RMS needs the esa/esal as a work area if wildcards are involved */
5532         rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5533
5534         rms_clear_nam_nop(defnam);
5535         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5536 #ifdef NAM$M_NO_SHORT_UPCASE
5537         if (decc_efs_case_preserve)
5538           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5539 #endif
5540 #ifdef NAML$M_OPEN_SPECIAL
5541         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5542           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5543 #endif
5544         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5545           if (trimver) {
5546              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5547           }
5548           if (trimtype) {
5549             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5550           }
5551         }
5552         if (defesal != NULL)
5553             PerlMem_free(defesal);
5554         PerlMem_free(defesa);
5555       }
5556     }
5557     if (trimver) {
5558       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5559         if (*(rms_nam_verl(mynam)) != '\"')
5560           speclen = rms_nam_verl(mynam) - tbuf;
5561       }
5562       else {
5563         if (*(rms_nam_ver(mynam)) != '\"')
5564           speclen = rms_nam_ver(mynam) - tbuf;
5565       }
5566     }
5567     if (trimtype) {
5568       /* If we didn't already trim version, copy down */
5569       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5570         if (speclen > rms_nam_verl(mynam) - tbuf)
5571           memmove
5572            (rms_nam_typel(mynam),
5573             rms_nam_verl(mynam),
5574             speclen - (rms_nam_verl(mynam) - tbuf));
5575           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5576       }
5577       else {
5578         if (speclen > rms_nam_ver(mynam) - tbuf)
5579           memmove
5580            (rms_nam_type(mynam),
5581             rms_nam_ver(mynam),
5582             speclen - (rms_nam_ver(mynam) - tbuf));
5583           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5584       }
5585     }
5586   }
5587
5588    /* Done with these copies of the input files */
5589   /*-------------------------------------------*/
5590   if (vmsfspec != NULL)
5591         PerlMem_free(vmsfspec);
5592   if (tmpfspec != NULL)
5593         PerlMem_free(tmpfspec);
5594
5595   /* If we just had a directory spec on input, $PARSE "helpfully"
5596    * adds an empty name and type for us */
5597 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5598   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5599     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5600         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5601         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5602       speclen = rms_nam_namel(mynam) - tbuf;
5603   }
5604   else
5605 #endif
5606   {
5607     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5608         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5609         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5610       speclen = rms_nam_name(mynam) - tbuf;
5611   }
5612
5613   /* Posix format specifications must have matching quotes */
5614   if (speclen < (VMS_MAXRSS - 1)) {
5615     if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
5616       if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
5617         tbuf[speclen] = '\"';
5618         speclen++;
5619       }
5620     }
5621   }
5622   tbuf[speclen] = '\0';
5623   if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
5624
5625   /* Have we been working with an expanded, but not resultant, spec? */
5626   /* Also, convert back to Unix syntax if necessary. */
5627   {
5628   int rsl;
5629
5630 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5631     if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5632       rsl = rms_nam_rsll(mynam);
5633     } else
5634 #endif
5635     {
5636       rsl = rms_nam_rsl(mynam);
5637     }
5638     if (!rsl) {
5639       if (isunix) {
5640         if (do_tounixspec(tbuf, outbuf ,0 , fs_utf8) == NULL) {
5641           if (out) Safefree(out);
5642           if (esal != NULL)
5643             PerlMem_free(esal);
5644           PerlMem_free(esa);
5645           if (outbufl != NULL)
5646             PerlMem_free(outbufl);
5647           return NULL;
5648         }
5649       }
5650       else strcpy(outbuf, tbuf);
5651     }
5652     else if (isunix) {
5653       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5654       if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5655       if (do_tounixspec(tbuf,tmpfspec,0,fs_utf8) == NULL) {
5656         if (out) Safefree(out);
5657         PerlMem_free(esa);
5658         if (esal != NULL)
5659             PerlMem_free(esal);
5660         PerlMem_free(tmpfspec);
5661         if (outbufl != NULL)
5662             PerlMem_free(outbufl);
5663         return NULL;
5664       }
5665       strcpy(outbuf,tmpfspec);
5666       PerlMem_free(tmpfspec);
5667     }
5668   }
5669   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5670   sts = rms_free_search_context(&myfab); /* Free search context */
5671   PerlMem_free(esa);
5672   if (esal != NULL)
5673      PerlMem_free(esal);
5674   if (outbufl != NULL)
5675      PerlMem_free(outbufl);
5676   return outbuf;
5677 }
5678 /*}}}*/
5679 /* External entry points */
5680 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5681 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5682 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5683 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5684 char *Perl_rmsexpand_utf8
5685   (pTHX_ const char *spec, char *buf, const char *def,
5686    unsigned opt, int * fs_utf8, int * dfs_utf8)
5687 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5688 char *Perl_rmsexpand_utf8_ts
5689   (pTHX_ const char *spec, char *buf, const char *def,
5690    unsigned opt, int * fs_utf8, int * dfs_utf8)
5691 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5692
5693
5694 /*
5695 ** The following routines are provided to make life easier when
5696 ** converting among VMS-style and Unix-style directory specifications.
5697 ** All will take input specifications in either VMS or Unix syntax. On
5698 ** failure, all return NULL.  If successful, the routines listed below
5699 ** return a pointer to a buffer containing the appropriately
5700 ** reformatted spec (and, therefore, subsequent calls to that routine
5701 ** will clobber the result), while the routines of the same names with
5702 ** a _ts suffix appended will return a pointer to a mallocd string
5703 ** containing the appropriately reformatted spec.
5704 ** In all cases, only explicit syntax is altered; no check is made that
5705 ** the resulting string is valid or that the directory in question
5706 ** actually exists.
5707 **
5708 **   fileify_dirspec() - convert a directory spec into the name of the
5709 **     directory file (i.e. what you can stat() to see if it's a dir).
5710 **     The style (VMS or Unix) of the result is the same as the style
5711 **     of the parameter passed in.
5712 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5713 **     what you prepend to a filename to indicate what directory it's in).
5714 **     The style (VMS or Unix) of the result is the same as the style
5715 **     of the parameter passed in.
5716 **   tounixpath() - convert a directory spec into a Unix-style path.
5717 **   tovmspath() - convert a directory spec into a VMS-style path.
5718 **   tounixspec() - convert any file spec into a Unix-style file spec.
5719 **   tovmsspec() - convert any file spec into a VMS-style spec.
5720 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5721 **
5722 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5723 ** Permission is given to distribute this code as part of the Perl
5724 ** standard distribution under the terms of the GNU General Public
5725 ** License or the Perl Artistic License.  Copies of each may be
5726 ** found in the Perl standard distribution.
5727  */
5728
5729 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5730 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
5731 {
5732     static char __fileify_retbuf[VMS_MAXRSS];
5733     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5734     char *retspec, *cp1, *cp2, *lastdir;
5735     char *trndir, *vmsdir;
5736     unsigned short int trnlnm_iter_count;
5737     int sts;
5738     if (utf8_fl != NULL)
5739         *utf8_fl = 0;
5740
5741     if (!dir || !*dir) {
5742       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5743     }
5744     dirlen = strlen(dir);
5745     while (dirlen && dir[dirlen-1] == '/') --dirlen;
5746     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5747       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5748         dir = "/sys$disk";
5749         dirlen = 9;
5750       }
5751       else
5752         dirlen = 1;
5753     }
5754     if (dirlen > (VMS_MAXRSS - 1)) {
5755       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5756       return NULL;
5757     }
5758     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
5759     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5760     if (!strpbrk(dir+1,"/]>:")  &&
5761         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5762       strcpy(trndir,*dir == '/' ? dir + 1: dir);
5763       trnlnm_iter_count = 0;
5764       while (!strpbrk(trndir,"/]>:") && my_trnlnm(trndir,trndir,0)) {
5765         trnlnm_iter_count++;
5766         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5767       }
5768       dirlen = strlen(trndir);
5769     }
5770     else {
5771       strncpy(trndir,dir,dirlen);
5772       trndir[dirlen] = '\0';
5773     }
5774
5775     /* At this point we are done with *dir and use *trndir which is a
5776      * copy that can be modified.  *dir must not be modified.
5777      */
5778
5779     /* If we were handed a rooted logical name or spec, treat it like a
5780      * simple directory, so that
5781      *    $ Define myroot dev:[dir.]
5782      *    ... do_fileify_dirspec("myroot",buf,1) ...
5783      * does something useful.
5784      */
5785     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5786       trndir[--dirlen] = '\0';
5787       trndir[dirlen-1] = ']';
5788     }
5789     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5790       trndir[--dirlen] = '\0';
5791       trndir[dirlen-1] = '>';
5792     }
5793
5794     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5795       /* If we've got an explicit filename, we can just shuffle the string. */
5796       if (*(cp1+1)) hasfilename = 1;
5797       /* Similarly, we can just back up a level if we've got multiple levels
5798          of explicit directories in a VMS spec which ends with directories. */
5799       else {
5800         for (cp2 = cp1; cp2 > trndir; cp2--) {
5801           if (*cp2 == '.') {
5802             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5803 /* fix-me, can not scan EFS file specs backward like this */
5804               *cp2 = *cp1; *cp1 = '\0';
5805               hasfilename = 1;
5806               break;
5807             }
5808           }
5809           if (*cp2 == '[' || *cp2 == '<') break;
5810         }
5811       }
5812     }
5813
5814     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
5815     if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
5816     cp1 = strpbrk(trndir,"]:>");
5817     if (hasfilename || !cp1) { /* Unix-style path or filename */
5818       if (trndir[0] == '.') {
5819         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5820           PerlMem_free(trndir);
5821           PerlMem_free(vmsdir);
5822           return do_fileify_dirspec("[]",buf,ts,NULL);
5823         }
5824         else if (trndir[1] == '.' &&
5825                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5826           PerlMem_free(trndir);
5827           PerlMem_free(vmsdir);
5828           return do_fileify_dirspec("[-]",buf,ts,NULL);
5829         }
5830       }
5831       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
5832         dirlen -= 1;                 /* to last element */
5833         lastdir = strrchr(trndir,'/');
5834       }
5835       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
5836         /* If we have "/." or "/..", VMSify it and let the VMS code
5837          * below expand it, rather than repeating the code to handle
5838          * relative components of a filespec here */
5839         do {
5840           if (*(cp1+2) == '.') cp1++;
5841           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
5842             char * ret_chr;
5843             if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5844                 PerlMem_free(trndir);
5845                 PerlMem_free(vmsdir);
5846                 return NULL;
5847             }
5848             if (strchr(vmsdir,'/') != NULL) {
5849               /* If do_tovmsspec() returned it, it must have VMS syntax
5850                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
5851                * the time to check this here only so we avoid a recursion
5852                * loop; otherwise, gigo.
5853                */
5854               PerlMem_free(trndir);
5855               PerlMem_free(vmsdir);
5856               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
5857               return NULL;
5858             }
5859             if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5860                 PerlMem_free(trndir);
5861                 PerlMem_free(vmsdir);
5862                 return NULL;
5863             }
5864             ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5865             PerlMem_free(trndir);
5866             PerlMem_free(vmsdir);
5867             return ret_chr;
5868           }
5869           cp1++;
5870         } while ((cp1 = strstr(cp1,"/.")) != NULL);
5871         lastdir = strrchr(trndir,'/');
5872       }
5873       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5874         char * ret_chr;
5875         /* Ditto for specs that end in an MFD -- let the VMS code
5876          * figure out whether it's a real device or a rooted logical. */
5877
5878         /* This should not happen any more.  Allowing the fake /000000
5879          * in a UNIX pathname causes all sorts of problems when trying
5880          * to run in UNIX emulation.  So the VMS to UNIX conversions
5881          * now remove the fake /000000 directories.
5882          */
5883
5884         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5885         if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5886             PerlMem_free(trndir);
5887             PerlMem_free(vmsdir);
5888             return NULL;
5889         }
5890         if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5891             PerlMem_free(trndir);
5892             PerlMem_free(vmsdir);
5893             return NULL;
5894         }
5895         ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5896         PerlMem_free(trndir);
5897         PerlMem_free(vmsdir);
5898         return ret_chr;
5899       }
5900       else {
5901
5902         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5903              !(lastdir = cp1 = strrchr(trndir,']')) &&
5904              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5905         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
5906           int ver; char *cp3;
5907
5908           /* For EFS or ODS-5 look for the last dot */
5909           if (decc_efs_charset) {
5910               cp2 = strrchr(cp1,'.');
5911           }
5912           if (vms_process_case_tolerant) {
5913               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5914                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5915                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5916                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5917                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5918                             (ver || *cp3)))))) {
5919                   PerlMem_free(trndir);
5920                   PerlMem_free(vmsdir);
5921                   set_errno(ENOTDIR);
5922                   set_vaxc_errno(RMS$_DIR);
5923                   return NULL;
5924               }
5925           }
5926           else {
5927               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5928                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5929                   !*(cp2+3) || *(cp2+3) != 'R' ||
5930                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5931                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5932                             (ver || *cp3)))))) {
5933                  PerlMem_free(trndir);
5934                  PerlMem_free(vmsdir);
5935                  set_errno(ENOTDIR);
5936                  set_vaxc_errno(RMS$_DIR);
5937                  return NULL;
5938               }
5939           }
5940           dirlen = cp2 - trndir;
5941         }
5942       }
5943
5944       retlen = dirlen + 6;
5945       if (buf) retspec = buf;
5946       else if (ts) Newx(retspec,retlen+1,char);
5947       else retspec = __fileify_retbuf;
5948       memcpy(retspec,trndir,dirlen);
5949       retspec[dirlen] = '\0';
5950
5951       /* We've picked up everything up to the directory file name.
5952          Now just add the type and version, and we're set. */
5953       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5954         strcat(retspec,".dir;1");
5955       else
5956         strcat(retspec,".DIR;1");
5957       PerlMem_free(trndir);
5958       PerlMem_free(vmsdir);
5959       return retspec;
5960     }
5961     else {  /* VMS-style directory spec */
5962
5963       char *esa, *esal, term, *cp;
5964       char *my_esa;
5965       int my_esa_len;
5966       unsigned long int sts, cmplen, haslower = 0;
5967       unsigned int nam_fnb;
5968       char * nam_type;
5969       struct FAB dirfab = cc$rms_fab;
5970       rms_setup_nam(savnam);
5971       rms_setup_nam(dirnam);
5972
5973       esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5974       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5975       esal = NULL;
5976 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5977       esal = PerlMem_malloc(VMS_MAXRSS);
5978       if (esal == NULL) _ckvmssts(SS$_INSFMEM);
5979 #endif
5980       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5981       rms_bind_fab_nam(dirfab, dirnam);
5982       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5983       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
5984 #ifdef NAM$M_NO_SHORT_UPCASE
5985       if (decc_efs_case_preserve)
5986         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5987 #endif
5988
5989       for (cp = trndir; *cp; cp++)
5990         if (islower(*cp)) { haslower = 1; break; }
5991       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5992         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5993           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5994           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5995         }
5996         if (!sts) {
5997           PerlMem_free(esa);
5998           if (esal != NULL)
5999               PerlMem_free(esal);
6000           PerlMem_free(trndir);
6001           PerlMem_free(vmsdir);
6002           set_errno(EVMSERR);
6003           set_vaxc_errno(dirfab.fab$l_sts);
6004           return NULL;
6005         }
6006       }
6007       else {
6008         savnam = dirnam;
6009         /* Does the file really exist? */
6010         if (sys$search(&dirfab)& STS$K_SUCCESS) {
6011           /* Yes; fake the fnb bits so we'll check type below */
6012         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6013         }
6014         else { /* No; just work with potential name */
6015           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6016           else {
6017             int fab_sts;
6018             fab_sts = dirfab.fab$l_sts;
6019             sts = rms_free_search_context(&dirfab);
6020             PerlMem_free(esa);
6021             if (esal != NULL)
6022                 PerlMem_free(esal);
6023             PerlMem_free(trndir);
6024             PerlMem_free(vmsdir);
6025             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
6026             return NULL;
6027           }
6028         }
6029       }
6030
6031       /* Make sure we are using the right buffer */
6032       if (esal != NULL) {
6033         my_esa = esal;
6034         my_esa_len = rms_nam_esll(dirnam);
6035       } else {
6036         my_esa = esa;
6037         my_esa_len = rms_nam_esl(dirnam);
6038       }
6039       my_esa[my_esa_len] = '\0';
6040       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6041         cp1 = strchr(my_esa,']');
6042         if (!cp1) cp1 = strchr(my_esa,'>');
6043         if (cp1) {  /* Should always be true */
6044           my_esa_len -= cp1 - my_esa - 1;
6045           memmove(my_esa, cp1 + 1, my_esa_len);
6046         }
6047       }
6048       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6049         /* Yep; check version while we're at it, if it's there. */
6050         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6051         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6052           /* Something other than .DIR[;1].  Bzzt. */
6053           sts = rms_free_search_context(&dirfab);
6054           PerlMem_free(esa);
6055           if (esal != NULL)
6056              PerlMem_free(esal);
6057           PerlMem_free(trndir);
6058           PerlMem_free(vmsdir);
6059           set_errno(ENOTDIR);
6060           set_vaxc_errno(RMS$_DIR);
6061           return NULL;
6062         }
6063       }
6064
6065       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6066         /* They provided at least the name; we added the type, if necessary, */
6067         if (buf) retspec = buf;                            /* in sys$parse() */
6068         else if (ts) Newx(retspec, my_esa_len + 1, char);
6069         else retspec = __fileify_retbuf;
6070         strcpy(retspec,my_esa);
6071         sts = rms_free_search_context(&dirfab);
6072         PerlMem_free(trndir);
6073         PerlMem_free(esa);
6074         if (esal != NULL)
6075             PerlMem_free(esal);
6076         PerlMem_free(vmsdir);
6077         return retspec;
6078       }
6079       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6080         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6081         *cp1 = '\0';
6082         my_esa_len -= 9;
6083       }
6084       if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6085       if (cp1 == NULL) { /* should never happen */
6086         sts = rms_free_search_context(&dirfab);
6087         PerlMem_free(trndir);
6088         PerlMem_free(esa);
6089         if (esal != NULL)
6090             PerlMem_free(esal);
6091         PerlMem_free(vmsdir);
6092         return NULL;
6093       }
6094       term = *cp1;
6095       *cp1 = '\0';
6096       retlen = strlen(my_esa);
6097       cp1 = strrchr(my_esa,'.');
6098       /* ODS-5 directory specifications can have extra "." in them. */
6099       /* Fix-me, can not scan EFS file specifications backwards */
6100       while (cp1 != NULL) {
6101         if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6102           break;
6103         else {
6104            cp1--;
6105            while ((cp1 > my_esa) && (*cp1 != '.'))
6106              cp1--;
6107         }
6108         if (cp1 == my_esa)
6109           cp1 = NULL;
6110       }
6111
6112       if ((cp1) != NULL) {
6113         /* There's more than one directory in the path.  Just roll back. */
6114         *cp1 = term;
6115         if (buf) retspec = buf;
6116         else if (ts) Newx(retspec,retlen+7,char);
6117         else retspec = __fileify_retbuf;
6118         strcpy(retspec,my_esa);
6119       }
6120       else {
6121         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6122           /* Go back and expand rooted logical name */
6123           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6124 #ifdef NAM$M_NO_SHORT_UPCASE
6125           if (decc_efs_case_preserve)
6126             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6127 #endif
6128           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6129             sts = rms_free_search_context(&dirfab);
6130             PerlMem_free(esa);
6131             if (esal != NULL)
6132                 PerlMem_free(esal);
6133             PerlMem_free(trndir);
6134             PerlMem_free(vmsdir);
6135             set_errno(EVMSERR);
6136             set_vaxc_errno(dirfab.fab$l_sts);
6137             return NULL;
6138           }
6139
6140           /* This changes the length of the string of course */
6141           if (esal != NULL) {
6142               my_esa_len = rms_nam_esll(dirnam);
6143           } else {
6144               my_esa_len = rms_nam_esl(dirnam);
6145           }
6146
6147           retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6148           if (buf) retspec = buf;
6149           else if (ts) Newx(retspec,retlen+16,char);
6150           else retspec = __fileify_retbuf;
6151           cp1 = strstr(my_esa,"][");
6152           if (!cp1) cp1 = strstr(my_esa,"]<");
6153           dirlen = cp1 - my_esa;
6154           memcpy(retspec,my_esa,dirlen);
6155           if (!strncmp(cp1+2,"000000]",7)) {
6156             retspec[dirlen-1] = '\0';
6157             /* fix-me Not full ODS-5, just extra dots in directories for now */
6158             cp1 = retspec + dirlen - 1;
6159             while (cp1 > retspec)
6160             {
6161               if (*cp1 == '[')
6162                 break;
6163               if (*cp1 == '.') {
6164                 if (*(cp1-1) != '^')
6165                   break;
6166               }
6167               cp1--;
6168             }
6169             if (*cp1 == '.') *cp1 = ']';
6170             else {
6171               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6172               memmove(cp1+1,"000000]",7);
6173             }
6174           }
6175           else {
6176             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
6177             retspec[retlen] = '\0';
6178             /* Convert last '.' to ']' */
6179             cp1 = retspec+retlen-1;
6180             while (*cp != '[') {
6181               cp1--;
6182               if (*cp1 == '.') {
6183                 /* Do not trip on extra dots in ODS-5 directories */
6184                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
6185                 break;
6186               }
6187             }
6188             if (*cp1 == '.') *cp1 = ']';
6189             else {
6190               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6191               memmove(cp1+1,"000000]",7);
6192             }
6193           }
6194         }
6195         else {  /* This is a top-level dir.  Add the MFD to the path. */
6196           if (buf) retspec = buf;
6197           else if (ts) Newx(retspec,retlen+16,char);
6198           else retspec = __fileify_retbuf;
6199           cp1 = my_esa;
6200           cp2 = retspec;
6201           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6202           strcpy(cp2,":[000000]");
6203           cp1 += 2;
6204           strcpy(cp2+9,cp1);
6205         }
6206       }
6207       sts = rms_free_search_context(&dirfab);
6208       /* We've set up the string up through the filename.  Add the
6209          type and version, and we're done. */
6210       strcat(retspec,".DIR;1");
6211
6212       /* $PARSE may have upcased filespec, so convert output to lower
6213        * case if input contained any lowercase characters. */
6214       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
6215       PerlMem_free(trndir);
6216       PerlMem_free(esa);
6217       if (esal != NULL)
6218         PerlMem_free(esal);
6219       PerlMem_free(vmsdir);
6220       return retspec;
6221     }
6222 }  /* end of do_fileify_dirspec() */
6223 /*}}}*/
6224 /* External entry points */
6225 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6226 { return do_fileify_dirspec(dir,buf,0,NULL); }
6227 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6228 { return do_fileify_dirspec(dir,buf,1,NULL); }
6229 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6230 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6231 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6232 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6233
6234 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6235 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6236 {
6237     static char __pathify_retbuf[VMS_MAXRSS];
6238     unsigned long int retlen;
6239     char *retpath, *cp1, *cp2, *trndir;
6240     unsigned short int trnlnm_iter_count;
6241     STRLEN trnlen;
6242     int sts;
6243     if (utf8_fl != NULL)
6244         *utf8_fl = 0;
6245
6246     if (!dir || !*dir) {
6247       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6248     }
6249
6250     trndir = PerlMem_malloc(VMS_MAXRSS);
6251     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
6252     if (*dir) strcpy(trndir,dir);
6253     else getcwd(trndir,VMS_MAXRSS - 1);
6254
6255     trnlnm_iter_count = 0;
6256     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6257            && my_trnlnm(trndir,trndir,0)) {
6258       trnlnm_iter_count++;
6259       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6260       trnlen = strlen(trndir);
6261
6262       /* Trap simple rooted lnms, and return lnm:[000000] */
6263       if (!strcmp(trndir+trnlen-2,".]")) {
6264         if (buf) retpath = buf;
6265         else if (ts) Newx(retpath,strlen(dir)+10,char);
6266         else retpath = __pathify_retbuf;
6267         strcpy(retpath,dir);
6268         strcat(retpath,":[000000]");
6269         PerlMem_free(trndir);
6270         return retpath;
6271       }
6272     }
6273
6274     /* At this point we do not work with *dir, but the copy in
6275      * *trndir that is modifiable.
6276      */
6277
6278     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
6279       if (*trndir == '.' && (*(trndir+1) == '\0' ||
6280                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
6281         retlen = 2 + (*(trndir+1) != '\0');
6282       else {
6283         if ( !(cp1 = strrchr(trndir,'/')) &&
6284              !(cp1 = strrchr(trndir,']')) &&
6285              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
6286         if ((cp2 = strchr(cp1,'.')) != NULL &&
6287             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
6288              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
6289               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
6290               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
6291           int ver; char *cp3;
6292
6293           /* For EFS or ODS-5 look for the last dot */
6294           if (decc_efs_charset) {
6295             cp2 = strrchr(cp1,'.');
6296           }
6297           if (vms_process_case_tolerant) {
6298               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
6299                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
6300                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6301                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6302                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6303                             (ver || *cp3)))))) {
6304                 PerlMem_free(trndir);
6305                 set_errno(ENOTDIR);
6306                 set_vaxc_errno(RMS$_DIR);
6307                 return NULL;
6308               }
6309           }
6310           else {
6311               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
6312                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
6313                   !*(cp2+3) || *(cp2+3) != 'R' ||
6314                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6315                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6316                             (ver || *cp3)))))) {
6317                 PerlMem_free(trndir);
6318                 set_errno(ENOTDIR);
6319                 set_vaxc_errno(RMS$_DIR);
6320                 return NULL;
6321               }
6322           }
6323           retlen = cp2 - trndir + 1;
6324         }
6325         else {  /* No file type present.  Treat the filename as a directory. */
6326           retlen = strlen(trndir) + 1;
6327         }
6328       }
6329       if (buf) retpath = buf;
6330       else if (ts) Newx(retpath,retlen+1,char);
6331       else retpath = __pathify_retbuf;
6332       strncpy(retpath, trndir, retlen-1);
6333       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
6334         retpath[retlen-1] = '/';      /* with '/', add it. */
6335         retpath[retlen] = '\0';
6336       }
6337       else retpath[retlen-1] = '\0';
6338     }
6339     else {  /* VMS-style directory spec */
6340       char *esa, *esal, *cp;
6341       char *my_esa;
6342       int my_esa_len;
6343       unsigned long int sts, cmplen, haslower;
6344       struct FAB dirfab = cc$rms_fab;
6345       int dirlen;
6346       rms_setup_nam(savnam);
6347       rms_setup_nam(dirnam);
6348
6349       /* If we've got an explicit filename, we can just shuffle the string. */
6350       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
6351              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
6352         if ((cp2 = strchr(cp1,'.')) != NULL) {
6353           int ver; char *cp3;
6354           if (vms_process_case_tolerant) {
6355               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
6356                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
6357                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6358                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6359                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6360                             (ver || *cp3)))))) {
6361                PerlMem_free(trndir);
6362                set_errno(ENOTDIR);
6363                set_vaxc_errno(RMS$_DIR);
6364                return NULL;
6365              }
6366           }
6367           else {
6368               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
6369                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
6370                   !*(cp2+3) || *(cp2+3) != 'R' ||
6371                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6372                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6373                             (ver || *cp3)))))) {
6374                PerlMem_free(trndir);
6375                set_errno(ENOTDIR);
6376                set_vaxc_errno(RMS$_DIR);
6377                return NULL;
6378              }
6379           }
6380         }
6381         else {  /* No file type, so just draw name into directory part */
6382           for (cp2 = cp1; *cp2; cp2++) ;
6383         }
6384         *cp2 = *cp1;
6385         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
6386         *cp1 = '.';
6387         /* We've now got a VMS 'path'; fall through */
6388       }
6389
6390       dirlen = strlen(trndir);
6391       if (trndir[dirlen-1] == ']' ||
6392           trndir[dirlen-1] == '>' ||
6393           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
6394         if (buf) retpath = buf;
6395         else if (ts) Newx(retpath,strlen(trndir)+1,char);
6396         else retpath = __pathify_retbuf;
6397         strcpy(retpath,trndir);
6398         PerlMem_free(trndir);
6399         return retpath;
6400       }
6401       rms_set_fna(dirfab, dirnam, trndir, dirlen);
6402       esa = PerlMem_malloc(VMS_MAXRSS);
6403       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
6404       esal = NULL;
6405 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6406       esal = PerlMem_malloc(VMS_MAXRSS);
6407       if (esal == NULL) _ckvmssts(SS$_INSFMEM);
6408 #endif
6409       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6410       rms_bind_fab_nam(dirfab, dirnam);
6411       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
6412 #ifdef NAM$M_NO_SHORT_UPCASE
6413       if (decc_efs_case_preserve)
6414           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6415 #endif
6416
6417       for (cp = trndir; *cp; cp++)
6418         if (islower(*cp)) { haslower = 1; break; }
6419
6420       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
6421         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
6422           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6423           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
6424         }
6425         if (!sts) {
6426           PerlMem_free(trndir);
6427           PerlMem_free(esa);
6428           if (esal != NULL)
6429             PerlMem_free(esal);
6430           set_errno(EVMSERR);
6431           set_vaxc_errno(dirfab.fab$l_sts);
6432           return NULL;
6433         }
6434       }
6435       else {
6436         savnam = dirnam;
6437         /* Does the file really exist? */
6438         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
6439           if (dirfab.fab$l_sts != RMS$_FNF) {
6440             int sts1;
6441             sts1 = rms_free_search_context(&dirfab);
6442             PerlMem_free(trndir);
6443             PerlMem_free(esa);
6444             if (esal != NULL)
6445                 PerlMem_free(esal);
6446             set_errno(EVMSERR);
6447             set_vaxc_errno(dirfab.fab$l_sts);
6448             return NULL;
6449           }
6450           dirnam = savnam; /* No; just work with potential name */
6451         }
6452       }
6453       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6454         /* Yep; check version while we're at it, if it's there. */
6455         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6456         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
6457           int sts2;
6458           /* Something other than .DIR[;1].  Bzzt. */
6459           sts2 = rms_free_search_context(&dirfab);
6460           PerlMem_free(trndir);
6461           PerlMem_free(esa);
6462           if (esal != NULL)
6463              PerlMem_free(esal);
6464           set_errno(ENOTDIR);
6465           set_vaxc_errno(RMS$_DIR);
6466           return NULL;
6467         }
6468       }
6469       /* Make sure we are using the right buffer */
6470       if (esal != NULL) {
6471         /* We only need one, clean up the other */
6472         my_esa = esal;
6473         my_esa_len = rms_nam_esll(dirnam);
6474       } else {
6475         my_esa = esa;
6476         my_esa_len = rms_nam_esl(dirnam);
6477       }
6478
6479       /* Null terminate the buffer */
6480       my_esa[my_esa_len] = '\0';
6481
6482       /* OK, the type was fine.  Now pull any file name into the
6483          directory path. */
6484       if ((cp1 = strrchr(my_esa,']'))) *(rms_nam_typel(dirnam)) = ']';
6485       else {
6486         cp1 = strrchr(my_esa,'>');
6487         *(rms_nam_typel(dirnam)) = '>';
6488       }
6489       *cp1 = '.';
6490       *(rms_nam_typel(dirnam) + 1) = '\0';
6491       retlen = (rms_nam_typel(dirnam)) - my_esa + 2;
6492       if (buf) retpath = buf;
6493       else if (ts) Newx(retpath,retlen,char);
6494       else retpath = __pathify_retbuf;
6495       strcpy(retpath,my_esa);
6496       PerlMem_free(esa);
6497       if (esal != NULL)
6498           PerlMem_free(esal);
6499       sts = rms_free_search_context(&dirfab);
6500       /* $PARSE may have upcased filespec, so convert output to lower
6501        * case if input contained any lowercase characters. */
6502       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
6503     }
6504
6505     PerlMem_free(trndir);
6506     return retpath;
6507 }  /* end of do_pathify_dirspec() */
6508 /*}}}*/
6509 /* External entry points */
6510 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6511 { return do_pathify_dirspec(dir,buf,0,NULL); }
6512 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6513 { return do_pathify_dirspec(dir,buf,1,NULL); }
6514 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6515 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6516 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6517 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
6518
6519 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
6520 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
6521 {
6522   static char __tounixspec_retbuf[VMS_MAXRSS];
6523   char *dirend, *rslt, *cp1, *cp3, *tmp;
6524   const char *cp2;
6525   int devlen, dirlen, retlen = VMS_MAXRSS;
6526   int expand = 1; /* guarantee room for leading and trailing slashes */
6527   unsigned short int trnlnm_iter_count;
6528   int cmp_rslt;
6529   if (utf8_fl != NULL)
6530     *utf8_fl = 0;
6531
6532   if (spec == NULL) return NULL;
6533   if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
6534   if (buf) rslt = buf;
6535   else if (ts) {
6536     Newx(rslt, VMS_MAXRSS, char);
6537   }
6538   else rslt = __tounixspec_retbuf;
6539
6540   /* New VMS specific format needs translation
6541    * glob passes filenames with trailing '\n' and expects this preserved.
6542    */
6543   if (decc_posix_compliant_pathnames) {
6544     if (strncmp(spec, "\"^UP^", 5) == 0) {
6545       char * uspec;
6546       char *tunix;
6547       int tunix_len;
6548       int nl_flag;
6549
6550       tunix = PerlMem_malloc(VMS_MAXRSS);
6551       if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
6552       strcpy(tunix, spec);
6553       tunix_len = strlen(tunix);
6554       nl_flag = 0;
6555       if (tunix[tunix_len - 1] == '\n') {
6556         tunix[tunix_len - 1] = '\"';
6557         tunix[tunix_len] = '\0';
6558         tunix_len--;
6559         nl_flag = 1;
6560       }
6561       uspec = decc$translate_vms(tunix);
6562       PerlMem_free(tunix);
6563       if ((int)uspec > 0) {
6564         strcpy(rslt,uspec);
6565         if (nl_flag) {
6566           strcat(rslt,"\n");
6567         }
6568         else {
6569           /* If we can not translate it, makemaker wants as-is */
6570           strcpy(rslt, spec);
6571         }
6572         return rslt;
6573       }
6574     }
6575   }
6576
6577   cmp_rslt = 0; /* Presume VMS */
6578   cp1 = strchr(spec, '/');
6579   if (cp1 == NULL)
6580     cmp_rslt = 0;
6581
6582     /* Look for EFS ^/ */
6583     if (decc_efs_charset) {
6584       while (cp1 != NULL) {
6585         cp2 = cp1 - 1;
6586         if (*cp2 != '^') {
6587           /* Found illegal VMS, assume UNIX */
6588           cmp_rslt = 1;
6589           break;
6590         }
6591       cp1++;
6592       cp1 = strchr(cp1, '/');
6593     }
6594   }
6595
6596   /* Look for "." and ".." */
6597   if (decc_filename_unix_report) {
6598     if (spec[0] == '.') {
6599       if ((spec[1] == '\0') || (spec[1] == '\n')) {
6600         cmp_rslt = 1;
6601       }
6602       else {
6603         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
6604           cmp_rslt = 1;
6605         }
6606       }
6607     }
6608   }
6609   /* This is already UNIX or at least nothing VMS understands */
6610   if (cmp_rslt) {
6611     strcpy(rslt,spec);
6612     return rslt;
6613   }
6614
6615   cp1 = rslt;
6616   cp2 = spec;
6617   dirend = strrchr(spec,']');
6618   if (dirend == NULL) dirend = strrchr(spec,'>');
6619   if (dirend == NULL) dirend = strchr(spec,':');
6620   if (dirend == NULL) {
6621     strcpy(rslt,spec);
6622     return rslt;
6623   }
6624
6625   /* Special case 1 - sys$posix_root = / */
6626 #if __CRTL_VER >= 70000000
6627   if (!decc_disable_posix_root) {
6628     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6629       *cp1 = '/';
6630       cp1++;
6631       cp2 = cp2 + 15;
6632       }
6633   }
6634 #endif
6635
6636   /* Special case 2 - Convert NLA0: to /dev/null */
6637 #if __CRTL_VER < 70000000
6638   cmp_rslt = strncmp(spec,"NLA0:", 5);
6639   if (cmp_rslt != 0)
6640      cmp_rslt = strncmp(spec,"nla0:", 5);
6641 #else
6642   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6643 #endif
6644   if (cmp_rslt == 0) {
6645     strcpy(rslt, "/dev/null");
6646     cp1 = cp1 + 9;
6647     cp2 = cp2 + 5;
6648     if (spec[6] != '\0') {
6649       cp1[9] == '/';
6650       cp1++;
6651       cp2++;
6652     }
6653   }
6654
6655    /* Also handle special case "SYS$SCRATCH:" */
6656 #if __CRTL_VER < 70000000
6657   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
6658   if (cmp_rslt != 0)
6659      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
6660 #else
6661   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6662 #endif
6663   tmp = PerlMem_malloc(VMS_MAXRSS);
6664   if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
6665   if (cmp_rslt == 0) {
6666   int islnm;
6667
6668     islnm = my_trnlnm(tmp, "TMP", 0);
6669     if (!islnm) {
6670       strcpy(rslt, "/tmp");
6671       cp1 = cp1 + 4;
6672       cp2 = cp2 + 12;
6673       if (spec[12] != '\0') {
6674         cp1[4] == '/';
6675         cp1++;
6676         cp2++;
6677       }
6678     }
6679   }
6680
6681   if (*cp2 != '[' && *cp2 != '<') {
6682     *(cp1++) = '/';
6683   }
6684   else {  /* the VMS spec begins with directories */
6685     cp2++;
6686     if (*cp2 == ']' || *cp2 == '>') {
6687       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
6688       PerlMem_free(tmp);
6689       return rslt;
6690     }
6691     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
6692       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
6693         if (ts) Safefree(rslt);
6694         PerlMem_free(tmp);
6695         return NULL;
6696       }
6697       trnlnm_iter_count = 0;
6698       do {
6699         cp3 = tmp;
6700         while (*cp3 != ':' && *cp3) cp3++;
6701         *(cp3++) = '\0';
6702         if (strchr(cp3,']') != NULL) break;
6703         trnlnm_iter_count++;
6704         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
6705       } while (vmstrnenv(tmp,tmp,0,fildev,0));
6706       if (ts && !buf &&
6707           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
6708         retlen = devlen + dirlen;
6709         Renew(rslt,retlen+1+2*expand,char);
6710         cp1 = rslt;
6711       }
6712       cp3 = tmp;
6713       *(cp1++) = '/';
6714       while (*cp3) {
6715         *(cp1++) = *(cp3++);
6716         if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
6717             PerlMem_free(tmp);
6718             return NULL; /* No room */
6719         }
6720       }
6721       *(cp1++) = '/';
6722     }
6723     if ((*cp2 == '^')) {
6724         /* EFS file escape, pass the next character as is */
6725         /* Fix me: HEX encoding for Unicode not implemented */
6726         cp2++;
6727     }
6728     else if ( *cp2 == '.') {
6729       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
6730         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6731         cp2 += 3;
6732       }
6733       else cp2++;
6734     }
6735   }
6736   PerlMem_free(tmp);
6737   for (; cp2 <= dirend; cp2++) {
6738     if ((*cp2 == '^')) {
6739         /* EFS file escape, pass the next character as is */
6740         /* Fix me: HEX encoding for Unicode not implemented */
6741         *(cp1++) = *(++cp2);
6742         /* An escaped dot stays as is -- don't convert to slash */
6743         if (*cp2 == '.') cp2++;
6744     }
6745     if (*cp2 == ':') {
6746       *(cp1++) = '/';
6747       if (*(cp2+1) == '[') cp2++;
6748     }
6749     else if (*cp2 == ']' || *cp2 == '>') {
6750       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6751     }
6752     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
6753       *(cp1++) = '/';
6754       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6755         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6756                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6757         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6758             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6759       }
6760       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6761         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6762         cp2 += 2;
6763       }
6764     }
6765     else if (*cp2 == '-') {
6766       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6767         while (*cp2 == '-') {
6768           cp2++;
6769           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6770         }
6771         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
6772           if (ts) Safefree(rslt);                        /* filespecs like */
6773           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
6774           return NULL;
6775         }
6776       }
6777       else *(cp1++) = *cp2;
6778     }
6779     else *(cp1++) = *cp2;
6780   }
6781   while (*cp2) {
6782     if ((*cp2 == '^') && (*(cp2+1) == '.')) cp2++;  /* '^.' --> '.' */
6783     *(cp1++) = *(cp2++);
6784   }
6785   *cp1 = '\0';
6786
6787   /* This still leaves /000000/ when working with a
6788    * VMS device root or concealed root.
6789    */
6790   {
6791   int ulen;
6792   char * zeros;
6793
6794       ulen = strlen(rslt);
6795
6796       /* Get rid of "000000/ in rooted filespecs */
6797       if (ulen > 7) {
6798         zeros = strstr(rslt, "/000000/");
6799         if (zeros != NULL) {
6800           int mlen;
6801           mlen = ulen - (zeros - rslt) - 7;
6802           memmove(zeros, &zeros[7], mlen);
6803           ulen = ulen - 7;
6804           rslt[ulen] = '\0';
6805         }
6806       }
6807   }
6808
6809   return rslt;
6810
6811 }  /* end of do_tounixspec() */
6812 /*}}}*/
6813 /* External entry points */
6814 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
6815   { return do_tounixspec(spec,buf,0, NULL); }
6816 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
6817   { return do_tounixspec(spec,buf,1, NULL); }
6818 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
6819   { return do_tounixspec(spec,buf,0, utf8_fl); }
6820 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
6821   { return do_tounixspec(spec,buf,1, utf8_fl); }
6822
6823 #if __CRTL_VER >= 70200000 && !defined(__VAX)
6824
6825 /*
6826  This procedure is used to identify if a path is based in either
6827  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
6828  it returns the OpenVMS format directory for it.
6829
6830  It is expecting specifications of only '/' or '/xxxx/'
6831
6832  If a posix root does not exist, or 'xxxx' is not a directory
6833  in the posix root, it returns a failure.
6834
6835  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
6836
6837  It is used only internally by posix_to_vmsspec_hardway().
6838  */
6839
6840 static int posix_root_to_vms
6841   (char *vmspath, int vmspath_len,
6842    const char *unixpath,
6843    const int * utf8_fl)
6844 {
6845 int sts;
6846 struct FAB myfab = cc$rms_fab;
6847 rms_setup_nam(mynam);
6848 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6849 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6850 char * esa, * esal, * rsa, * rsal;
6851 char *vms_delim;
6852 int dir_flag;
6853 int unixlen;
6854
6855     dir_flag = 0;
6856     vmspath[0] = '\0';
6857     unixlen = strlen(unixpath);
6858     if (unixlen == 0) {
6859       return RMS$_FNF;
6860     }
6861
6862 #if __CRTL_VER >= 80200000
6863   /* If not a posix spec already, convert it */
6864   if (decc_posix_compliant_pathnames) {
6865     if (strncmp(unixpath,"\"^UP^",5) != 0) {
6866       sprintf(vmspath,"\"^UP^%s\"",unixpath);
6867     }
6868     else {
6869       /* This is already a VMS specification, no conversion */
6870       unixlen--;
6871       strncpy(vmspath,unixpath, vmspath_len);
6872     }
6873   }
6874   else
6875 #endif
6876   {
6877   int path_len;
6878   int i,j;
6879
6880      /* Check to see if this is under the POSIX root */
6881      if (decc_disable_posix_root) {
6882         return RMS$_FNF;
6883      }
6884
6885      /* Skip leading / */
6886      if (unixpath[0] == '/') {
6887         unixpath++;
6888         unixlen--;
6889      }
6890
6891
6892      strcpy(vmspath,"SYS$POSIX_ROOT:");
6893
6894      /* If this is only the / , or blank, then... */
6895      if (unixpath[0] == '\0') {
6896         /* by definition, this is the answer */
6897         return SS$_NORMAL;
6898      }
6899
6900      /* Need to look up a directory */
6901      vmspath[15] = '[';
6902      vmspath[16] = '\0';
6903
6904      /* Copy and add '^' escape characters as needed */
6905      j = 16;
6906      i = 0;
6907      while (unixpath[i] != 0) {
6908      int k;
6909
6910         j += copy_expand_unix_filename_escape
6911             (&vmspath[j], &unixpath[i], &k, utf8_fl);
6912         i += k;
6913      }
6914
6915      path_len = strlen(vmspath);
6916      if (vmspath[path_len - 1] == '/')
6917         path_len--;
6918      vmspath[path_len] = ']';
6919      path_len++;
6920      vmspath[path_len] = '\0';
6921
6922   }
6923   vmspath[vmspath_len] = 0;
6924   if (unixpath[unixlen - 1] == '/')
6925   dir_flag = 1;
6926   esal = PerlMem_malloc(VMS_MAXRSS);
6927   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6928   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6929   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6930   rsal = PerlMem_malloc(VMS_MAXRSS);
6931   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6932   rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6933   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6934   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
6935   rms_bind_fab_nam(myfab, mynam);
6936   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
6937   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
6938   if (decc_efs_case_preserve)
6939     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6940 #ifdef NAML$M_OPEN_SPECIAL
6941   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6942 #endif
6943
6944   /* Set up the remaining naml fields */
6945   sts = sys$parse(&myfab);
6946
6947   /* It failed! Try again as a UNIX filespec */
6948   if (!(sts & 1)) {
6949     PerlMem_free(esal);
6950     PerlMem_free(esa);
6951     PerlMem_free(rsal);
6952     PerlMem_free(rsa);
6953     return sts;
6954   }
6955
6956    /* get the Device ID and the FID */
6957    sts = sys$search(&myfab);
6958
6959    /* These are no longer needed */
6960    PerlMem_free(esa);
6961    PerlMem_free(rsal);
6962    PerlMem_free(rsa);
6963
6964    /* on any failure, returned the POSIX ^UP^ filespec */
6965    if (!(sts & 1)) {
6966       PerlMem_free(esal);
6967       return sts;
6968    }
6969    specdsc.dsc$a_pointer = vmspath;
6970    specdsc.dsc$w_length = vmspath_len;
6971
6972    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6973    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6974    sts = lib$fid_to_name
6975       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6976
6977   /* on any failure, returned the POSIX ^UP^ filespec */
6978   if (!(sts & 1)) {
6979      /* This can happen if user does not have permission to read directories */
6980      if (strncmp(unixpath,"\"^UP^",5) != 0)
6981        sprintf(vmspath,"\"^UP^%s\"",unixpath);
6982      else
6983        strcpy(vmspath, unixpath);
6984   }
6985   else {
6986     vmspath[specdsc.dsc$w_length] = 0;
6987
6988     /* Are we expecting a directory? */
6989     if (dir_flag != 0) {
6990     int i;
6991     char *eptr;
6992
6993       eptr = NULL;
6994
6995       i = specdsc.dsc$w_length - 1;
6996       while (i > 0) {
6997       int zercnt;
6998         zercnt = 0;
6999         /* Version must be '1' */
7000         if (vmspath[i--] != '1')
7001           break;
7002         /* Version delimiter is one of ".;" */
7003         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7004           break;
7005         i--;
7006         if (vmspath[i--] != 'R')
7007           break;
7008         if (vmspath[i--] != 'I')
7009           break;
7010         if (vmspath[i--] != 'D')
7011           break;
7012         if (vmspath[i--] != '.')
7013           break;
7014         eptr = &vmspath[i+1];
7015         while (i > 0) {
7016           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7017             if (vmspath[i-1] != '^') {
7018               if (zercnt != 6) {
7019                 *eptr = vmspath[i];
7020                 eptr[1] = '\0';
7021                 vmspath[i] = '.';
7022                 break;
7023               }
7024               else {
7025                 /* Get rid of 6 imaginary zero directory filename */
7026                 vmspath[i+1] = '\0';
7027               }
7028             }
7029           }
7030           if (vmspath[i] == '0')
7031             zercnt++;
7032           else
7033             zercnt = 10;
7034           i--;
7035         }
7036         break;
7037       }
7038     }
7039   }
7040   PerlMem_free(esal);
7041   return sts;
7042 }
7043
7044 /* /dev/mumble needs to be handled special.
7045    /dev/null becomes NLA0:, And there is the potential for other stuff
7046    like /dev/tty which may need to be mapped to something.
7047 */
7048
7049 static int
7050 slash_dev_special_to_vms
7051    (const char * unixptr,
7052     char * vmspath,
7053     int vmspath_len)
7054 {
7055 char * nextslash;
7056 int len;
7057 int cmp;
7058 int islnm;
7059
7060     unixptr += 4;
7061     nextslash = strchr(unixptr, '/');
7062     len = strlen(unixptr);
7063     if (nextslash != NULL)
7064         len = nextslash - unixptr;
7065     cmp = strncmp("null", unixptr, 5);
7066     if (cmp == 0) {
7067         if (vmspath_len >= 6) {
7068             strcpy(vmspath, "_NLA0:");
7069             return SS$_NORMAL;
7070         }
7071     }
7072 }
7073
7074
7075 /* The built in routines do not understand perl's special needs, so
7076     doing a manual conversion from UNIX to VMS
7077
7078     If the utf8_fl is not null and points to a non-zero value, then
7079     treat 8 bit characters as UTF-8.
7080
7081     The sequence starting with '$(' and ending with ')' will be passed
7082     through with out interpretation instead of being escaped.
7083
7084   */
7085 static int posix_to_vmsspec_hardway
7086   (char *vmspath, int vmspath_len,
7087    const char *unixpath,
7088    int dir_flag,
7089    int * utf8_fl) {
7090
7091 char *esa;
7092 const char *unixptr;
7093 const char *unixend;
7094 char *vmsptr;
7095 const char *lastslash;
7096 const char *lastdot;
7097 int unixlen;
7098 int vmslen;
7099 int dir_start;
7100 int dir_dot;
7101 int quoted;
7102 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7103 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7104
7105   if (utf8_fl != NULL)
7106     *utf8_fl = 0;
7107
7108   unixptr = unixpath;
7109   dir_dot = 0;
7110
7111   /* Ignore leading "/" characters */
7112   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7113     unixptr++;
7114   }
7115   unixlen = strlen(unixptr);
7116
7117   /* Do nothing with blank paths */
7118   if (unixlen == 0) {
7119     vmspath[0] = '\0';
7120     return SS$_NORMAL;
7121   }
7122
7123   quoted = 0;
7124   /* This could have a "^UP^ on the front */
7125   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7126     quoted = 1;
7127     unixptr+= 5;
7128     unixlen-= 5;
7129   }
7130
7131   lastslash = strrchr(unixptr,'/');
7132   lastdot = strrchr(unixptr,'.');
7133   unixend = strrchr(unixptr,'\"');
7134   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7135     unixend = unixptr + unixlen;
7136   }
7137
7138   /* last dot is last dot or past end of string */
7139   if (lastdot == NULL)
7140     lastdot = unixptr + unixlen;
7141
7142   /* if no directories, set last slash to beginning of string */
7143   if (lastslash == NULL) {
7144     lastslash = unixptr;
7145   }
7146   else {
7147     /* Watch out for trailing "." after last slash, still a directory */
7148     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7149       lastslash = unixptr + unixlen;
7150     }
7151
7152     /* Watch out for traiing ".." after last slash, still a directory */
7153     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7154       lastslash = unixptr + unixlen;
7155     }
7156
7157     /* dots in directories are aways escaped */
7158     if (lastdot < lastslash)
7159       lastdot = unixptr + unixlen;
7160   }
7161
7162   /* if (unixptr < lastslash) then we are in a directory */
7163
7164   dir_start = 0;
7165
7166   vmsptr = vmspath;
7167   vmslen = 0;
7168
7169   /* Start with the UNIX path */
7170   if (*unixptr != '/') {
7171     /* relative paths */
7172
7173     /* If allowing logical names on relative pathnames, then handle here */
7174     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7175         !decc_posix_compliant_pathnames) {
7176     char * nextslash;
7177     int seg_len;
7178     char * trn;
7179     int islnm;
7180
7181         /* Find the next slash */
7182         nextslash = strchr(unixptr,'/');
7183
7184         esa = PerlMem_malloc(vmspath_len);
7185         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7186
7187         trn = PerlMem_malloc(VMS_MAXRSS);
7188         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7189
7190         if (nextslash != NULL) {
7191
7192             seg_len = nextslash - unixptr;
7193             strncpy(esa, unixptr, seg_len);
7194             esa[seg_len] = 0;
7195         }
7196         else {
7197             strcpy(esa, unixptr);
7198             seg_len = strlen(unixptr);
7199         }
7200         /* trnlnm(section) */
7201         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7202
7203         if (islnm) {
7204             /* Now fix up the directory */
7205
7206             /* Split up the path to find the components */
7207             sts = vms_split_path
7208                   (trn,
7209                    &v_spec,
7210                    &v_len,
7211                    &r_spec,
7212                    &r_len,
7213                    &d_spec,
7214                    &d_len,
7215                    &n_spec,
7216                    &n_len,
7217                    &e_spec,
7218                    &e_len,
7219                    &vs_spec,
7220                    &vs_len);
7221
7222             while (sts == 0) {
7223             char * strt;
7224             int cmp;
7225
7226                 /* A logical name must be a directory  or the full
7227                    specification.  It is only a full specification if
7228                    it is the only component */
7229                 if ((unixptr[seg_len] == '\0') ||
7230                     (unixptr[seg_len+1] == '\0')) {
7231
7232                     /* Is a directory being required? */
7233                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7234                         /* Not a logical name */
7235                         break;
7236                     }
7237
7238
7239                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7240                         /* This must be a directory */
7241                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7242                             strcpy(vmsptr, esa);
7243                             vmslen=strlen(vmsptr);
7244                             vmsptr[vmslen] = ':';
7245                             vmslen++;
7246                             vmsptr[vmslen] = '\0';
7247                             return SS$_NORMAL;
7248                         }
7249                     }
7250
7251                 }
7252
7253
7254                 /* must be dev/directory - ignore version */
7255                 if ((n_len + e_len) != 0)
7256                     break;
7257
7258                 /* transfer the volume */
7259                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7260                     strncpy(vmsptr, v_spec, v_len);
7261                     vmsptr += v_len;
7262                     vmsptr[0] = '\0';
7263                     vmslen += v_len;
7264                 }
7265
7266                 /* unroot the rooted directory */
7267                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7268                     r_spec[0] = '[';
7269                     r_spec[r_len - 1] = ']';
7270
7271                     /* This should not be there, but nothing is perfect */
7272                     if (r_len > 9) {
7273                         cmp = strcmp(&r_spec[1], "000000.");
7274                         if (cmp == 0) {
7275                             r_spec += 7;
7276                             r_spec[7] = '[';
7277                             r_len -= 7;
7278                             if (r_len == 2)
7279                                 r_len = 0;
7280                         }
7281                     }
7282                     if (r_len > 0) {
7283                         strncpy(vmsptr, r_spec, r_len);
7284                         vmsptr += r_len;
7285                         vmslen += r_len;
7286                         vmsptr[0] = '\0';
7287                     }
7288                 }
7289                 /* Bring over the directory. */
7290                 if ((d_len > 0) &&
7291                     ((d_len + vmslen) < vmspath_len)) {
7292                     d_spec[0] = '[';
7293                     d_spec[d_len - 1] = ']';
7294                     if (d_len > 9) {
7295                         cmp = strcmp(&d_spec[1], "000000.");
7296                         if (cmp == 0) {
7297                             d_spec += 7;
7298                             d_spec[7] = '[';
7299                             d_len -= 7;
7300                             if (d_len == 2)
7301                                 d_len = 0;
7302                         }
7303                     }
7304
7305                     if (r_len > 0) {
7306                         /* Remove the redundant root */
7307                         if (r_len > 0) {
7308                             /* remove the ][ */
7309                             vmsptr--;
7310                             vmslen--;
7311                             d_spec++;
7312                             d_len--;
7313                         }
7314                         strncpy(vmsptr, d_spec, d_len);
7315                             vmsptr += d_len;
7316                             vmslen += d_len;
7317                             vmsptr[0] = '\0';
7318                     }
7319                 }
7320                 break;
7321             }
7322         }
7323
7324         PerlMem_free(esa);
7325         PerlMem_free(trn);
7326     }
7327
7328     if (lastslash > unixptr) {
7329     int dotdir_seen;
7330
7331       /* skip leading ./ */
7332       dotdir_seen = 0;
7333       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7334         dotdir_seen = 1;
7335         unixptr++;
7336         unixptr++;
7337       }
7338
7339       /* Are we still in a directory? */
7340       if (unixptr <= lastslash) {
7341         *vmsptr++ = '[';
7342         vmslen = 1;
7343         dir_start = 1;
7344
7345         /* if not backing up, then it is relative forward. */
7346         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7347               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7348           *vmsptr++ = '.';
7349           vmslen++;
7350           dir_dot = 1;
7351           }
7352        }
7353        else {
7354          if (dotdir_seen) {
7355            /* Perl wants an empty directory here to tell the difference
7356             * between a DCL commmand and a filename
7357             */
7358           *vmsptr++ = '[';
7359           *vmsptr++ = ']';
7360           vmslen = 2;
7361         }
7362       }
7363     }
7364     else {
7365       /* Handle two special files . and .. */
7366       if (unixptr[0] == '.') {
7367         if (&unixptr[1] == unixend) {
7368           *vmsptr++ = '[';
7369           *vmsptr++ = ']';
7370           vmslen += 2;
7371           *vmsptr++ = '\0';
7372           return SS$_NORMAL;
7373         }
7374         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7375           *vmsptr++ = '[';
7376           *vmsptr++ = '-';
7377           *vmsptr++ = ']';
7378           vmslen += 3;
7379           *vmsptr++ = '\0';
7380           return SS$_NORMAL;
7381         }
7382       }
7383     }
7384   }
7385   else {        /* Absolute PATH handling */
7386   int sts;
7387   char * nextslash;
7388   int seg_len;
7389     /* Need to find out where root is */
7390
7391     /* In theory, this procedure should never get an absolute POSIX pathname
7392      * that can not be found on the POSIX root.
7393      * In practice, that can not be relied on, and things will show up
7394      * here that are a VMS device name or concealed logical name instead.
7395      * So to make things work, this procedure must be tolerant.
7396      */
7397     esa = PerlMem_malloc(vmspath_len);
7398     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7399
7400     sts = SS$_NORMAL;
7401     nextslash = strchr(&unixptr[1],'/');
7402     seg_len = 0;
7403     if (nextslash != NULL) {
7404     int cmp;
7405       seg_len = nextslash - &unixptr[1];
7406       strncpy(vmspath, unixptr, seg_len + 1);
7407       vmspath[seg_len+1] = 0;
7408       cmp = 1;
7409       if (seg_len == 3) {
7410         cmp = strncmp(vmspath, "dev", 4);
7411         if (cmp == 0) {
7412             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7413             if (sts = SS$_NORMAL)
7414                 return SS$_NORMAL;
7415         }
7416       }
7417       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
7418     }
7419
7420     if ($VMS_STATUS_SUCCESS(sts)) {
7421       /* This is verified to be a real path */
7422
7423       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7424       if ($VMS_STATUS_SUCCESS(sts)) {
7425         strcpy(vmspath, esa);
7426         vmslen = strlen(vmspath);
7427         vmsptr = vmspath + vmslen;
7428         unixptr++;
7429         if (unixptr < lastslash) {
7430         char * rptr;
7431           vmsptr--;
7432           *vmsptr++ = '.';
7433           dir_start = 1;
7434           dir_dot = 1;
7435           if (vmslen > 7) {
7436           int cmp;
7437             rptr = vmsptr - 7;
7438             cmp = strcmp(rptr,"000000.");
7439             if (cmp == 0) {
7440               vmslen -= 7;
7441               vmsptr -= 7;
7442               vmsptr[1] = '\0';
7443             } /* removing 6 zeros */
7444           } /* vmslen < 7, no 6 zeros possible */
7445         } /* Not in a directory */
7446       } /* Posix root found */
7447       else {
7448         /* No posix root, fall back to default directory */
7449         strcpy(vmspath, "SYS$DISK:[");
7450         vmsptr = &vmspath[10];
7451         vmslen = 10;
7452         if (unixptr > lastslash) {
7453            *vmsptr = ']';
7454            vmsptr++;
7455            vmslen++;
7456         }
7457         else {
7458            dir_start = 1;
7459         }
7460       }
7461     } /* end of verified real path handling */
7462     else {
7463     int add_6zero;
7464     int islnm;
7465
7466       /* Ok, we have a device or a concealed root that is not in POSIX
7467        * or we have garbage.  Make the best of it.
7468        */
7469
7470       /* Posix to VMS destroyed this, so copy it again */
7471       strncpy(vmspath, &unixptr[1], seg_len);
7472       vmspath[seg_len] = 0;
7473       vmslen = seg_len;
7474       vmsptr = &vmsptr[vmslen];
7475       islnm = 0;
7476
7477       /* Now do we need to add the fake 6 zero directory to it? */
7478       add_6zero = 1;
7479       if ((*lastslash == '/') && (nextslash < lastslash)) {
7480         /* No there is another directory */
7481         add_6zero = 0;
7482       }
7483       else {
7484       int trnend;
7485       int cmp;
7486
7487         /* now we have foo:bar or foo:[000000]bar to decide from */
7488         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
7489
7490         if (!islnm && !decc_posix_compliant_pathnames) {
7491
7492             cmp = strncmp("bin", vmspath, 4);
7493             if (cmp == 0) {
7494                 /* bin => SYS$SYSTEM: */
7495                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7496             }
7497             else {
7498                 /* tmp => SYS$SCRATCH: */
7499                 cmp = strncmp("tmp", vmspath, 4);
7500                 if (cmp == 0) {
7501                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
7502                 }
7503             }
7504         }
7505
7506         trnend = islnm ? islnm - 1 : 0;
7507
7508         /* if this was a logical name, ']' or '>' must be present */
7509         /* if not a logical name, then assume a device and hope. */
7510         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
7511
7512         /* if log name and trailing '.' then rooted - treat as device */
7513         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
7514
7515         /* Fix me, if not a logical name, a device lookup should be
7516          * done to see if the device is file structured.  If the device
7517          * is not file structured, the 6 zeros should not be put on.
7518          *
7519          * As it is, perl is occasionally looking for dev:[000000]tty.
7520          * which looks a little strange.
7521          *
7522          * Not that easy to detect as "/dev" may be file structured with
7523          * special device files.
7524          */
7525
7526         if ((add_6zero == 0) && (*nextslash == '/') &&
7527             (&nextslash[1] == unixend)) {
7528           /* No real directory present */
7529           add_6zero = 1;
7530         }
7531       }
7532
7533       /* Put the device delimiter on */
7534       *vmsptr++ = ':';
7535       vmslen++;
7536       unixptr = nextslash;
7537       unixptr++;
7538
7539       /* Start directory if needed */
7540       if (!islnm || add_6zero) {
7541         *vmsptr++ = '[';
7542         vmslen++;
7543         dir_start = 1;
7544       }
7545
7546       /* add fake 000000] if needed */
7547       if (add_6zero) {
7548         *vmsptr++ = '0';
7549         *vmsptr++ = '0';
7550         *vmsptr++ = '0';
7551         *vmsptr++ = '0';
7552         *vmsptr++ = '0';
7553         *vmsptr++ = '0';
7554         *vmsptr++ = ']';
7555         vmslen += 7;
7556         dir_start = 0;
7557       }
7558
7559     } /* non-POSIX translation */
7560     PerlMem_free(esa);
7561   } /* End of relative/absolute path handling */
7562
7563   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
7564   int dash_flag;
7565   int in_cnt;
7566   int out_cnt;
7567
7568     dash_flag = 0;
7569
7570     if (dir_start != 0) {
7571
7572       /* First characters in a directory are handled special */
7573       while ((*unixptr == '/') ||
7574              ((*unixptr == '.') &&
7575               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
7576                 (&unixptr[1]==unixend)))) {
7577       int loop_flag;
7578
7579         loop_flag = 0;
7580
7581         /* Skip redundant / in specification */
7582         while ((*unixptr == '/') && (dir_start != 0)) {
7583           loop_flag = 1;
7584           unixptr++;
7585           if (unixptr == lastslash)
7586             break;
7587         }
7588         if (unixptr == lastslash)
7589           break;
7590
7591         /* Skip redundant ./ characters */
7592         while ((*unixptr == '.') &&
7593                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
7594           loop_flag = 1;
7595           unixptr++;
7596           if (unixptr == lastslash)
7597             break;
7598           if (*unixptr == '/')
7599             unixptr++;
7600         }
7601         if (unixptr == lastslash)
7602           break;
7603
7604         /* Skip redundant ../ characters */
7605         while ((*unixptr == '.') && (unixptr[1] == '.') &&
7606              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
7607           /* Set the backing up flag */
7608           loop_flag = 1;
7609           dir_dot = 0;
7610           dash_flag = 1;
7611           *vmsptr++ = '-';
7612           vmslen++;
7613           unixptr++; /* first . */
7614           unixptr++; /* second . */
7615           if (unixptr == lastslash)
7616             break;
7617           if (*unixptr == '/') /* The slash */
7618             unixptr++;
7619         }
7620         if (unixptr == lastslash)
7621           break;
7622
7623         /* To do: Perl expects /.../ to be translated to [...] on VMS */
7624         /* Not needed when VMS is pretending to be UNIX. */
7625
7626         /* Is this loop stuck because of too many dots? */
7627         if (loop_flag == 0) {
7628           /* Exit the loop and pass the rest through */
7629           break;
7630         }
7631       }
7632
7633       /* Are we done with directories yet? */
7634       if (unixptr >= lastslash) {
7635
7636         /* Watch out for trailing dots */
7637         if (dir_dot != 0) {
7638             vmslen --;
7639             vmsptr--;
7640         }
7641         *vmsptr++ = ']';
7642         vmslen++;
7643         dash_flag = 0;
7644         dir_start = 0;
7645         if (*unixptr == '/')
7646           unixptr++;
7647       }
7648       else {
7649         /* Have we stopped backing up? */
7650         if (dash_flag) {
7651           *vmsptr++ = '.';
7652           vmslen++;
7653           dash_flag = 0;
7654           /* dir_start continues to be = 1 */
7655         }
7656         if (*unixptr == '-') {
7657           *vmsptr++ = '^';
7658           *vmsptr++ = *unixptr++;
7659           vmslen += 2;
7660           dir_start = 0;
7661
7662           /* Now are we done with directories yet? */
7663           if (unixptr >= lastslash) {
7664
7665             /* Watch out for trailing dots */
7666             if (dir_dot != 0) {
7667               vmslen --;
7668               vmsptr--;
7669             }
7670
7671             *vmsptr++ = ']';
7672             vmslen++;
7673             dash_flag = 0;
7674             dir_start = 0;
7675           }
7676         }
7677       }
7678     }
7679
7680     /* All done? */
7681     if (unixptr >= unixend)
7682       break;
7683
7684     /* Normal characters - More EFS work probably needed */
7685     dir_start = 0;
7686     dir_dot = 0;
7687
7688     switch(*unixptr) {
7689     case '/':
7690         /* remove multiple / */
7691         while (unixptr[1] == '/') {
7692            unixptr++;
7693         }
7694         if (unixptr == lastslash) {
7695           /* Watch out for trailing dots */
7696           if (dir_dot != 0) {
7697             vmslen --;
7698             vmsptr--;
7699           }
7700           *vmsptr++ = ']';
7701         }
7702         else {
7703           dir_start = 1;
7704           *vmsptr++ = '.';
7705           dir_dot = 1;
7706
7707           /* To do: Perl expects /.../ to be translated to [...] on VMS */
7708           /* Not needed when VMS is pretending to be UNIX. */
7709
7710         }
7711         dash_flag = 0;
7712         if (unixptr != unixend)
7713           unixptr++;
7714         vmslen++;
7715         break;
7716     case '.':
7717         if ((unixptr < lastdot) || (unixptr < lastslash) ||
7718             (&unixptr[1] == unixend)) {
7719           *vmsptr++ = '^';
7720           *vmsptr++ = '.';
7721           vmslen += 2;
7722           unixptr++;
7723
7724           /* trailing dot ==> '^..' on VMS */
7725           if (unixptr == unixend) {
7726             *vmsptr++ = '.';
7727             vmslen++;
7728             unixptr++;
7729           }
7730           break;
7731         }
7732
7733         *vmsptr++ = *unixptr++;
7734         vmslen ++;
7735         break;
7736     case '"':
7737         if (quoted && (&unixptr[1] == unixend)) {
7738             unixptr++;
7739             break;
7740         }
7741         in_cnt = copy_expand_unix_filename_escape
7742                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7743         vmsptr += out_cnt;
7744         unixptr += in_cnt;
7745         break;
7746     case '~':
7747     case ';':
7748     case '\\':
7749     case '?':
7750     case ' ':
7751     default:
7752         in_cnt = copy_expand_unix_filename_escape
7753                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7754         vmsptr += out_cnt;
7755         unixptr += in_cnt;
7756         break;
7757     }
7758   }
7759
7760   /* Make sure directory is closed */
7761   if (unixptr == lastslash) {
7762     char *vmsptr2;
7763     vmsptr2 = vmsptr - 1;
7764
7765     if (*vmsptr2 != ']') {
7766       *vmsptr2--;
7767
7768       /* directories do not end in a dot bracket */
7769       if (*vmsptr2 == '.') {
7770         vmsptr2--;
7771
7772         /* ^. is allowed */
7773         if (*vmsptr2 != '^') {
7774           vmsptr--; /* back up over the dot */
7775         }
7776       }
7777       *vmsptr++ = ']';
7778     }
7779   }
7780   else {
7781     char *vmsptr2;
7782     /* Add a trailing dot if a file with no extension */
7783     vmsptr2 = vmsptr - 1;
7784     if ((vmslen > 1) &&
7785         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
7786         (*vmsptr2 != ')') && (*lastdot != '.')) {
7787         *vmsptr++ = '.';
7788         vmslen++;
7789     }
7790   }
7791
7792   *vmsptr = '\0';
7793   return SS$_NORMAL;
7794 }
7795 #endif
7796
7797  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
7798 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
7799 {
7800 char * result;
7801 int utf8_flag;
7802
7803    /* If a UTF8 flag is being passed, honor it */
7804    utf8_flag = 0;
7805    if (utf8_fl != NULL) {
7806      utf8_flag = *utf8_fl;
7807     *utf8_fl = 0;
7808    }
7809
7810    if (utf8_flag) {
7811      /* If there is a possibility of UTF8, then if any UTF8 characters
7812         are present, then they must be converted to VTF-7
7813       */
7814      result = strcpy(rslt, path); /* FIX-ME */
7815    }
7816    else
7817      result = strcpy(rslt, path);
7818
7819    return result;
7820 }
7821
7822
7823 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
7824 static char *mp_do_tovmsspec
7825    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
7826   static char __tovmsspec_retbuf[VMS_MAXRSS];
7827   char *rslt, *dirend;
7828   char *lastdot;
7829   char *vms_delim;
7830   register char *cp1;
7831   const char *cp2;
7832   unsigned long int infront = 0, hasdir = 1;
7833   int rslt_len;
7834   int no_type_seen;
7835   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7836   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7837
7838   if (path == NULL) return NULL;
7839   rslt_len = VMS_MAXRSS-1;
7840   if (buf) rslt = buf;
7841   else if (ts) Newx(rslt, VMS_MAXRSS, char);
7842   else rslt = __tovmsspec_retbuf;
7843
7844   /* '.' and '..' are "[]" and "[-]" for a quick check */
7845   if (path[0] == '.') {
7846     if (path[1] == '\0') {
7847       strcpy(rslt,"[]");
7848       if (utf8_flag != NULL)
7849         *utf8_flag = 0;
7850       return rslt;
7851     }
7852     else {
7853       if (path[1] == '.' && path[2] == '\0') {
7854         strcpy(rslt,"[-]");
7855         if (utf8_flag != NULL)
7856            *utf8_flag = 0;
7857         return rslt;
7858       }
7859     }
7860   }
7861
7862    /* Posix specifications are now a native VMS format */
7863   /*--------------------------------------------------*/
7864 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7865   if (decc_posix_compliant_pathnames) {
7866     if (strncmp(path,"\"^UP^",5) == 0) {
7867       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7868       return rslt;
7869     }
7870   }
7871 #endif
7872
7873   /* This is really the only way to see if this is already in VMS format */
7874   sts = vms_split_path
7875        (path,
7876         &v_spec,
7877         &v_len,
7878         &r_spec,
7879         &r_len,
7880         &d_spec,
7881         &d_len,
7882         &n_spec,
7883         &n_len,
7884         &e_spec,
7885         &e_len,
7886         &vs_spec,
7887         &vs_len);
7888   if (sts == 0) {
7889     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
7890        replacement, because the above parse just took care of most of
7891        what is needed to do vmspath when the specification is already
7892        in VMS format.
7893
7894        And if it is not already, it is easier to do the conversion as
7895        part of this routine than to call this routine and then work on
7896        the result.
7897      */
7898
7899     /* If VMS punctuation was found, it is already VMS format */
7900     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
7901       if (utf8_flag != NULL)
7902         *utf8_flag = 0;
7903       strcpy(rslt, path);
7904       return rslt;
7905     }
7906     /* Now, what to do with trailing "." cases where there is no
7907        extension?  If this is a UNIX specification, and EFS characters
7908        are enabled, then the trailing "." should be converted to a "^.".
7909        But if this was already a VMS specification, then it should be
7910        left alone.
7911
7912        So in the case of ambiguity, leave the specification alone.
7913      */
7914
7915
7916     /* If there is a possibility of UTF8, then if any UTF8 characters
7917         are present, then they must be converted to VTF-7
7918      */
7919     if (utf8_flag != NULL)
7920       *utf8_flag = 0;
7921     strcpy(rslt, path);
7922     return rslt;
7923   }
7924
7925   dirend = strrchr(path,'/');
7926
7927   if (dirend == NULL) {
7928      /* If we get here with no UNIX directory delimiters, then this is
7929         not a complete file specification, either garbage a UNIX glob
7930         specification that can not be converted to a VMS wildcard, or
7931         it a UNIX shell macro.  MakeMaker wants these passed through AS-IS,
7932         so apparently other programs expect this also.
7933
7934         utf8 flag setting needs to be preserved.
7935       */
7936       strcpy(rslt, path);
7937       return rslt;
7938   }
7939
7940 /* If POSIX mode active, handle the conversion */
7941 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7942   if (decc_efs_charset) {
7943     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7944     return rslt;
7945   }
7946 #endif
7947
7948   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
7949     if (!*(dirend+2)) dirend +=2;
7950     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7951     if (decc_efs_charset == 0) {
7952       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7953     }
7954   }
7955
7956   cp1 = rslt;
7957   cp2 = path;
7958   lastdot = strrchr(cp2,'.');
7959   if (*cp2 == '/') {
7960     char *trndev;
7961     int islnm, rooted;
7962     STRLEN trnend;
7963
7964     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7965     if (!*(cp2+1)) {
7966       if (decc_disable_posix_root) {
7967         strcpy(rslt,"sys$disk:[000000]");
7968       }
7969       else {
7970         strcpy(rslt,"sys$posix_root:[000000]");
7971       }
7972       if (utf8_flag != NULL)
7973         *utf8_flag = 0;
7974       return rslt;
7975     }
7976     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7977     *cp1 = '\0';
7978     trndev = PerlMem_malloc(VMS_MAXRSS);
7979     if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7980     islnm =  my_trnlnm(rslt,trndev,0);
7981
7982      /* DECC special handling */
7983     if (!islnm) {
7984       if (strcmp(rslt,"bin") == 0) {
7985         strcpy(rslt,"sys$system");
7986         cp1 = rslt + 10;
7987         *cp1 = 0;
7988         islnm =  my_trnlnm(rslt,trndev,0);
7989       }
7990       else if (strcmp(rslt,"tmp") == 0) {
7991         strcpy(rslt,"sys$scratch");
7992         cp1 = rslt + 11;
7993         *cp1 = 0;
7994         islnm =  my_trnlnm(rslt,trndev,0);
7995       }
7996       else if (!decc_disable_posix_root) {
7997         strcpy(rslt, "sys$posix_root");
7998         cp1 = rslt + 13;
7999         *cp1 = 0;
8000         cp2 = path;
8001         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8002         islnm =  my_trnlnm(rslt,trndev,0);
8003       }
8004       else if (strcmp(rslt,"dev") == 0) {
8005         if (strncmp(cp2,"/null", 5) == 0) {
8006           if ((cp2[5] == 0) || (cp2[5] == '/')) {
8007             strcpy(rslt,"NLA0");
8008             cp1 = rslt + 4;
8009             *cp1 = 0;
8010             cp2 = cp2 + 5;
8011             islnm =  my_trnlnm(rslt,trndev,0);
8012           }
8013         }
8014       }
8015     }
8016
8017     trnend = islnm ? strlen(trndev) - 1 : 0;
8018     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8019     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8020     /* If the first element of the path is a logical name, determine
8021      * whether it has to be translated so we can add more directories. */
8022     if (!islnm || rooted) {
8023       *(cp1++) = ':';
8024       *(cp1++) = '[';
8025       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8026       else cp2++;
8027     }
8028     else {
8029       if (cp2 != dirend) {
8030         strcpy(rslt,trndev);
8031         cp1 = rslt + trnend;
8032         if (*cp2 != 0) {
8033           *(cp1++) = '.';
8034           cp2++;
8035         }
8036       }
8037       else {
8038         if (decc_disable_posix_root) {
8039           *(cp1++) = ':';
8040           hasdir = 0;
8041         }
8042       }
8043     }
8044     PerlMem_free(trndev);
8045   }
8046   else {
8047     *(cp1++) = '[';
8048     if (*cp2 == '.') {
8049       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8050         cp2 += 2;         /* skip over "./" - it's redundant */
8051         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8052       }
8053       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8054         *(cp1++) = '-';                                 /* "../" --> "-" */
8055         cp2 += 3;
8056       }
8057       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8058                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8059         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8060         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8061         cp2 += 4;
8062       }
8063       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8064         /* Escape the extra dots in EFS file specifications */
8065         *(cp1++) = '^';
8066       }
8067       if (cp2 > dirend) cp2 = dirend;
8068     }
8069     else *(cp1++) = '.';
8070   }
8071   for (; cp2 < dirend; cp2++) {
8072     if (*cp2 == '/') {
8073       if (*(cp2-1) == '/') continue;
8074       if (*(cp1-1) != '.') *(cp1++) = '.';
8075       infront = 0;
8076     }
8077     else if (!infront && *cp2 == '.') {
8078       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8079       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8080       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8081         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8082         else if (*(cp1-2) == '[') *(cp1-1) = '-';
8083         else {  /* back up over previous directory name */
8084           cp1--;
8085           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
8086           if (*(cp1-1) == '[') {
8087             memcpy(cp1,"000000.",7);
8088             cp1 += 7;
8089           }
8090         }
8091         cp2 += 2;
8092         if (cp2 == dirend) break;
8093       }
8094       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8095                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8096         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8097         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8098         if (!*(cp2+3)) {
8099           *(cp1++) = '.';  /* Simulate trailing '/' */
8100           cp2 += 2;  /* for loop will incr this to == dirend */
8101         }
8102         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8103       }
8104       else {
8105         if (decc_efs_charset == 0)
8106           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8107         else {
8108           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
8109           *(cp1++) = '.';
8110         }
8111       }
8112     }
8113     else {
8114       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
8115       if (*cp2 == '.') {
8116         if (decc_efs_charset == 0)
8117           *(cp1++) = '_';
8118         else {
8119           *(cp1++) = '^';
8120           *(cp1++) = '.';
8121         }
8122       }
8123       else                  *(cp1++) =  *cp2;
8124       infront = 1;
8125     }
8126   }
8127   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8128   if (hasdir) *(cp1++) = ']';
8129   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
8130   /* fixme for ODS5 */
8131   no_type_seen = 0;
8132   if (cp2 > lastdot)
8133     no_type_seen = 1;
8134   while (*cp2) {
8135     switch(*cp2) {
8136     case '?':
8137         if (decc_efs_charset == 0)
8138           *(cp1++) = '%';
8139         else
8140           *(cp1++) = '?';
8141         cp2++;
8142     case ' ':
8143         *(cp1)++ = '^';
8144         *(cp1)++ = '_';
8145         cp2++;
8146         break;
8147     case '.':
8148         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8149             decc_readdir_dropdotnotype) {
8150           *(cp1)++ = '^';
8151           *(cp1)++ = '.';
8152           cp2++;
8153
8154           /* trailing dot ==> '^..' on VMS */
8155           if (*cp2 == '\0') {
8156             *(cp1++) = '.';
8157             no_type_seen = 0;
8158           }
8159         }
8160         else {
8161           *(cp1++) = *(cp2++);
8162           no_type_seen = 0;
8163         }
8164         break;
8165     case '$':
8166          /* This could be a macro to be passed through */
8167         *(cp1++) = *(cp2++);
8168         if (*cp2 == '(') {
8169         const char * save_cp2;
8170         char * save_cp1;
8171         int is_macro;
8172
8173             /* paranoid check */
8174             save_cp2 = cp2;
8175             save_cp1 = cp1;
8176             is_macro = 0;
8177
8178             /* Test through */
8179             *(cp1++) = *(cp2++);
8180             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8181                 *(cp1++) = *(cp2++);
8182                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8183                     *(cp1++) = *(cp2++);
8184                 }
8185                 if (*cp2 == ')') {
8186                     *(cp1++) = *(cp2++);
8187                     is_macro = 1;
8188                 }
8189             }
8190             if (is_macro == 0) {
8191                 /* Not really a macro - never mind */
8192                 cp2 = save_cp2;
8193                 cp1 = save_cp1;
8194             }
8195         }
8196         break;
8197     case '\"':
8198     case '~':
8199     case '`':
8200     case '!':
8201     case '#':
8202     case '%':
8203     case '^':
8204         /* Don't escape again if following character is
8205          * already something we escape.
8206          */
8207         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8208             *(cp1++) = *(cp2++);
8209             break;
8210         }
8211         /* But otherwise fall through and escape it. */
8212     case '&':
8213     case '(':
8214     case ')':
8215     case '=':
8216     case '+':
8217     case '\'':
8218     case '@':
8219     case '[':
8220     case ']':
8221     case '{':
8222     case '}':
8223     case ':':
8224     case '\\':
8225     case '|':
8226     case '<':
8227     case '>':
8228         *(cp1++) = '^';
8229         *(cp1++) = *(cp2++);
8230         break;
8231     case ';':
8232         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8233          * which is wrong.  UNIX notation should be ".dir." unless
8234          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8235          * changing this behavior could break more things at this time.
8236          * efs character set effectively does not allow "." to be a version
8237          * delimiter as a further complication about changing this.
8238          */
8239         if (decc_filename_unix_report != 0) {
8240           *(cp1++) = '^';
8241         }
8242         *(cp1++) = *(cp2++);
8243         break;
8244     default:
8245         *(cp1++) = *(cp2++);
8246     }
8247   }
8248   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8249   char *lcp1;
8250     lcp1 = cp1;
8251     lcp1--;
8252      /* Fix me for "^]", but that requires making sure that you do
8253       * not back up past the start of the filename
8254       */
8255     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8256       *cp1++ = '.';
8257   }
8258   *cp1 = '\0';
8259
8260   if (utf8_flag != NULL)
8261     *utf8_flag = 0;
8262   return rslt;
8263
8264 }  /* end of do_tovmsspec() */
8265 /*}}}*/
8266 /* External entry points */
8267 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8268   { return do_tovmsspec(path,buf,0,NULL); }
8269 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8270   { return do_tovmsspec(path,buf,1,NULL); }
8271 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8272   { return do_tovmsspec(path,buf,0,utf8_fl); }
8273 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8274   { return do_tovmsspec(path,buf,1,utf8_fl); }
8275
8276 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8277 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8278   static char __tovmspath_retbuf[VMS_MAXRSS];
8279   int vmslen;
8280   char *pathified, *vmsified, *cp;
8281
8282   if (path == NULL) return NULL;
8283   pathified = PerlMem_malloc(VMS_MAXRSS);
8284   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8285   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
8286     PerlMem_free(pathified);
8287     return NULL;
8288   }
8289
8290   vmsified = NULL;
8291   if (buf == NULL)
8292      Newx(vmsified, VMS_MAXRSS, char);
8293   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8294     PerlMem_free(pathified);
8295     if (vmsified) Safefree(vmsified);
8296     return NULL;
8297   }
8298   PerlMem_free(pathified);
8299   if (buf) {
8300     return buf;
8301   }
8302   else if (ts) {
8303     vmslen = strlen(vmsified);
8304     Newx(cp,vmslen+1,char);
8305     memcpy(cp,vmsified,vmslen);
8306     cp[vmslen] = '\0';
8307     Safefree(vmsified);
8308     return cp;
8309   }
8310   else {
8311     strcpy(__tovmspath_retbuf,vmsified);
8312     Safefree(vmsified);
8313     return __tovmspath_retbuf;
8314   }
8315
8316 }  /* end of do_tovmspath() */
8317 /*}}}*/
8318 /* External entry points */
8319 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8320   { return do_tovmspath(path,buf,0, NULL); }
8321 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8322   { return do_tovmspath(path,buf,1, NULL); }
8323 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8324   { return do_tovmspath(path,buf,0,utf8_fl); }
8325 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8326   { return do_tovmspath(path,buf,1,utf8_fl); }
8327
8328
8329 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8330 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8331   static char __tounixpath_retbuf[VMS_MAXRSS];
8332   int unixlen;
8333   char *pathified, *unixified, *cp;
8334
8335   if (path == NULL) return NULL;
8336   pathified = PerlMem_malloc(VMS_MAXRSS);
8337   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8338   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
8339     PerlMem_free(pathified);
8340     return NULL;
8341   }
8342
8343   unixified = NULL;
8344   if (buf == NULL) {
8345       Newx(unixified, VMS_MAXRSS, char);
8346   }
8347   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
8348     PerlMem_free(pathified);
8349     if (unixified) Safefree(unixified);
8350     return NULL;
8351   }
8352   PerlMem_free(pathified);
8353   if (buf) {
8354     return buf;
8355   }
8356   else if (ts) {
8357     unixlen = strlen(unixified);
8358     Newx(cp,unixlen+1,char);
8359     memcpy(cp,unixified,unixlen);
8360     cp[unixlen] = '\0';
8361     Safefree(unixified);
8362     return cp;
8363   }
8364   else {
8365     strcpy(__tounixpath_retbuf,unixified);
8366     Safefree(unixified);
8367     return __tounixpath_retbuf;
8368   }
8369
8370 }  /* end of do_tounixpath() */
8371 /*}}}*/
8372 /* External entry points */
8373 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8374   { return do_tounixpath(path,buf,0,NULL); }
8375 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8376   { return do_tounixpath(path,buf,1,NULL); }
8377 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8378   { return do_tounixpath(path,buf,0,utf8_fl); }
8379 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8380   { return do_tounixpath(path,buf,1,utf8_fl); }
8381
8382 /*
8383  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
8384  *
8385  *****************************************************************************
8386  *                                                                           *
8387  *  Copyright (C) 1989-1994, 2007 by                                         *
8388  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
8389  *                                                                           *
8390  *  Permission is hereby granted for the reproduction of this software       *
8391  *  on condition that this copyright notice is included in source            *
8392  *  distributions of the software.  The code may be modified and             *
8393  *  distributed under the same terms as Perl itself.                         *
8394  *                                                                           *
8395  *  27-Aug-1994 Modified for inclusion in perl5                              *
8396  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
8397  *****************************************************************************
8398  */
8399
8400 /*
8401  * getredirection() is intended to aid in porting C programs
8402  * to VMS (Vax-11 C).  The native VMS environment does not support
8403  * '>' and '<' I/O redirection, or command line wild card expansion,
8404  * or a command line pipe mechanism using the '|' AND background
8405  * command execution '&'.  All of these capabilities are provided to any
8406  * C program which calls this procedure as the first thing in the
8407  * main program.
8408  * The piping mechanism will probably work with almost any 'filter' type
8409  * of program.  With suitable modification, it may useful for other
8410  * portability problems as well.
8411  *
8412  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
8413  */
8414 struct list_item
8415     {
8416     struct list_item *next;
8417     char *value;
8418     };
8419
8420 static void add_item(struct list_item **head,
8421                      struct list_item **tail,
8422                      char *value,
8423                      int *count);
8424
8425 static void mp_expand_wild_cards(pTHX_ char *item,
8426                                 struct list_item **head,
8427                                 struct list_item **tail,
8428                                 int *count);
8429
8430 static int background_process(pTHX_ int argc, char **argv);
8431
8432 static void pipe_and_fork(pTHX_ char **cmargv);
8433
8434 /*{{{ void getredirection(int *ac, char ***av)*/
8435 static void
8436 mp_getredirection(pTHX_ int *ac, char ***av)
8437 /*
8438  * Process vms redirection arg's.  Exit if any error is seen.
8439  * If getredirection() processes an argument, it is erased
8440  * from the vector.  getredirection() returns a new argc and argv value.
8441  * In the event that a background command is requested (by a trailing "&"),
8442  * this routine creates a background subprocess, and simply exits the program.
8443  *
8444  * Warning: do not try to simplify the code for vms.  The code
8445  * presupposes that getredirection() is called before any data is
8446  * read from stdin or written to stdout.
8447  *
8448  * Normal usage is as follows:
8449  *
8450  *      main(argc, argv)
8451  *      int             argc;
8452  *      char            *argv[];
8453  *      {
8454  *              getredirection(&argc, &argv);
8455  *      }
8456  */
8457 {
8458     int                 argc = *ac;     /* Argument Count         */
8459     char                **argv = *av;   /* Argument Vector        */
8460     char                *ap;            /* Argument pointer       */
8461     int                 j;              /* argv[] index           */
8462     int                 item_count = 0; /* Count of Items in List */
8463     struct list_item    *list_head = 0; /* First Item in List       */
8464     struct list_item    *list_tail;     /* Last Item in List        */
8465     char                *in = NULL;     /* Input File Name          */
8466     char                *out = NULL;    /* Output File Name         */
8467     char                *outmode = "w"; /* Mode to Open Output File */
8468     char                *err = NULL;    /* Error File Name          */
8469     char                *errmode = "w"; /* Mode to Open Error File  */
8470     int                 cmargc = 0;     /* Piped Command Arg Count  */
8471     char                **cmargv = NULL;/* Piped Command Arg Vector */
8472
8473     /*
8474      * First handle the case where the last thing on the line ends with
8475      * a '&'.  This indicates the desire for the command to be run in a
8476      * subprocess, so we satisfy that desire.
8477      */
8478     ap = argv[argc-1];
8479     if (0 == strcmp("&", ap))
8480        exit(background_process(aTHX_ --argc, argv));
8481     if (*ap && '&' == ap[strlen(ap)-1])
8482         {
8483         ap[strlen(ap)-1] = '\0';
8484        exit(background_process(aTHX_ argc, argv));
8485         }
8486     /*
8487      * Now we handle the general redirection cases that involve '>', '>>',
8488      * '<', and pipes '|'.
8489      */
8490     for (j = 0; j < argc; ++j)
8491         {
8492         if (0 == strcmp("<", argv[j]))
8493             {
8494             if (j+1 >= argc)
8495                 {
8496                 fprintf(stderr,"No input file after < on command line");
8497                 exit(LIB$_WRONUMARG);
8498                 }
8499             in = argv[++j];
8500             continue;
8501             }
8502         if ('<' == *(ap = argv[j]))
8503             {
8504             in = 1 + ap;
8505             continue;
8506             }
8507         if (0 == strcmp(">", ap))
8508             {
8509             if (j+1 >= argc)
8510                 {
8511                 fprintf(stderr,"No output file after > on command line");
8512                 exit(LIB$_WRONUMARG);
8513                 }
8514             out = argv[++j];
8515             continue;
8516             }
8517         if ('>' == *ap)
8518             {
8519             if ('>' == ap[1])
8520                 {
8521                 outmode = "a";
8522                 if ('\0' == ap[2])
8523                     out = argv[++j];
8524                 else
8525                     out = 2 + ap;
8526                 }
8527             else
8528                 out = 1 + ap;
8529             if (j >= argc)
8530                 {
8531                 fprintf(stderr,"No output file after > or >> on command line");
8532                 exit(LIB$_WRONUMARG);
8533                 }
8534             continue;
8535             }
8536         if (('2' == *ap) && ('>' == ap[1]))
8537             {
8538             if ('>' == ap[2])
8539                 {
8540                 errmode = "a";
8541                 if ('\0' == ap[3])
8542                     err = argv[++j];
8543                 else
8544                     err = 3 + ap;
8545                 }
8546             else
8547                 if ('\0' == ap[2])
8548                     err = argv[++j];
8549                 else
8550                     err = 2 + ap;
8551             if (j >= argc)
8552                 {
8553                 fprintf(stderr,"No output file after 2> or 2>> on command line");
8554                 exit(LIB$_WRONUMARG);
8555                 }
8556             continue;
8557             }
8558         if (0 == strcmp("|", argv[j]))
8559             {
8560             if (j+1 >= argc)
8561                 {
8562                 fprintf(stderr,"No command into which to pipe on command line");
8563                 exit(LIB$_WRONUMARG);
8564                 }
8565             cmargc = argc-(j+1);
8566             cmargv = &argv[j+1];
8567             argc = j;
8568             continue;
8569             }
8570         if ('|' == *(ap = argv[j]))
8571             {
8572             ++argv[j];
8573             cmargc = argc-j;
8574             cmargv = &argv[j];
8575             argc = j;
8576             continue;
8577             }
8578         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
8579         }
8580     /*
8581      * Allocate and fill in the new argument vector, Some Unix's terminate
8582      * the list with an extra null pointer.
8583      */
8584     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
8585     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8586     *av = argv;
8587     for (j = 0; j < item_count; ++j, list_head = list_head->next)
8588         argv[j] = list_head->value;
8589     *ac = item_count;
8590     if (cmargv != NULL)
8591         {
8592         if (out != NULL)
8593             {
8594             fprintf(stderr,"'|' and '>' may not both be specified on command line");
8595             exit(LIB$_INVARGORD);
8596             }
8597         pipe_and_fork(aTHX_ cmargv);
8598         }
8599
8600     /* Check for input from a pipe (mailbox) */
8601
8602     if (in == NULL && 1 == isapipe(0))
8603         {
8604         char mbxname[L_tmpnam];
8605         long int bufsize;
8606         long int dvi_item = DVI$_DEVBUFSIZ;
8607         $DESCRIPTOR(mbxnam, "");
8608         $DESCRIPTOR(mbxdevnam, "");
8609
8610         /* Input from a pipe, reopen it in binary mode to disable       */
8611         /* carriage control processing.                                 */
8612
8613         fgetname(stdin, mbxname);
8614         mbxnam.dsc$a_pointer = mbxname;
8615         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
8616         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
8617         mbxdevnam.dsc$a_pointer = mbxname;
8618         mbxdevnam.dsc$w_length = sizeof(mbxname);
8619         dvi_item = DVI$_DEVNAM;
8620         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
8621         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
8622         set_errno(0);
8623         set_vaxc_errno(1);
8624         freopen(mbxname, "rb", stdin);
8625         if (errno != 0)
8626             {
8627             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
8628             exit(vaxc$errno);
8629             }
8630         }
8631     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
8632         {
8633         fprintf(stderr,"Can't open input file %s as stdin",in);
8634         exit(vaxc$errno);
8635         }
8636     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
8637         {
8638         fprintf(stderr,"Can't open output file %s as stdout",out);
8639         exit(vaxc$errno);
8640         }
8641         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
8642
8643     if (err != NULL) {
8644         if (strcmp(err,"&1") == 0) {
8645             dup2(fileno(stdout), fileno(stderr));
8646             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
8647         } else {
8648         FILE *tmperr;
8649         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
8650             {
8651             fprintf(stderr,"Can't open error file %s as stderr",err);
8652             exit(vaxc$errno);
8653             }
8654             fclose(tmperr);
8655            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
8656                 {
8657                 exit(vaxc$errno);
8658                 }
8659             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
8660         }
8661         }
8662 #ifdef ARGPROC_DEBUG
8663     PerlIO_printf(Perl_debug_log, "Arglist:\n");
8664     for (j = 0; j < *ac;  ++j)
8665         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
8666 #endif
8667    /* Clear errors we may have hit expanding wildcards, so they don't
8668       show up in Perl's $! later */
8669    set_errno(0); set_vaxc_errno(1);
8670 }  /* end of getredirection() */
8671 /*}}}*/
8672
8673 static void add_item(struct list_item **head,
8674                      struct list_item **tail,
8675                      char *value,
8676                      int *count)
8677 {
8678     if (*head == 0)
8679         {
8680         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8681         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8682         *tail = *head;
8683         }
8684     else {
8685         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8686         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8687         *tail = (*tail)->next;
8688         }
8689     (*tail)->value = value;
8690     ++(*count);
8691 }
8692
8693 static void mp_expand_wild_cards(pTHX_ char *item,
8694                               struct list_item **head,
8695                               struct list_item **tail,
8696                               int *count)
8697 {
8698 int expcount = 0;
8699 unsigned long int context = 0;
8700 int isunix = 0;
8701 int item_len = 0;
8702 char *had_version;
8703 char *had_device;
8704 int had_directory;
8705 char *devdir,*cp;
8706 char *vmsspec;
8707 $DESCRIPTOR(filespec, "");
8708 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
8709 $DESCRIPTOR(resultspec, "");
8710 unsigned long int lff_flags = 0;
8711 int sts;
8712 int rms_sts;
8713
8714 #ifdef VMS_LONGNAME_SUPPORT
8715     lff_flags = LIB$M_FIL_LONG_NAMES;
8716 #endif
8717
8718     for (cp = item; *cp; cp++) {
8719         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
8720         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
8721     }
8722     if (!*cp || isspace(*cp))
8723         {
8724         add_item(head, tail, item, count);
8725         return;
8726         }
8727     else
8728         {
8729      /* "double quoted" wild card expressions pass as is */
8730      /* From DCL that means using e.g.:                  */
8731      /* perl program """perl.*"""                        */
8732      item_len = strlen(item);
8733      if ( '"' == *item && '"' == item[item_len-1] )
8734        {
8735        item++;
8736        item[item_len-2] = '\0';
8737        add_item(head, tail, item, count);
8738        return;
8739        }
8740      }
8741     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
8742     resultspec.dsc$b_class = DSC$K_CLASS_D;
8743     resultspec.dsc$a_pointer = NULL;
8744     vmsspec = PerlMem_malloc(VMS_MAXRSS);
8745     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8746     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
8747       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
8748     if (!isunix || !filespec.dsc$a_pointer)
8749       filespec.dsc$a_pointer = item;
8750     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
8751     /*
8752      * Only return version specs, if the caller specified a version
8753      */
8754     had_version = strchr(item, ';');
8755     /*
8756      * Only return device and directory specs, if the caller specifed either.
8757      */
8758     had_device = strchr(item, ':');
8759     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
8760
8761     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
8762                                  (&filespec, &resultspec, &context,
8763                                   &defaultspec, 0, &rms_sts, &lff_flags)))
8764         {
8765         char *string;
8766         char *c;
8767
8768         string = PerlMem_malloc(resultspec.dsc$w_length+1);
8769         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8770         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
8771         string[resultspec.dsc$w_length] = '\0';
8772         if (NULL == had_version)
8773             *(strrchr(string, ';')) = '\0';
8774         if ((!had_directory) && (had_device == NULL))
8775             {
8776             if (NULL == (devdir = strrchr(string, ']')))
8777                 devdir = strrchr(string, '>');
8778             strcpy(string, devdir + 1);
8779             }
8780         /*
8781          * Be consistent with what the C RTL has already done to the rest of
8782          * the argv items and lowercase all of these names.
8783          */
8784         if (!decc_efs_case_preserve) {
8785             for (c = string; *c; ++c)
8786             if (isupper(*c))
8787                 *c = tolower(*c);
8788         }
8789         if (isunix) trim_unixpath(string,item,1);
8790         add_item(head, tail, string, count);
8791         ++expcount;
8792     }
8793     PerlMem_free(vmsspec);
8794     if (sts != RMS$_NMF)
8795         {
8796         set_vaxc_errno(sts);
8797         switch (sts)
8798             {
8799             case RMS$_FNF: case RMS$_DNF:
8800                 set_errno(ENOENT); break;
8801             case RMS$_DIR:
8802                 set_errno(ENOTDIR); break;
8803             case RMS$_DEV:
8804                 set_errno(ENODEV); break;
8805             case RMS$_FNM: case RMS$_SYN:
8806                 set_errno(EINVAL); break;
8807             case RMS$_PRV:
8808                 set_errno(EACCES); break;
8809             default:
8810                 _ckvmssts_noperl(sts);
8811             }
8812         }
8813     if (expcount == 0)
8814         add_item(head, tail, item, count);
8815     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
8816     _ckvmssts_noperl(lib$find_file_end(&context));
8817 }
8818
8819 static int child_st[2];/* Event Flag set when child process completes   */
8820
8821 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
8822
8823 static unsigned long int exit_handler(int *status)
8824 {
8825 short iosb[4];
8826
8827     if (0 == child_st[0])
8828         {
8829 #ifdef ARGPROC_DEBUG
8830         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
8831 #endif
8832         fflush(stdout);     /* Have to flush pipe for binary data to    */
8833                             /* terminate properly -- <tp@mccall.com>    */
8834         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
8835         sys$dassgn(child_chan);
8836         fclose(stdout);
8837         sys$synch(0, child_st);
8838         }
8839     return(1);
8840 }
8841
8842 static void sig_child(int chan)
8843 {
8844 #ifdef ARGPROC_DEBUG
8845     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
8846 #endif
8847     if (child_st[0] == 0)
8848         child_st[0] = 1;
8849 }
8850
8851 static struct exit_control_block exit_block =
8852     {
8853     0,
8854     exit_handler,
8855     1,
8856     &exit_block.exit_status,
8857     0
8858     };
8859
8860 static void
8861 pipe_and_fork(pTHX_ char **cmargv)
8862 {
8863     PerlIO *fp;
8864     struct dsc$descriptor_s *vmscmd;
8865     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
8866     int sts, j, l, ismcr, quote, tquote = 0;
8867
8868     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
8869     vms_execfree(vmscmd);
8870
8871     j = l = 0;
8872     p = subcmd;
8873     q = cmargv[0];
8874     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
8875               && toupper(*(q+2)) == 'R' && !*(q+3);
8876
8877     while (q && l < MAX_DCL_LINE_LENGTH) {
8878         if (!*q) {
8879             if (j > 0 && quote) {
8880                 *p++ = '"';
8881                 l++;
8882             }
8883             q = cmargv[++j];
8884             if (q) {
8885                 if (ismcr && j > 1) quote = 1;
8886                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
8887                 *p++ = ' ';
8888                 l++;
8889                 if (quote || tquote) {
8890                     *p++ = '"';
8891                     l++;
8892                 }
8893             }
8894         } else {
8895             if ((quote||tquote) && *q == '"') {
8896                 *p++ = '"';
8897                 l++;
8898             }
8899             *p++ = *q++;
8900             l++;
8901         }
8902     }
8903     *p = '\0';
8904
8905     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
8906     if (fp == Nullfp) {
8907         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
8908     }
8909 }
8910
8911 static int background_process(pTHX_ int argc, char **argv)
8912 {
8913 char command[MAX_DCL_SYMBOL + 1] = "$";
8914 $DESCRIPTOR(value, "");
8915 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
8916 static $DESCRIPTOR(null, "NLA0:");
8917 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
8918 char pidstring[80];
8919 $DESCRIPTOR(pidstr, "");
8920 int pid;
8921 unsigned long int flags = 17, one = 1, retsts;
8922 int len;
8923
8924     strcat(command, argv[0]);
8925     len = strlen(command);
8926     while (--argc && (len < MAX_DCL_SYMBOL))
8927         {
8928         strcat(command, " \"");
8929         strcat(command, *(++argv));
8930         strcat(command, "\"");
8931         len = strlen(command);
8932         }
8933     value.dsc$a_pointer = command;
8934     value.dsc$w_length = strlen(value.dsc$a_pointer);
8935     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
8936     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
8937     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
8938         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8939     }
8940     else {
8941         _ckvmssts_noperl(retsts);
8942     }
8943 #ifdef ARGPROC_DEBUG
8944     PerlIO_printf(Perl_debug_log, "%s\n", command);
8945 #endif
8946     sprintf(pidstring, "%08X", pid);
8947     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8948     pidstr.dsc$a_pointer = pidstring;
8949     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8950     lib$set_symbol(&pidsymbol, &pidstr);
8951     return(SS$_NORMAL);
8952 }
8953 /*}}}*/
8954 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8955
8956
8957 /* OS-specific initialization at image activation (not thread startup) */
8958 /* Older VAXC header files lack these constants */
8959 #ifndef JPI$_RIGHTS_SIZE
8960 #  define JPI$_RIGHTS_SIZE 817
8961 #endif
8962 #ifndef KGB$M_SUBSYSTEM
8963 #  define KGB$M_SUBSYSTEM 0x8
8964 #endif
8965
8966 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8967
8968 /*{{{void vms_image_init(int *, char ***)*/
8969 void
8970 vms_image_init(int *argcp, char ***argvp)
8971 {
8972   char eqv[LNM$C_NAMLENGTH+1] = "";
8973   unsigned int len, tabct = 8, tabidx = 0;
8974   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8975   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8976   unsigned short int dummy, rlen;
8977   struct dsc$descriptor_s **tabvec;
8978 #if defined(PERL_IMPLICIT_CONTEXT)
8979   pTHX = NULL;
8980 #endif
8981   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
8982                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
8983                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8984                                  {          0,                0,    0,      0} };
8985
8986 #ifdef KILL_BY_SIGPRC
8987     Perl_csighandler_init();
8988 #endif
8989
8990   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8991   _ckvmssts_noperl(iosb[0]);
8992   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8993     if (iprv[i]) {           /* Running image installed with privs? */
8994       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
8995       will_taint = TRUE;
8996       break;
8997     }
8998   }
8999   /* Rights identifiers might trigger tainting as well. */
9000   if (!will_taint && (rlen || rsz)) {
9001     while (rlen < rsz) {
9002       /* We didn't get all the identifiers on the first pass.  Allocate a
9003        * buffer much larger than $GETJPI wants (rsz is size in bytes that
9004        * were needed to hold all identifiers at time of last call; we'll
9005        * allocate that many unsigned long ints), and go back and get 'em.
9006        * If it gave us less than it wanted to despite ample buffer space,
9007        * something's broken.  Is your system missing a system identifier?
9008        */
9009       if (rsz <= jpilist[1].buflen) {
9010          /* Perl_croak accvios when used this early in startup. */
9011          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9012                          rsz, (unsigned long) jpilist[1].buflen,
9013                          "Check your rights database for corruption.\n");
9014          exit(SS$_ABORT);
9015       }
9016       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9017       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9018       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9019       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9020       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9021       _ckvmssts_noperl(iosb[0]);
9022     }
9023     mask = jpilist[1].bufadr;
9024     /* Check attribute flags for each identifier (2nd longword); protected
9025      * subsystem identifiers trigger tainting.
9026      */
9027     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9028       if (mask[i] & KGB$M_SUBSYSTEM) {
9029         will_taint = TRUE;
9030         break;
9031       }
9032     }
9033     if (mask != rlst) PerlMem_free(mask);
9034   }
9035
9036   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9037    * logical, some versions of the CRTL will add a phanthom /000000/
9038    * directory.  This needs to be removed.
9039    */
9040   if (decc_filename_unix_report) {
9041   char * zeros;
9042   int ulen;
9043     ulen = strlen(argvp[0][0]);
9044     if (ulen > 7) {
9045       zeros = strstr(argvp[0][0], "/000000/");
9046       if (zeros != NULL) {
9047         int mlen;
9048         mlen = ulen - (zeros - argvp[0][0]) - 7;
9049         memmove(zeros, &zeros[7], mlen);
9050         ulen = ulen - 7;
9051         argvp[0][0][ulen] = '\0';
9052       }
9053     }
9054     /* It also may have a trailing dot that needs to be removed otherwise
9055      * it will be converted to VMS mode incorrectly.
9056      */
9057     ulen--;
9058     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9059       argvp[0][0][ulen] = '\0';
9060   }
9061
9062   /* We need to use this hack to tell Perl it should run with tainting,
9063    * since its tainting flag may be part of the PL_curinterp struct, which
9064    * hasn't been allocated when vms_image_init() is called.
9065    */
9066   if (will_taint) {
9067     char **newargv, **oldargv;
9068     oldargv = *argvp;
9069     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9070     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9071     newargv[0] = oldargv[0];
9072     newargv[1] = PerlMem_malloc(3 * sizeof(char));
9073     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9074     strcpy(newargv[1], "-T");
9075     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9076     (*argcp)++;
9077     newargv[*argcp] = NULL;
9078     /* We orphan the old argv, since we don't know where it's come from,
9079      * so we don't know how to free it.
9080      */
9081     *argvp = newargv;
9082   }
9083   else {  /* Did user explicitly request tainting? */
9084     int i;
9085     char *cp, **av = *argvp;
9086     for (i = 1; i < *argcp; i++) {
9087       if (*av[i] != '-') break;
9088       for (cp = av[i]+1; *cp; cp++) {
9089         if (*cp == 'T') { will_taint = 1; break; }
9090         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9091                   strchr("DFIiMmx",*cp)) break;
9092       }
9093       if (will_taint) break;
9094     }
9095   }
9096
9097   for (tabidx = 0;
9098        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9099        tabidx++) {
9100     if (!tabidx) {
9101       tabvec = (struct dsc$descriptor_s **)
9102             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9103       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9104     }
9105     else if (tabidx >= tabct) {
9106       tabct += 8;
9107       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9108       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9109     }
9110     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9111     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9112     tabvec[tabidx]->dsc$w_length  = 0;
9113     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9114     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
9115     tabvec[tabidx]->dsc$a_pointer = NULL;
9116     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9117   }
9118   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9119
9120   getredirection(argcp,argvp);
9121 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9122   {
9123 # include <reentrancy.h>
9124   decc$set_reentrancy(C$C_MULTITHREAD);
9125   }
9126 #endif
9127   return;
9128 }
9129 /*}}}*/
9130
9131
9132 /* trim_unixpath()
9133  * Trim Unix-style prefix off filespec, so it looks like what a shell
9134  * glob expansion would return (i.e. from specified prefix on, not
9135  * full path).  Note that returned filespec is Unix-style, regardless
9136  * of whether input filespec was VMS-style or Unix-style.
9137  *
9138  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9139  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9140  * vector of options; at present, only bit 0 is used, and if set tells
9141  * trim unixpath to try the current default directory as a prefix when
9142  * presented with a possibly ambiguous ... wildcard.
9143  *
9144  * Returns !=0 on success, with trimmed filespec replacing contents of
9145  * fspec, and 0 on failure, with contents of fpsec unchanged.
9146  */
9147 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9148 int
9149 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9150 {
9151   char *unixified, *unixwild,
9152        *template, *base, *end, *cp1, *cp2;
9153   register int tmplen, reslen = 0, dirs = 0;
9154
9155   unixwild = PerlMem_malloc(VMS_MAXRSS);
9156   if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
9157   if (!wildspec || !fspec) return 0;
9158   template = unixwild;
9159   if (strpbrk(wildspec,"]>:") != NULL) {
9160     if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
9161         PerlMem_free(unixwild);
9162         return 0;
9163     }
9164   }
9165   else {
9166     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
9167     unixwild[VMS_MAXRSS-1] = 0;
9168   }
9169   unixified = PerlMem_malloc(VMS_MAXRSS);
9170   if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
9171   if (strpbrk(fspec,"]>:") != NULL) {
9172     if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
9173         PerlMem_free(unixwild);
9174         PerlMem_free(unixified);
9175         return 0;
9176     }
9177     else base = unixified;
9178     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9179      * check to see that final result fits into (isn't longer than) fspec */
9180     reslen = strlen(fspec);
9181   }
9182   else base = fspec;
9183
9184   /* No prefix or absolute path on wildcard, so nothing to remove */
9185   if (!*template || *template == '/') {
9186     PerlMem_free(unixwild);
9187     if (base == fspec) {
9188         PerlMem_free(unixified);
9189         return 1;
9190     }
9191     tmplen = strlen(unixified);
9192     if (tmplen > reslen) {
9193         PerlMem_free(unixified);
9194         return 0;  /* not enough space */
9195     }
9196     /* Copy unixified resultant, including trailing NUL */
9197     memmove(fspec,unixified,tmplen+1);
9198     PerlMem_free(unixified);
9199     return 1;
9200   }
9201
9202   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
9203   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
9204     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
9205     for (cp1 = end ;cp1 >= base; cp1--)
9206       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9207         { cp1++; break; }
9208     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9209     PerlMem_free(unixified);
9210     PerlMem_free(unixwild);
9211     return 1;
9212   }
9213   else {
9214     char *tpl, *lcres;
9215     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9216     int ells = 1, totells, segdirs, match;
9217     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9218                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9219
9220     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9221     totells = ells;
9222     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9223     tpl = PerlMem_malloc(VMS_MAXRSS);
9224     if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
9225     if (ellipsis == template && opts & 1) {
9226       /* Template begins with an ellipsis.  Since we can't tell how many
9227        * directory names at the front of the resultant to keep for an
9228        * arbitrary starting point, we arbitrarily choose the current
9229        * default directory as a starting point.  If it's there as a prefix,
9230        * clip it off.  If not, fall through and act as if the leading
9231        * ellipsis weren't there (i.e. return shortest possible path that
9232        * could match template).
9233        */
9234       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9235           PerlMem_free(tpl);
9236           PerlMem_free(unixified);
9237           PerlMem_free(unixwild);
9238           return 0;
9239       }
9240       if (!decc_efs_case_preserve) {
9241         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9242           if (_tolower(*cp1) != _tolower(*cp2)) break;
9243       }
9244       segdirs = dirs - totells;  /* Min # of dirs we must have left */
9245       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9246       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9247         memmove(fspec,cp2+1,end - cp2);
9248         PerlMem_free(tpl);
9249         PerlMem_free(unixified);
9250         PerlMem_free(unixwild);
9251         return 1;
9252       }
9253     }
9254     /* First off, back up over constant elements at end of path */
9255     if (dirs) {
9256       for (front = end ; front >= base; front--)
9257          if (*front == '/' && !dirs--) { front++; break; }
9258     }
9259     lcres = PerlMem_malloc(VMS_MAXRSS);
9260     if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
9261     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9262          cp1++,cp2++) {
9263             if (!decc_efs_case_preserve) {
9264                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
9265             }
9266             else {
9267                 *cp2 = *cp1;
9268             }
9269     }
9270     if (cp1 != '\0') {
9271         PerlMem_free(tpl);
9272         PerlMem_free(unixified);
9273         PerlMem_free(unixwild);
9274         PerlMem_free(lcres);
9275         return 0;  /* Path too long. */
9276     }
9277     lcend = cp2;
9278     *cp2 = '\0';  /* Pick up with memcpy later */
9279     lcfront = lcres + (front - base);
9280     /* Now skip over each ellipsis and try to match the path in front of it. */
9281     while (ells--) {
9282       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
9283         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
9284             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
9285       if (cp1 < template) break; /* template started with an ellipsis */
9286       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9287         ellipsis = cp1; continue;
9288       }
9289       wilddsc.dsc$a_pointer = tpl;
9290       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9291       nextell = cp1;
9292       for (segdirs = 0, cp2 = tpl;
9293            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9294            cp1++, cp2++) {
9295          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9296          else {
9297             if (!decc_efs_case_preserve) {
9298               *cp2 = _tolower(*cp1);  /* else lowercase for match */
9299             }
9300             else {
9301               *cp2 = *cp1;  /* else preserve case for match */
9302             }
9303          }
9304          if (*cp2 == '/') segdirs++;
9305       }
9306       if (cp1 != ellipsis - 1) {
9307           PerlMem_free(tpl);
9308           PerlMem_free(unixified);
9309           PerlMem_free(unixwild);
9310           PerlMem_free(lcres);
9311           return 0; /* Path too long */
9312       }
9313       /* Back up at least as many dirs as in template before matching */
9314       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9315         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9316       for (match = 0; cp1 > lcres;) {
9317         resdsc.dsc$a_pointer = cp1;
9318         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9319           match++;
9320           if (match == 1) lcfront = cp1;
9321         }
9322         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9323       }
9324       if (!match) {
9325         PerlMem_free(tpl);
9326         PerlMem_free(unixified);
9327         PerlMem_free(unixwild);
9328         PerlMem_free(lcres);
9329         return 0;  /* Can't find prefix ??? */
9330       }
9331       if (match > 1 && opts & 1) {
9332         /* This ... wildcard could cover more than one set of dirs (i.e.
9333          * a set of similar dir names is repeated).  If the template
9334          * contains more than 1 ..., upstream elements could resolve the
9335          * ambiguity, but it's not worth a full backtracking setup here.
9336          * As a quick heuristic, clip off the current default directory
9337          * if it's present to find the trimmed spec, else use the
9338          * shortest string that this ... could cover.
9339          */
9340         char def[NAM$C_MAXRSS+1], *st;
9341
9342         if (getcwd(def, sizeof def,0) == NULL) {
9343             Safefree(unixified);
9344             Safefree(unixwild);
9345             Safefree(lcres);
9346             Safefree(tpl);
9347             return 0;
9348         }
9349         if (!decc_efs_case_preserve) {
9350           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9351             if (_tolower(*cp1) != _tolower(*cp2)) break;
9352         }
9353         segdirs = dirs - totells;  /* Min # of dirs we must have left */
9354         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9355         if (*cp1 == '\0' && *cp2 == '/') {
9356           memmove(fspec,cp2+1,end - cp2);
9357           PerlMem_free(tpl);
9358           PerlMem_free(unixified);
9359           PerlMem_free(unixwild);
9360           PerlMem_free(lcres);
9361           return 1;
9362         }
9363         /* Nope -- stick with lcfront from above and keep going. */
9364       }
9365     }
9366     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
9367     PerlMem_free(tpl);
9368     PerlMem_free(unixified);
9369     PerlMem_free(unixwild);
9370     PerlMem_free(lcres);
9371     return 1;
9372     ellipsis = nextell;
9373   }
9374
9375 }  /* end of trim_unixpath() */
9376 /*}}}*/
9377
9378
9379 /*
9380  *  VMS readdir() routines.
9381  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
9382  *
9383  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
9384  *  Minor modifications to original routines.
9385  */
9386
9387 /* readdir may have been redefined by reentr.h, so make sure we get
9388  * the local version for what we do here.
9389  */
9390 #ifdef readdir
9391 # undef readdir
9392 #endif
9393 #if !defined(PERL_IMPLICIT_CONTEXT)
9394 # define readdir Perl_readdir
9395 #else
9396 # define readdir(a) Perl_readdir(aTHX_ a)
9397 #endif
9398
9399     /* Number of elements in vms_versions array */
9400 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
9401
9402 /*
9403  *  Open a directory, return a handle for later use.
9404  */
9405 /*{{{ DIR *opendir(char*name) */
9406 DIR *
9407 Perl_opendir(pTHX_ const char *name)
9408 {
9409     DIR *dd;
9410     char *dir;
9411     Stat_t sb;
9412
9413     Newx(dir, VMS_MAXRSS, char);
9414     if (do_tovmspath(name,dir,0,NULL) == NULL) {
9415       Safefree(dir);
9416       return NULL;
9417     }
9418     /* Check access before stat; otherwise stat does not
9419      * accurately report whether it's a directory.
9420      */
9421     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
9422       /* cando_by_name has already set errno */
9423       Safefree(dir);
9424       return NULL;
9425     }
9426     if (flex_stat(dir,&sb) == -1) return NULL;
9427     if (!S_ISDIR(sb.st_mode)) {
9428       Safefree(dir);
9429       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
9430       return NULL;
9431     }
9432     /* Get memory for the handle, and the pattern. */
9433     Newx(dd,1,DIR);
9434     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
9435
9436     /* Fill in the fields; mainly playing with the descriptor. */
9437     sprintf(dd->pattern, "%s*.*",dir);
9438     Safefree(dir);
9439     dd->context = 0;
9440     dd->count = 0;
9441     dd->flags = 0;
9442     /* By saying we always want the result of readdir() in unix format, we
9443      * are really saying we want all the escapes removed.  Otherwise the caller,
9444      * having no way to know whether it's already in VMS format, might send it
9445      * through tovmsspec again, thus double escaping.
9446      */
9447     dd->flags = PERL_VMSDIR_M_UNIXSPECS;
9448     dd->pat.dsc$a_pointer = dd->pattern;
9449     dd->pat.dsc$w_length = strlen(dd->pattern);
9450     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
9451     dd->pat.dsc$b_class = DSC$K_CLASS_S;
9452 #if defined(USE_ITHREADS)
9453     Newx(dd->mutex,1,perl_mutex);
9454     MUTEX_INIT( (perl_mutex *) dd->mutex );
9455 #else
9456     dd->mutex = NULL;
9457 #endif
9458
9459     return dd;
9460 }  /* end of opendir() */
9461 /*}}}*/
9462
9463 /*
9464  *  Set the flag to indicate we want versions or not.
9465  */
9466 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
9467 void
9468 vmsreaddirversions(DIR *dd, int flag)
9469 {
9470     if (flag)
9471         dd->flags |= PERL_VMSDIR_M_VERSIONS;
9472     else
9473         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9474 }
9475 /*}}}*/
9476
9477 /*
9478  *  Free up an opened directory.
9479  */
9480 /*{{{ void closedir(DIR *dd)*/
9481 void
9482 Perl_closedir(DIR *dd)
9483 {
9484     int sts;
9485
9486     sts = lib$find_file_end(&dd->context);
9487     Safefree(dd->pattern);
9488 #if defined(USE_ITHREADS)
9489     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
9490     Safefree(dd->mutex);
9491 #endif
9492     Safefree(dd);
9493 }
9494 /*}}}*/
9495
9496 /*
9497  *  Collect all the version numbers for the current file.
9498  */
9499 static void
9500 collectversions(pTHX_ DIR *dd)
9501 {
9502     struct dsc$descriptor_s     pat;
9503     struct dsc$descriptor_s     res;
9504     struct dirent *e;
9505     char *p, *text, *buff;
9506     int i;
9507     unsigned long context, tmpsts;
9508
9509     /* Convenient shorthand. */
9510     e = &dd->entry;
9511
9512     /* Add the version wildcard, ignoring the "*.*" put on before */
9513     i = strlen(dd->pattern);
9514     Newx(text,i + e->d_namlen + 3,char);
9515     strcpy(text, dd->pattern);
9516     sprintf(&text[i - 3], "%s;*", e->d_name);
9517
9518     /* Set up the pattern descriptor. */
9519     pat.dsc$a_pointer = text;
9520     pat.dsc$w_length = i + e->d_namlen - 1;
9521     pat.dsc$b_dtype = DSC$K_DTYPE_T;
9522     pat.dsc$b_class = DSC$K_CLASS_S;
9523
9524     /* Set up result descriptor. */
9525     Newx(buff, VMS_MAXRSS, char);
9526     res.dsc$a_pointer = buff;
9527     res.dsc$w_length = VMS_MAXRSS - 1;
9528     res.dsc$b_dtype = DSC$K_DTYPE_T;
9529     res.dsc$b_class = DSC$K_CLASS_S;
9530
9531     /* Read files, collecting versions. */
9532     for (context = 0, e->vms_verscount = 0;
9533          e->vms_verscount < VERSIZE(e);
9534          e->vms_verscount++) {
9535         unsigned long rsts;
9536         unsigned long flags = 0;
9537
9538 #ifdef VMS_LONGNAME_SUPPORT
9539         flags = LIB$M_FIL_LONG_NAMES;
9540 #endif
9541         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
9542         if (tmpsts == RMS$_NMF || context == 0) break;
9543         _ckvmssts(tmpsts);
9544         buff[VMS_MAXRSS - 1] = '\0';
9545         if ((p = strchr(buff, ';')))
9546             e->vms_versions[e->vms_verscount] = atoi(p + 1);
9547         else
9548             e->vms_versions[e->vms_verscount] = -1;
9549     }
9550
9551     _ckvmssts(lib$find_file_end(&context));
9552     Safefree(text);
9553     Safefree(buff);
9554
9555 }  /* end of collectversions() */
9556
9557 /*
9558  *  Read the next entry from the directory.
9559  */
9560 /*{{{ struct dirent *readdir(DIR *dd)*/
9561 struct dirent *
9562 Perl_readdir(pTHX_ DIR *dd)
9563 {
9564     struct dsc$descriptor_s     res;
9565     char *p, *buff;
9566     unsigned long int tmpsts;
9567     unsigned long rsts;
9568     unsigned long flags = 0;
9569     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
9570     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
9571
9572     /* Set up result descriptor, and get next file. */
9573     Newx(buff, VMS_MAXRSS, char);
9574     res.dsc$a_pointer = buff;
9575     res.dsc$w_length = VMS_MAXRSS - 1;
9576     res.dsc$b_dtype = DSC$K_DTYPE_T;
9577     res.dsc$b_class = DSC$K_CLASS_S;
9578
9579 #ifdef VMS_LONGNAME_SUPPORT
9580     flags = LIB$M_FIL_LONG_NAMES;
9581 #endif
9582
9583     tmpsts = lib$find_file
9584         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
9585     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
9586     if (!(tmpsts & 1)) {
9587       set_vaxc_errno(tmpsts);
9588       switch (tmpsts) {
9589         case RMS$_PRV:
9590           set_errno(EACCES); break;
9591         case RMS$_DEV:
9592           set_errno(ENODEV); break;
9593         case RMS$_DIR:
9594           set_errno(ENOTDIR); break;
9595         case RMS$_FNF: case RMS$_DNF:
9596           set_errno(ENOENT); break;
9597         default:
9598           set_errno(EVMSERR);
9599       }
9600       Safefree(buff);
9601       return NULL;
9602     }
9603     dd->count++;
9604     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
9605     buff[res.dsc$w_length] = '\0';
9606     p = buff + res.dsc$w_length;
9607     while (--p >= buff) if (!isspace(*p)) break;
9608     *p = '\0';
9609     if (!decc_efs_case_preserve) {
9610       for (p = buff; *p; p++) *p = _tolower(*p);
9611     }
9612
9613     /* Skip any directory component and just copy the name. */
9614     sts = vms_split_path
9615        (buff,
9616         &v_spec,
9617         &v_len,
9618         &r_spec,
9619         &r_len,
9620         &d_spec,
9621         &d_len,
9622         &n_spec,
9623         &n_len,
9624         &e_spec,
9625         &e_len,
9626         &vs_spec,
9627         &vs_len);
9628
9629     /* Drop NULL extensions on UNIX file specification */
9630     if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
9631         (e_len == 1) && decc_readdir_dropdotnotype)) {
9632         e_len = 0;
9633         e_spec[0] = '\0';
9634     }
9635
9636     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
9637     dd->entry.d_name[n_len + e_len] = '\0';
9638     dd->entry.d_namlen = strlen(dd->entry.d_name);
9639
9640     /* Convert the filename to UNIX format if needed */
9641     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
9642
9643         /* Translate the encoded characters. */
9644         /* Fixme: Unicode handling could result in embedded 0 characters */
9645         if (strchr(dd->entry.d_name, '^') != NULL) {
9646             char new_name[256];
9647             char * q;
9648             p = dd->entry.d_name;
9649             q = new_name;
9650             while (*p != 0) {
9651                 int inchars_read, outchars_added;
9652                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
9653                 p += inchars_read;
9654                 q += outchars_added;
9655                 /* fix-me */
9656                 /* if outchars_added > 1, then this is a wide file specification */
9657                 /* Wide file specifications need to be passed in Perl */
9658                 /* counted strings apparently with a Unicode flag */
9659             }
9660             *q = 0;
9661             strcpy(dd->entry.d_name, new_name);
9662             dd->entry.d_namlen = strlen(dd->entry.d_name);
9663         }
9664     }
9665
9666     dd->entry.vms_verscount = 0;
9667     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
9668     Safefree(buff);
9669     return &dd->entry;
9670
9671 }  /* end of readdir() */
9672 /*}}}*/
9673
9674 /*
9675  *  Read the next entry from the directory -- thread-safe version.
9676  */
9677 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
9678 int
9679 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
9680 {
9681     int retval;
9682
9683     MUTEX_LOCK( (perl_mutex *) dd->mutex );
9684
9685     entry = readdir(dd);
9686     *result = entry;
9687     retval = ( *result == NULL ? errno : 0 );
9688
9689     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
9690
9691     return retval;
9692
9693 }  /* end of readdir_r() */
9694 /*}}}*/
9695
9696 /*
9697  *  Return something that can be used in a seekdir later.
9698  */
9699 /*{{{ long telldir(DIR *dd)*/
9700 long
9701 Perl_telldir(DIR *dd)
9702 {
9703     return dd->count;
9704 }
9705 /*}}}*/
9706
9707 /*
9708  *  Return to a spot where we used to be.  Brute force.
9709  */
9710 /*{{{ void seekdir(DIR *dd,long count)*/
9711 void
9712 Perl_seekdir(pTHX_ DIR *dd, long count)
9713 {
9714     int old_flags;
9715
9716     /* If we haven't done anything yet... */
9717     if (dd->count == 0)
9718         return;
9719
9720     /* Remember some state, and clear it. */
9721     old_flags = dd->flags;
9722     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9723     _ckvmssts(lib$find_file_end(&dd->context));
9724     dd->context = 0;
9725
9726     /* The increment is in readdir(). */
9727     for (dd->count = 0; dd->count < count; )
9728         readdir(dd);
9729
9730     dd->flags = old_flags;
9731
9732 }  /* end of seekdir() */
9733 /*}}}*/
9734
9735 /* VMS subprocess management
9736  *
9737  * my_vfork() - just a vfork(), after setting a flag to record that
9738  * the current script is trying a Unix-style fork/exec.
9739  *
9740  * vms_do_aexec() and vms_do_exec() are called in response to the
9741  * perl 'exec' function.  If this follows a vfork call, then they
9742  * call out the regular perl routines in doio.c which do an
9743  * execvp (for those who really want to try this under VMS).
9744  * Otherwise, they do exactly what the perl docs say exec should
9745  * do - terminate the current script and invoke a new command
9746  * (See below for notes on command syntax.)
9747  *
9748  * do_aspawn() and do_spawn() implement the VMS side of the perl
9749  * 'system' function.
9750  *
9751  * Note on command arguments to perl 'exec' and 'system': When handled
9752  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
9753  * are concatenated to form a DCL command string.  If the first non-numeric
9754  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
9755  * the command string is handed off to DCL directly.  Otherwise,
9756  * the first token of the command is taken as the filespec of an image
9757  * to run.  The filespec is expanded using a default type of '.EXE' and
9758  * the process defaults for device, directory, etc., and if found, the resultant
9759  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
9760  * the command string as parameters.  This is perhaps a bit complicated,
9761  * but I hope it will form a happy medium between what VMS folks expect
9762  * from lib$spawn and what Unix folks expect from exec.
9763  */
9764
9765 static int vfork_called;
9766
9767 /*{{{int my_vfork()*/
9768 int
9769 my_vfork()
9770 {
9771   vfork_called++;
9772   return vfork();
9773 }
9774 /*}}}*/
9775
9776
9777 static void
9778 vms_execfree(struct dsc$descriptor_s *vmscmd)
9779 {
9780   if (vmscmd) {
9781       if (vmscmd->dsc$a_pointer) {
9782           PerlMem_free(vmscmd->dsc$a_pointer);
9783       }
9784       PerlMem_free(vmscmd);
9785   }
9786 }
9787
9788 static char *
9789 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
9790 {
9791   char *junk, *tmps = Nullch;
9792   register size_t cmdlen = 0;
9793   size_t rlen;
9794   register SV **idx;
9795   STRLEN n_a;
9796
9797   idx = mark;
9798   if (really) {
9799     tmps = SvPV(really,rlen);
9800     if (*tmps) {
9801       cmdlen += rlen + 1;
9802       idx++;
9803     }
9804   }
9805
9806   for (idx++; idx <= sp; idx++) {
9807     if (*idx) {
9808       junk = SvPVx(*idx,rlen);
9809       cmdlen += rlen ? rlen + 1 : 0;
9810     }
9811   }
9812   Newx(PL_Cmd, cmdlen+1, char);
9813
9814   if (tmps && *tmps) {
9815     strcpy(PL_Cmd,tmps);
9816     mark++;
9817   }
9818   else *PL_Cmd = '\0';
9819   while (++mark <= sp) {
9820     if (*mark) {
9821       char *s = SvPVx(*mark,n_a);
9822       if (!*s) continue;
9823       if (*PL_Cmd) strcat(PL_Cmd," ");
9824       strcat(PL_Cmd,s);
9825     }
9826   }
9827   return PL_Cmd;
9828
9829 }  /* end of setup_argstr() */
9830
9831
9832 static unsigned long int
9833 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
9834                    struct dsc$descriptor_s **pvmscmd)
9835 {
9836   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
9837   char image_name[NAM$C_MAXRSS+1];
9838   char image_argv[NAM$C_MAXRSS+1];
9839   $DESCRIPTOR(defdsc,".EXE");
9840   $DESCRIPTOR(defdsc2,".");
9841   $DESCRIPTOR(resdsc,resspec);
9842   struct dsc$descriptor_s *vmscmd;
9843   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9844   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
9845   register char *s, *rest, *cp, *wordbreak;
9846   char * cmd;
9847   int cmdlen;
9848   register int isdcl;
9849
9850   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9851   if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
9852
9853   /* Make a copy for modification */
9854   cmdlen = strlen(incmd);
9855   cmd = PerlMem_malloc(cmdlen+1);
9856   if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
9857   strncpy(cmd, incmd, cmdlen);
9858   cmd[cmdlen] = 0;
9859   image_name[0] = 0;
9860   image_argv[0] = 0;
9861
9862   vmscmd->dsc$a_pointer = NULL;
9863   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
9864   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
9865   vmscmd->dsc$w_length = 0;
9866   if (pvmscmd) *pvmscmd = vmscmd;
9867
9868   if (suggest_quote) *suggest_quote = 0;
9869
9870   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
9871     PerlMem_free(cmd);
9872     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
9873   }
9874
9875   s = cmd;
9876
9877   while (*s && isspace(*s)) s++;
9878
9879   if (*s == '@' || *s == '$') {
9880     vmsspec[0] = *s;  rest = s + 1;
9881     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
9882   }
9883   else { cp = vmsspec; rest = s; }
9884   if (*rest == '.' || *rest == '/') {
9885     char *cp2;
9886     for (cp2 = resspec;
9887          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
9888          rest++, cp2++) *cp2 = *rest;
9889     *cp2 = '\0';
9890     if (do_tovmsspec(resspec,cp,0,NULL)) {
9891       s = vmsspec;
9892       if (*rest) {
9893         for (cp2 = vmsspec + strlen(vmsspec);
9894              *rest && cp2 - vmsspec < sizeof vmsspec;
9895              rest++, cp2++) *cp2 = *rest;
9896         *cp2 = '\0';
9897       }
9898     }
9899   }
9900   /* Intuit whether verb (first word of cmd) is a DCL command:
9901    *   - if first nonspace char is '@', it's a DCL indirection
9902    * otherwise
9903    *   - if verb contains a filespec separator, it's not a DCL command
9904    *   - if it doesn't, caller tells us whether to default to a DCL
9905    *     command, or to a local image unless told it's DCL (by leading '$')
9906    */
9907   if (*s == '@') {
9908       isdcl = 1;
9909       if (suggest_quote) *suggest_quote = 1;
9910   } else {
9911     register char *filespec = strpbrk(s,":<[.;");
9912     rest = wordbreak = strpbrk(s," \"\t/");
9913     if (!wordbreak) wordbreak = s + strlen(s);
9914     if (*s == '$') check_img = 0;
9915     if (filespec && (filespec < wordbreak)) isdcl = 0;
9916     else isdcl = !check_img;
9917   }
9918
9919   if (!isdcl) {
9920     int rsts;
9921     imgdsc.dsc$a_pointer = s;
9922     imgdsc.dsc$w_length = wordbreak - s;
9923     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9924     if (!(retsts&1)) {
9925         _ckvmssts(lib$find_file_end(&cxt));
9926         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9927       if (!(retsts & 1) && *s == '$') {
9928         _ckvmssts(lib$find_file_end(&cxt));
9929         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
9930         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9931         if (!(retsts&1)) {
9932           _ckvmssts(lib$find_file_end(&cxt));
9933           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9934         }
9935       }
9936     }
9937     _ckvmssts(lib$find_file_end(&cxt));
9938
9939     if (retsts & 1) {
9940       FILE *fp;
9941       s = resspec;
9942       while (*s && !isspace(*s)) s++;
9943       *s = '\0';
9944
9945       /* check that it's really not DCL with no file extension */
9946       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9947       if (fp) {
9948         char b[256] = {0,0,0,0};
9949         read(fileno(fp), b, 256);
9950         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9951         if (isdcl) {
9952           int shebang_len;
9953
9954           /* Check for script */
9955           shebang_len = 0;
9956           if ((b[0] == '#') && (b[1] == '!'))
9957              shebang_len = 2;
9958 #ifdef ALTERNATE_SHEBANG
9959           else {
9960             shebang_len = strlen(ALTERNATE_SHEBANG);
9961             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9962               char * perlstr;
9963                 perlstr = strstr("perl",b);
9964                 if (perlstr == NULL)
9965                   shebang_len = 0;
9966             }
9967             else
9968               shebang_len = 0;
9969           }
9970 #endif
9971
9972           if (shebang_len > 0) {
9973           int i;
9974           int j;
9975           char tmpspec[NAM$C_MAXRSS + 1];
9976
9977             i = shebang_len;
9978              /* Image is following after white space */
9979             /*--------------------------------------*/
9980             while (isprint(b[i]) && isspace(b[i]))
9981                 i++;
9982
9983             j = 0;
9984             while (isprint(b[i]) && !isspace(b[i])) {
9985                 tmpspec[j++] = b[i++];
9986                 if (j >= NAM$C_MAXRSS)
9987                    break;
9988             }
9989             tmpspec[j] = '\0';
9990
9991              /* There may be some default parameters to the image */
9992             /*---------------------------------------------------*/
9993             j = 0;
9994             while (isprint(b[i])) {
9995                 image_argv[j++] = b[i++];
9996                 if (j >= NAM$C_MAXRSS)
9997                    break;
9998             }
9999             while ((j > 0) && !isprint(image_argv[j-1]))
10000                 j--;
10001             image_argv[j] = 0;
10002
10003             /* It will need to be converted to VMS format and validated */
10004             if (tmpspec[0] != '\0') {
10005               char * iname;
10006
10007                /* Try to find the exact program requested to be run */
10008               /*---------------------------------------------------*/
10009               iname = do_rmsexpand
10010                  (tmpspec, image_name, 0, ".exe",
10011                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10012               if (iname != NULL) {
10013                 if (cando_by_name_int
10014                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10015                   /* MCR prefix needed */
10016                   isdcl = 0;
10017                 }
10018                 else {
10019                    /* Try again with a null type */
10020                   /*----------------------------*/
10021                   iname = do_rmsexpand
10022                     (tmpspec, image_name, 0, ".",
10023                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10024                   if (iname != NULL) {
10025                     if (cando_by_name_int
10026                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10027                       /* MCR prefix needed */
10028                       isdcl = 0;
10029                     }
10030                   }
10031                 }
10032
10033                  /* Did we find the image to run the script? */
10034                 /*------------------------------------------*/
10035                 if (isdcl) {
10036                   char *tchr;
10037
10038                    /* Assume DCL or foreign command exists */
10039                   /*--------------------------------------*/
10040                   tchr = strrchr(tmpspec, '/');
10041                   if (tchr != NULL) {
10042                     tchr++;
10043                   }
10044                   else {
10045                     tchr = tmpspec;
10046                   }
10047                   strcpy(image_name, tchr);
10048                 }
10049               }
10050             }
10051           }
10052         }
10053         fclose(fp);
10054       }
10055       if (check_img && isdcl) return RMS$_FNF;
10056
10057       if (cando_by_name(S_IXUSR,0,resspec)) {
10058         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10059         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
10060         if (!isdcl) {
10061             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
10062             if (image_name[0] != 0) {
10063                 strcat(vmscmd->dsc$a_pointer, image_name);
10064                 strcat(vmscmd->dsc$a_pointer, " ");
10065             }
10066         } else if (image_name[0] != 0) {
10067             strcpy(vmscmd->dsc$a_pointer, image_name);
10068             strcat(vmscmd->dsc$a_pointer, " ");
10069         } else {
10070             strcpy(vmscmd->dsc$a_pointer,"@");
10071         }
10072         if (suggest_quote) *suggest_quote = 1;
10073
10074         /* If there is an image name, use original command */
10075         if (image_name[0] == 0)
10076             strcat(vmscmd->dsc$a_pointer,resspec);
10077         else {
10078             rest = cmd;
10079             while (*rest && isspace(*rest)) rest++;
10080         }
10081
10082         if (image_argv[0] != 0) {
10083           strcat(vmscmd->dsc$a_pointer,image_argv);
10084           strcat(vmscmd->dsc$a_pointer, " ");
10085         }
10086         if (rest) {
10087            int rest_len;
10088            int vmscmd_len;
10089
10090            rest_len = strlen(rest);
10091            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10092            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10093               strcat(vmscmd->dsc$a_pointer,rest);
10094            else
10095              retsts = CLI$_BUFOVF;
10096         }
10097         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10098         PerlMem_free(cmd);
10099         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10100       }
10101       else
10102         retsts = RMS$_PRV;
10103     }
10104   }
10105   /* It's either a DCL command or we couldn't find a suitable image */
10106   vmscmd->dsc$w_length = strlen(cmd);
10107
10108   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
10109   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
10110   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
10111
10112   PerlMem_free(cmd);
10113
10114   /* check if it's a symbol (for quoting purposes) */
10115   if (suggest_quote && !*suggest_quote) {
10116     int iss;
10117     char equiv[LNM$C_NAMLENGTH];
10118     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10119     eqvdsc.dsc$a_pointer = equiv;
10120
10121     iss = lib$get_symbol(vmscmd,&eqvdsc);
10122     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10123   }
10124   if (!(retsts & 1)) {
10125     /* just hand off status values likely to be due to user error */
10126     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10127         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10128        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10129     else { _ckvmssts(retsts); }
10130   }
10131
10132   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10133
10134 }  /* end of setup_cmddsc() */
10135
10136
10137 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10138 bool
10139 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10140 {
10141 bool exec_sts;
10142 char * cmd;
10143
10144   if (sp > mark) {
10145     if (vfork_called) {           /* this follows a vfork - act Unixish */
10146       vfork_called--;
10147       if (vfork_called < 0) {
10148         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10149         vfork_called = 0;
10150       }
10151       else return do_aexec(really,mark,sp);
10152     }
10153                                            /* no vfork - act VMSish */
10154     cmd = setup_argstr(aTHX_ really,mark,sp);
10155     exec_sts = vms_do_exec(cmd);
10156     Safefree(cmd);  /* Clean up from setup_argstr() */
10157     return exec_sts;
10158   }
10159
10160   return FALSE;
10161 }  /* end of vms_do_aexec() */
10162 /*}}}*/
10163
10164 /* {{{bool vms_do_exec(char *cmd) */
10165 bool
10166 Perl_vms_do_exec(pTHX_ const char *cmd)
10167 {
10168   struct dsc$descriptor_s *vmscmd;
10169
10170   if (vfork_called) {             /* this follows a vfork - act Unixish */
10171     vfork_called--;
10172     if (vfork_called < 0) {
10173       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10174       vfork_called = 0;
10175     }
10176     else return do_exec(cmd);
10177   }
10178
10179   {                               /* no vfork - act VMSish */
10180     unsigned long int retsts;
10181
10182     TAINT_ENV();
10183     TAINT_PROPER("exec");
10184     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10185       retsts = lib$do_command(vmscmd);
10186
10187     switch (retsts) {
10188       case RMS$_FNF: case RMS$_DNF:
10189         set_errno(ENOENT); break;
10190       case RMS$_DIR:
10191         set_errno(ENOTDIR); break;
10192       case RMS$_DEV:
10193         set_errno(ENODEV); break;
10194       case RMS$_PRV:
10195         set_errno(EACCES); break;
10196       case RMS$_SYN:
10197         set_errno(EINVAL); break;
10198       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10199         set_errno(E2BIG); break;
10200       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10201         _ckvmssts(retsts); /* fall through */
10202       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10203         set_errno(EVMSERR);
10204     }
10205     set_vaxc_errno(retsts);
10206     if (ckWARN(WARN_EXEC)) {
10207       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10208              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10209     }
10210     vms_execfree(vmscmd);
10211   }
10212
10213   return FALSE;
10214
10215 }  /* end of vms_do_exec() */
10216 /*}}}*/
10217
10218 unsigned long int Perl_do_spawn(pTHX_ const char *);
10219 unsigned long int do_spawn2(pTHX_ const char *, int);
10220
10221 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
10222 unsigned long int
10223 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
10224 {
10225 unsigned long int sts;
10226 char * cmd;
10227 int flags = 0;
10228
10229   if (sp > mark) {
10230
10231     /* We'll copy the (undocumented?) Win32 behavior and allow a
10232      * numeric first argument.  But the only value we'll support
10233      * through do_aspawn is a value of 1, which means spawn without
10234      * waiting for completion -- other values are ignored.
10235      */
10236     if (SvNIOKp(*((SV**)mark+1)) && !SvPOKp(*((SV**)mark+1))) {
10237         ++mark;
10238         flags = SvIVx(*(SV**)mark);
10239     }
10240
10241     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
10242         flags = CLI$M_NOWAIT;
10243     else
10244         flags = 0;
10245
10246     cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
10247     sts = do_spawn2(aTHX_ cmd, flags);
10248     /* pp_sys will clean up cmd */
10249     return sts;
10250   }
10251   return SS$_ABORT;
10252 }  /* end of do_aspawn() */
10253 /*}}}*/
10254
10255
10256 /* {{{unsigned long int do_spawn(char *cmd) */
10257 unsigned long int
10258 Perl_do_spawn(pTHX_ const char *cmd)
10259 {
10260     return do_spawn2(aTHX_ cmd, 0);
10261 }
10262 /*}}}*/
10263
10264 /* {{{unsigned long int do_spawn2(char *cmd) */
10265 unsigned long int
10266 do_spawn2(pTHX_ const char *cmd, int flags)
10267 {
10268   unsigned long int sts, substs;
10269
10270   /* The caller of this routine expects to Safefree(PL_Cmd) */
10271   Newx(PL_Cmd,10,char);
10272
10273   TAINT_ENV();
10274   TAINT_PROPER("spawn");
10275   if (!cmd || !*cmd) {
10276     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
10277     if (!(sts & 1)) {
10278       switch (sts) {
10279         case RMS$_FNF:  case RMS$_DNF:
10280           set_errno(ENOENT); break;
10281         case RMS$_DIR:
10282           set_errno(ENOTDIR); break;
10283         case RMS$_DEV:
10284           set_errno(ENODEV); break;
10285         case RMS$_PRV:
10286           set_errno(EACCES); break;
10287         case RMS$_SYN:
10288           set_errno(EINVAL); break;
10289         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10290           set_errno(E2BIG); break;
10291         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10292           _ckvmssts(sts); /* fall through */
10293         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10294           set_errno(EVMSERR);
10295       }
10296       set_vaxc_errno(sts);
10297       if (ckWARN(WARN_EXEC)) {
10298         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
10299                     Strerror(errno));
10300       }
10301     }
10302     sts = substs;
10303   }
10304   else {
10305     char mode[3];
10306     PerlIO * fp;
10307     if (flags & CLI$M_NOWAIT)
10308         strcpy(mode, "n");
10309     else
10310         strcpy(mode, "nW");
10311
10312     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
10313     if (fp != NULL)
10314       my_pclose(fp);
10315     /* sts will be the pid in the nowait case */
10316   }
10317   return sts;
10318 }  /* end of do_spawn2() */
10319 /*}}}*/
10320
10321
10322 static unsigned int *sockflags, sockflagsize;
10323
10324 /*
10325  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
10326  * routines found in some versions of the CRTL can't deal with sockets.
10327  * We don't shim the other file open routines since a socket isn't
10328  * likely to be opened by a name.
10329  */
10330 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
10331 FILE *my_fdopen(int fd, const char *mode)
10332 {
10333   FILE *fp = fdopen(fd, mode);
10334
10335   if (fp) {
10336     unsigned int fdoff = fd / sizeof(unsigned int);
10337     Stat_t sbuf; /* native stat; we don't need flex_stat */
10338     if (!sockflagsize || fdoff > sockflagsize) {
10339       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
10340       else           Newx  (sockflags,fdoff+2,unsigned int);
10341       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
10342       sockflagsize = fdoff + 2;
10343     }
10344     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
10345       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
10346   }
10347   return fp;
10348
10349 }
10350 /*}}}*/
10351
10352
10353 /*
10354  * Clear the corresponding bit when the (possibly) socket stream is closed.
10355  * There still a small hole: we miss an implicit close which might occur
10356  * via freopen().  >> Todo
10357  */
10358 /*{{{ int my_fclose(FILE *fp)*/
10359 int my_fclose(FILE *fp) {
10360   if (fp) {
10361     unsigned int fd = fileno(fp);
10362     unsigned int fdoff = fd / sizeof(unsigned int);
10363
10364     if (sockflagsize && fdoff <= sockflagsize)
10365       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
10366   }
10367   return fclose(fp);
10368 }
10369 /*}}}*/
10370
10371
10372 /*
10373  * A simple fwrite replacement which outputs itmsz*nitm chars without
10374  * introducing record boundaries every itmsz chars.
10375  * We are using fputs, which depends on a terminating null.  We may
10376  * well be writing binary data, so we need to accommodate not only
10377  * data with nulls sprinkled in the middle but also data with no null
10378  * byte at the end.
10379  */
10380 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
10381 int
10382 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
10383 {
10384   register char *cp, *end, *cpd, *data;
10385   register unsigned int fd = fileno(dest);
10386   register unsigned int fdoff = fd / sizeof(unsigned int);
10387   int retval;
10388   int bufsize = itmsz * nitm + 1;
10389
10390   if (fdoff < sockflagsize &&
10391       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
10392     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
10393     return nitm;
10394   }
10395
10396   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
10397   memcpy( data, src, itmsz*nitm );
10398   data[itmsz*nitm] = '\0';
10399
10400   end = data + itmsz * nitm;
10401   retval = (int) nitm; /* on success return # items written */
10402
10403   cpd = data;
10404   while (cpd <= end) {
10405     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
10406     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
10407     if (cp < end)
10408       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
10409     cpd = cp + 1;
10410   }
10411
10412   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
10413   return retval;
10414
10415 }  /* end of my_fwrite() */
10416 /*}}}*/
10417
10418 /*{{{ int my_flush(FILE *fp)*/
10419 int
10420 Perl_my_flush(pTHX_ FILE *fp)
10421 {
10422     int res;
10423     if ((res = fflush(fp)) == 0 && fp) {
10424 #ifdef VMS_DO_SOCKETS
10425         Stat_t s;
10426         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
10427 #endif
10428             res = fsync(fileno(fp));
10429     }
10430 /*
10431  * If the flush succeeded but set end-of-file, we need to clear
10432  * the error because our caller may check ferror().  BTW, this
10433  * probably means we just flushed an empty file.
10434  */
10435     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
10436
10437     return res;
10438 }
10439 /*}}}*/
10440
10441 /*
10442  * Here are replacements for the following Unix routines in the VMS environment:
10443  *      getpwuid    Get information for a particular UIC or UID
10444  *      getpwnam    Get information for a named user
10445  *      getpwent    Get information for each user in the rights database
10446  *      setpwent    Reset search to the start of the rights database
10447  *      endpwent    Finish searching for users in the rights database
10448  *
10449  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
10450  * (defined in pwd.h), which contains the following fields:-
10451  *      struct passwd {
10452  *              char        *pw_name;    Username (in lower case)
10453  *              char        *pw_passwd;  Hashed password
10454  *              unsigned int pw_uid;     UIC
10455  *              unsigned int pw_gid;     UIC group  number
10456  *              char        *pw_unixdir; Default device/directory (VMS-style)
10457  *              char        *pw_gecos;   Owner name
10458  *              char        *pw_dir;     Default device/directory (Unix-style)
10459  *              char        *pw_shell;   Default CLI name (eg. DCL)
10460  *      };
10461  * If the specified user does not exist, getpwuid and getpwnam return NULL.
10462  *
10463  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
10464  * not the UIC member number (eg. what's returned by getuid()),
10465  * getpwuid() can accept either as input (if uid is specified, the caller's
10466  * UIC group is used), though it won't recognise gid=0.
10467  *
10468  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
10469  * information about other users in your group or in other groups, respectively.
10470  * If the required privilege is not available, then these routines fill only
10471  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
10472  * string).
10473  *
10474  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
10475  */
10476
10477 /* sizes of various UAF record fields */
10478 #define UAI$S_USERNAME 12
10479 #define UAI$S_IDENT    31
10480 #define UAI$S_OWNER    31
10481 #define UAI$S_DEFDEV   31
10482 #define UAI$S_DEFDIR   63
10483 #define UAI$S_DEFCLI   31
10484 #define UAI$S_PWD       8
10485
10486 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
10487                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
10488                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
10489
10490 static char __empty[]= "";
10491 static struct passwd __passwd_empty=
10492     {(char *) __empty, (char *) __empty, 0, 0,
10493      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
10494 static int contxt= 0;
10495 static struct passwd __pwdcache;
10496 static char __pw_namecache[UAI$S_IDENT+1];
10497
10498 /*
10499  * This routine does most of the work extracting the user information.
10500  */
10501 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
10502 {
10503     static struct {
10504         unsigned char length;
10505         char pw_gecos[UAI$S_OWNER+1];
10506     } owner;
10507     static union uicdef uic;
10508     static struct {
10509         unsigned char length;
10510         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
10511     } defdev;
10512     static struct {
10513         unsigned char length;
10514         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
10515     } defdir;
10516     static struct {
10517         unsigned char length;
10518         char pw_shell[UAI$S_DEFCLI+1];
10519     } defcli;
10520     static char pw_passwd[UAI$S_PWD+1];
10521
10522     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
10523     struct dsc$descriptor_s name_desc;
10524     unsigned long int sts;
10525
10526     static struct itmlst_3 itmlst[]= {
10527         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
10528         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
10529         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
10530         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
10531         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
10532         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
10533         {0,                0,           NULL,    NULL}};
10534
10535     name_desc.dsc$w_length=  strlen(name);
10536     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
10537     name_desc.dsc$b_class=   DSC$K_CLASS_S;
10538     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
10539
10540 /*  Note that sys$getuai returns many fields as counted strings. */
10541     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
10542     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
10543       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
10544     }
10545     else { _ckvmssts(sts); }
10546     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
10547
10548     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
10549     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
10550     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
10551     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
10552     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
10553     owner.pw_gecos[lowner]=            '\0';
10554     defdev.pw_dir[ldefdev+ldefdir]= '\0';
10555     defcli.pw_shell[ldefcli]=          '\0';
10556     if (valid_uic(uic)) {
10557         pwd->pw_uid= uic.uic$l_uic;
10558         pwd->pw_gid= uic.uic$v_group;
10559     }
10560     else
10561       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
10562     pwd->pw_passwd=  pw_passwd;
10563     pwd->pw_gecos=   owner.pw_gecos;
10564     pwd->pw_dir=     defdev.pw_dir;
10565     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
10566     pwd->pw_shell=   defcli.pw_shell;
10567     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
10568         int ldir;
10569         ldir= strlen(pwd->pw_unixdir) - 1;
10570         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
10571     }
10572     else
10573         strcpy(pwd->pw_unixdir, pwd->pw_dir);
10574     if (!decc_efs_case_preserve)
10575         __mystrtolower(pwd->pw_unixdir);
10576     return 1;
10577 }
10578
10579 /*
10580  * Get information for a named user.
10581 */
10582 /*{{{struct passwd *getpwnam(char *name)*/
10583 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
10584 {
10585     struct dsc$descriptor_s name_desc;
10586     union uicdef uic;
10587     unsigned long int status, sts;
10588
10589     __pwdcache = __passwd_empty;
10590     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
10591       /* We still may be able to determine pw_uid and pw_gid */
10592       name_desc.dsc$w_length=  strlen(name);
10593       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
10594       name_desc.dsc$b_class=   DSC$K_CLASS_S;
10595       name_desc.dsc$a_pointer= (char *) name;
10596       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
10597         __pwdcache.pw_uid= uic.uic$l_uic;
10598         __pwdcache.pw_gid= uic.uic$v_group;
10599       }
10600       else {
10601         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
10602           set_vaxc_errno(sts);
10603           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
10604           return NULL;
10605         }
10606         else { _ckvmssts(sts); }
10607       }
10608     }
10609     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
10610     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
10611     __pwdcache.pw_name= __pw_namecache;
10612     return &__pwdcache;
10613 }  /* end of my_getpwnam() */
10614 /*}}}*/
10615
10616 /*
10617  * Get information for a particular UIC or UID.
10618  * Called by my_getpwent with uid=-1 to list all users.
10619 */
10620 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
10621 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
10622 {
10623     const $DESCRIPTOR(name_desc,__pw_namecache);
10624     unsigned short lname;
10625     union uicdef uic;
10626     unsigned long int status;
10627
10628     if (uid == (unsigned int) -1) {
10629       do {
10630         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
10631         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
10632           set_vaxc_errno(status);
10633           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10634           my_endpwent();
10635           return NULL;
10636         }
10637         else { _ckvmssts(status); }
10638       } while (!valid_uic (uic));
10639     }
10640     else {
10641       uic.uic$l_uic= uid;
10642       if (!uic.uic$v_group)
10643         uic.uic$v_group= PerlProc_getgid();
10644       if (valid_uic(uic))
10645         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
10646       else status = SS$_IVIDENT;
10647       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
10648           status == RMS$_PRV) {
10649         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10650         return NULL;
10651       }
10652       else { _ckvmssts(status); }
10653     }
10654     __pw_namecache[lname]= '\0';
10655     __mystrtolower(__pw_namecache);
10656
10657     __pwdcache = __passwd_empty;
10658     __pwdcache.pw_name = __pw_namecache;
10659
10660 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
10661     The identifier's value is usually the UIC, but it doesn't have to be,
10662     so if we can, we let fillpasswd update this. */
10663     __pwdcache.pw_uid =  uic.uic$l_uic;
10664     __pwdcache.pw_gid =  uic.uic$v_group;
10665
10666     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
10667     return &__pwdcache;
10668
10669 }  /* end of my_getpwuid() */
10670 /*}}}*/
10671
10672 /*
10673  * Get information for next user.
10674 */
10675 /*{{{struct passwd *my_getpwent()*/
10676 struct passwd *Perl_my_getpwent(pTHX)
10677 {
10678     return (my_getpwuid((unsigned int) -1));
10679 }
10680 /*}}}*/
10681
10682 /*
10683  * Finish searching rights database for users.
10684 */
10685 /*{{{void my_endpwent()*/
10686 void Perl_my_endpwent(pTHX)
10687 {
10688     if (contxt) {
10689       _ckvmssts(sys$finish_rdb(&contxt));
10690       contxt= 0;
10691     }
10692 }
10693 /*}}}*/
10694
10695 #ifdef HOMEGROWN_POSIX_SIGNALS
10696   /* Signal handling routines, pulled into the core from POSIX.xs.
10697    *
10698    * We need these for threads, so they've been rolled into the core,
10699    * rather than left in POSIX.xs.
10700    *
10701    * (DRS, Oct 23, 1997)
10702    */
10703
10704   /* sigset_t is atomic under VMS, so these routines are easy */
10705 /*{{{int my_sigemptyset(sigset_t *) */
10706 int my_sigemptyset(sigset_t *set) {
10707     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10708     *set = 0; return 0;
10709 }
10710 /*}}}*/
10711
10712
10713 /*{{{int my_sigfillset(sigset_t *)*/
10714 int my_sigfillset(sigset_t *set) {
10715     int i;
10716     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10717     for (i = 0; i < NSIG; i++) *set |= (1 << i);
10718     return 0;
10719 }
10720 /*}}}*/
10721
10722
10723 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
10724 int my_sigaddset(sigset_t *set, int sig) {
10725     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10726     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10727     *set |= (1 << (sig - 1));
10728     return 0;
10729 }
10730 /*}}}*/
10731
10732
10733 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
10734 int my_sigdelset(sigset_t *set, int sig) {
10735     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10736     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10737     *set &= ~(1 << (sig - 1));
10738     return 0;
10739 }
10740 /*}}}*/
10741
10742
10743 /*{{{int my_sigismember(sigset_t *set, int sig)*/
10744 int my_sigismember(sigset_t *set, int sig) {
10745     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10746     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10747     return *set & (1 << (sig - 1));
10748 }
10749 /*}}}*/
10750
10751
10752 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10753 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10754     sigset_t tempmask;
10755
10756     /* If set and oset are both null, then things are badly wrong. Bail out. */
10757     if ((oset == NULL) && (set == NULL)) {
10758       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
10759       return -1;
10760     }
10761
10762     /* If set's null, then we're just handling a fetch. */
10763     if (set == NULL) {
10764         tempmask = sigblock(0);
10765     }
10766     else {
10767       switch (how) {
10768       case SIG_SETMASK:
10769         tempmask = sigsetmask(*set);
10770         break;
10771       case SIG_BLOCK:
10772         tempmask = sigblock(*set);
10773         break;
10774       case SIG_UNBLOCK:
10775         tempmask = sigblock(0);
10776         sigsetmask(*oset & ~tempmask);
10777         break;
10778       default:
10779         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10780         return -1;
10781       }
10782     }
10783
10784     /* Did they pass us an oset? If so, stick our holding mask into it */
10785     if (oset)
10786       *oset = tempmask;
10787
10788     return 0;
10789 }
10790 /*}}}*/
10791 #endif  /* HOMEGROWN_POSIX_SIGNALS */
10792
10793
10794 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
10795  * my_utime(), and flex_stat(), all of which operate on UTC unless
10796  * VMSISH_TIMES is true.
10797  */
10798 /* method used to handle UTC conversions:
10799  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
10800  */
10801 static int gmtime_emulation_type;
10802 /* number of secs to add to UTC POSIX-style time to get local time */
10803 static long int utc_offset_secs;
10804
10805 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
10806  * in vmsish.h.  #undef them here so we can call the CRTL routines
10807  * directly.
10808  */
10809 #undef gmtime
10810 #undef localtime
10811 #undef time
10812
10813
10814 /*
10815  * DEC C previous to 6.0 corrupts the behavior of the /prefix
10816  * qualifier with the extern prefix pragma.  This provisional
10817  * hack circumvents this prefix pragma problem in previous
10818  * precompilers.
10819  */
10820 #if defined(__VMS_VER) && __VMS_VER >= 70000000
10821 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
10822 #    pragma __extern_prefix save
10823 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
10824 #    define gmtime decc$__utctz_gmtime
10825 #    define localtime decc$__utctz_localtime
10826 #    define time decc$__utc_time
10827 #    pragma __extern_prefix restore
10828
10829      struct tm *gmtime(), *localtime();
10830
10831 #  endif
10832 #endif
10833
10834
10835 static time_t toutc_dst(time_t loc) {
10836   struct tm *rsltmp;
10837
10838   if ((rsltmp = localtime(&loc)) == NULL) return -1;
10839   loc -= utc_offset_secs;
10840   if (rsltmp->tm_isdst) loc -= 3600;
10841   return loc;
10842 }
10843 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10844        ((gmtime_emulation_type || my_time(NULL)), \
10845        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
10846        ((secs) - utc_offset_secs))))
10847
10848 static time_t toloc_dst(time_t utc) {
10849   struct tm *rsltmp;
10850
10851   utc += utc_offset_secs;
10852   if ((rsltmp = localtime(&utc)) == NULL) return -1;
10853   if (rsltmp->tm_isdst) utc += 3600;
10854   return utc;
10855 }
10856 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10857        ((gmtime_emulation_type || my_time(NULL)), \
10858        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
10859        ((secs) + utc_offset_secs))))
10860
10861 #ifndef RTL_USES_UTC
10862 /*
10863
10864     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
10865         DST starts on 1st sun of april      at 02:00  std time
10866             ends on last sun of october     at 02:00  dst time
10867     see the UCX management command reference, SET CONFIG TIMEZONE
10868     for formatting info.
10869
10870     No, it's not as general as it should be, but then again, NOTHING
10871     will handle UK times in a sensible way.
10872 */
10873
10874
10875 /*
10876     parse the DST start/end info:
10877     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
10878 */
10879
10880 static char *
10881 tz_parse_startend(char *s, struct tm *w, int *past)
10882 {
10883     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
10884     int ly, dozjd, d, m, n, hour, min, sec, j, k;
10885     time_t g;
10886
10887     if (!s)    return 0;
10888     if (!w) return 0;
10889     if (!past) return 0;
10890
10891     ly = 0;
10892     if (w->tm_year % 4        == 0) ly = 1;
10893     if (w->tm_year % 100      == 0) ly = 0;
10894     if (w->tm_year+1900 % 400 == 0) ly = 1;
10895     if (ly) dinm[1]++;
10896
10897     dozjd = isdigit(*s);
10898     if (*s == 'J' || *s == 'j' || dozjd) {
10899         if (!dozjd && !isdigit(*++s)) return 0;
10900         d = *s++ - '0';
10901         if (isdigit(*s)) {
10902             d = d*10 + *s++ - '0';
10903             if (isdigit(*s)) {
10904                 d = d*10 + *s++ - '0';
10905             }
10906         }
10907         if (d == 0) return 0;
10908         if (d > 366) return 0;
10909         d--;
10910         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
10911         g = d * 86400;
10912         dozjd = 1;
10913     } else if (*s == 'M' || *s == 'm') {
10914         if (!isdigit(*++s)) return 0;
10915         m = *s++ - '0';
10916         if (isdigit(*s)) m = 10*m + *s++ - '0';
10917         if (*s != '.') return 0;
10918         if (!isdigit(*++s)) return 0;
10919         n = *s++ - '0';
10920         if (n < 1 || n > 5) return 0;
10921         if (*s != '.') return 0;
10922         if (!isdigit(*++s)) return 0;
10923         d = *s++ - '0';
10924         if (d > 6) return 0;
10925     }
10926
10927     if (*s == '/') {
10928         if (!isdigit(*++s)) return 0;
10929         hour = *s++ - '0';
10930         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
10931         if (*s == ':') {
10932             if (!isdigit(*++s)) return 0;
10933             min = *s++ - '0';
10934             if (isdigit(*s)) min = 10*min + *s++ - '0';
10935             if (*s == ':') {
10936                 if (!isdigit(*++s)) return 0;
10937                 sec = *s++ - '0';
10938                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
10939             }
10940         }
10941     } else {
10942         hour = 2;
10943         min = 0;
10944         sec = 0;
10945     }
10946
10947     if (dozjd) {
10948         if (w->tm_yday < d) goto before;
10949         if (w->tm_yday > d) goto after;
10950     } else {
10951         if (w->tm_mon+1 < m) goto before;
10952         if (w->tm_mon+1 > m) goto after;
10953
10954         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
10955         k = d - j; /* mday of first d */
10956         if (k <= 0) k += 7;
10957         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
10958         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
10959         if (w->tm_mday < k) goto before;
10960         if (w->tm_mday > k) goto after;
10961     }
10962
10963     if (w->tm_hour < hour) goto before;
10964     if (w->tm_hour > hour) goto after;
10965     if (w->tm_min  < min)  goto before;
10966     if (w->tm_min  > min)  goto after;
10967     if (w->tm_sec  < sec)  goto before;
10968     goto after;
10969
10970 before:
10971     *past = 0;
10972     return s;
10973 after:
10974     *past = 1;
10975     return s;
10976 }
10977
10978
10979
10980
10981 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
10982
10983 static char *
10984 tz_parse_offset(char *s, int *offset)
10985 {
10986     int hour = 0, min = 0, sec = 0;
10987     int neg = 0;
10988     if (!s) return 0;
10989     if (!offset) return 0;
10990
10991     if (*s == '-') {neg++; s++;}
10992     if (*s == '+') s++;
10993     if (!isdigit(*s)) return 0;
10994     hour = *s++ - '0';
10995     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10996     if (hour > 24) return 0;
10997     if (*s == ':') {
10998         if (!isdigit(*++s)) return 0;
10999         min = *s++ - '0';
11000         if (isdigit(*s)) min = min*10 + (*s++ - '0');
11001         if (min > 59) return 0;
11002         if (*s == ':') {
11003             if (!isdigit(*++s)) return 0;
11004             sec = *s++ - '0';
11005             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
11006             if (sec > 59) return 0;
11007         }
11008     }
11009
11010     *offset = (hour*60+min)*60 + sec;
11011     if (neg) *offset = -*offset;
11012     return s;
11013 }
11014
11015 /*
11016     input time is w, whatever type of time the CRTL localtime() uses.
11017     sets dst, the zone, and the gmtoff (seconds)
11018
11019     caches the value of TZ and UCX$TZ env variables; note that
11020     my_setenv looks for these and sets a flag if they're changed
11021     for efficiency.
11022
11023     We have to watch out for the "australian" case (dst starts in
11024     october, ends in april)...flagged by "reverse" and checked by
11025     scanning through the months of the previous year.
11026
11027 */
11028
11029 static int
11030 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
11031 {
11032     time_t when;
11033     struct tm *w2;
11034     char *s,*s2;
11035     char *dstzone, *tz, *s_start, *s_end;
11036     int std_off, dst_off, isdst;
11037     int y, dststart, dstend;
11038     static char envtz[1025];  /* longer than any logical, symbol, ... */
11039     static char ucxtz[1025];
11040     static char reversed = 0;
11041
11042     if (!w) return 0;
11043
11044     if (tz_updated) {
11045         tz_updated = 0;
11046         reversed = -1;  /* flag need to check  */
11047         envtz[0] = ucxtz[0] = '\0';
11048         tz = my_getenv("TZ",0);
11049         if (tz) strcpy(envtz, tz);
11050         tz = my_getenv("UCX$TZ",0);
11051         if (tz) strcpy(ucxtz, tz);
11052         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
11053     }
11054     tz = envtz;
11055     if (!*tz) tz = ucxtz;
11056
11057     s = tz;
11058     while (isalpha(*s)) s++;
11059     s = tz_parse_offset(s, &std_off);
11060     if (!s) return 0;
11061     if (!*s) {                  /* no DST, hurray we're done! */
11062         isdst = 0;
11063         goto done;
11064     }
11065
11066     dstzone = s;
11067     while (isalpha(*s)) s++;
11068     s2 = tz_parse_offset(s, &dst_off);
11069     if (s2) {
11070         s = s2;
11071     } else {
11072         dst_off = std_off - 3600;
11073     }
11074
11075     if (!*s) {      /* default dst start/end?? */
11076         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
11077             s = strchr(ucxtz,',');
11078         }
11079         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
11080     }
11081     if (*s != ',') return 0;
11082
11083     when = *w;
11084     when = _toutc(when);      /* convert to utc */
11085     when = when - std_off;    /* convert to pseudolocal time*/
11086
11087     w2 = localtime(&when);
11088     y = w2->tm_year;
11089     s_start = s+1;
11090     s = tz_parse_startend(s_start,w2,&dststart);
11091     if (!s) return 0;
11092     if (*s != ',') return 0;
11093
11094     when = *w;
11095     when = _toutc(when);      /* convert to utc */
11096     when = when - dst_off;    /* convert to pseudolocal time*/
11097     w2 = localtime(&when);
11098     if (w2->tm_year != y) {   /* spans a year, just check one time */
11099         when += dst_off - std_off;
11100         w2 = localtime(&when);
11101     }
11102     s_end = s+1;
11103     s = tz_parse_startend(s_end,w2,&dstend);
11104     if (!s) return 0;
11105
11106     if (reversed == -1) {  /* need to check if start later than end */
11107         int j, ds, de;
11108
11109         when = *w;
11110         if (when < 2*365*86400) {
11111             when += 2*365*86400;
11112         } else {
11113             when -= 365*86400;
11114         }
11115         w2 =localtime(&when);
11116         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
11117
11118         for (j = 0; j < 12; j++) {
11119             w2 =localtime(&when);
11120             tz_parse_startend(s_start,w2,&ds);
11121             tz_parse_startend(s_end,w2,&de);
11122             if (ds != de) break;
11123             when += 30*86400;
11124         }
11125         reversed = 0;
11126         if (de && !ds) reversed = 1;
11127     }
11128
11129     isdst = dststart && !dstend;
11130     if (reversed) isdst = dststart  || !dstend;
11131
11132 done:
11133     if (dst)    *dst = isdst;
11134     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
11135     if (isdst)  tz = dstzone;
11136     if (zone) {
11137         while(isalpha(*tz))  *zone++ = *tz++;
11138         *zone = '\0';
11139     }
11140     return 1;
11141 }
11142
11143 #endif /* !RTL_USES_UTC */
11144
11145 /* my_time(), my_localtime(), my_gmtime()
11146  * By default traffic in UTC time values, using CRTL gmtime() or
11147  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11148  * Note: We need to use these functions even when the CRTL has working
11149  * UTC support, since they also handle C<use vmsish qw(times);>
11150  *
11151  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
11152  * Modified by Charles Bailey <bailey@newman.upenn.edu>
11153  */
11154
11155 /*{{{time_t my_time(time_t *timep)*/
11156 time_t Perl_my_time(pTHX_ time_t *timep)
11157 {
11158   time_t when;
11159   struct tm *tm_p;
11160
11161   if (gmtime_emulation_type == 0) {
11162     int dstnow;
11163     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
11164                               /* results of calls to gmtime() and localtime() */
11165                               /* for same &base */
11166
11167     gmtime_emulation_type++;
11168     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11169       char off[LNM$C_NAMLENGTH+1];;
11170
11171       gmtime_emulation_type++;
11172       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11173         gmtime_emulation_type++;
11174         utc_offset_secs = 0;
11175         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11176       }
11177       else { utc_offset_secs = atol(off); }
11178     }
11179     else { /* We've got a working gmtime() */
11180       struct tm gmt, local;
11181
11182       gmt = *tm_p;
11183       tm_p = localtime(&base);
11184       local = *tm_p;
11185       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
11186       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11187       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
11188       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
11189     }
11190   }
11191
11192   when = time(NULL);
11193 # ifdef VMSISH_TIME
11194 # ifdef RTL_USES_UTC
11195   if (VMSISH_TIME) when = _toloc(when);
11196 # else
11197   if (!VMSISH_TIME) when = _toutc(when);
11198 # endif
11199 # endif
11200   if (timep != NULL) *timep = when;
11201   return when;
11202
11203 }  /* end of my_time() */
11204 /*}}}*/
11205
11206
11207 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11208 struct tm *
11209 Perl_my_gmtime(pTHX_ const time_t *timep)
11210 {
11211   char *p;
11212   time_t when;
11213   struct tm *rsltmp;
11214
11215   if (timep == NULL) {
11216     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11217     return NULL;
11218   }
11219   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11220
11221   when = *timep;
11222 # ifdef VMSISH_TIME
11223   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11224 #  endif
11225 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
11226   return gmtime(&when);
11227 # else
11228   /* CRTL localtime() wants local time as input, so does no tz correction */
11229   rsltmp = localtime(&when);
11230   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
11231   return rsltmp;
11232 #endif
11233 }  /* end of my_gmtime() */
11234 /*}}}*/
11235
11236
11237 /*{{{struct tm *my_localtime(const time_t *timep)*/
11238 struct tm *
11239 Perl_my_localtime(pTHX_ const time_t *timep)
11240 {
11241   time_t when, whenutc;
11242   struct tm *rsltmp;
11243   int dst, offset;
11244
11245   if (timep == NULL) {
11246     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11247     return NULL;
11248   }
11249   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11250   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11251
11252   when = *timep;
11253 # ifdef RTL_USES_UTC
11254 # ifdef VMSISH_TIME
11255   if (VMSISH_TIME) when = _toutc(when);
11256 # endif
11257   /* CRTL localtime() wants UTC as input, does tz correction itself */
11258   return localtime(&when);
11259
11260 # else /* !RTL_USES_UTC */
11261   whenutc = when;
11262 # ifdef VMSISH_TIME
11263   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
11264   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
11265 # endif
11266   dst = -1;
11267 #ifndef RTL_USES_UTC
11268   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
11269       when = whenutc - offset;                   /* pseudolocal time*/
11270   }
11271 # endif
11272   /* CRTL localtime() wants local time as input, so does no tz correction */
11273   rsltmp = localtime(&when);
11274   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
11275   return rsltmp;
11276 # endif
11277
11278 } /*  end of my_localtime() */
11279 /*}}}*/
11280
11281 /* Reset definitions for later calls */
11282 #define gmtime(t)    my_gmtime(t)
11283 #define localtime(t) my_localtime(t)
11284 #define time(t)      my_time(t)
11285
11286
11287 /* my_utime - update modification/access time of a file
11288  *
11289  * VMS 7.3 and later implementation
11290  * Only the UTC translation is home-grown. The rest is handled by the
11291  * CRTL utime(), which will take into account the relevant feature
11292  * logicals and ODS-5 volume characteristics for true access times.
11293  *
11294  * pre VMS 7.3 implementation:
11295  * The calling sequence is identical to POSIX utime(), but under
11296  * VMS with ODS-2, only the modification time is changed; ODS-2 does
11297  * not maintain access times.  Restrictions differ from the POSIX
11298  * definition in that the time can be changed as long as the
11299  * caller has permission to execute the necessary IO$_MODIFY $QIO;
11300  * no separate checks are made to insure that the caller is the
11301  * owner of the file or has special privs enabled.
11302  * Code here is based on Joe Meadows' FILE utility.
11303  *
11304  */
11305
11306 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11307  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
11308  * in 100 ns intervals.
11309  */
11310 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11311
11312 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11313 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11314 {
11315 #if __CRTL_VER >= 70300000
11316   struct utimbuf utc_utimes, *utc_utimesp;
11317
11318   if (utimes != NULL) {
11319     utc_utimes.actime = utimes->actime;
11320     utc_utimes.modtime = utimes->modtime;
11321 # ifdef VMSISH_TIME
11322     /* If input was local; convert to UTC for sys svc */
11323     if (VMSISH_TIME) {
11324       utc_utimes.actime = _toutc(utimes->actime);
11325       utc_utimes.modtime = _toutc(utimes->modtime);
11326     }
11327 # endif
11328     utc_utimesp = &utc_utimes;
11329   }
11330   else {
11331     utc_utimesp = NULL;
11332   }
11333
11334   return utime(file, utc_utimesp);
11335
11336 #else /* __CRTL_VER < 70300000 */
11337
11338   register int i;
11339   int sts;
11340   long int bintime[2], len = 2, lowbit, unixtime,
11341            secscale = 10000000; /* seconds --> 100 ns intervals */
11342   unsigned long int chan, iosb[2], retsts;
11343   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11344   struct FAB myfab = cc$rms_fab;
11345   struct NAM mynam = cc$rms_nam;
11346 #if defined (__DECC) && defined (__VAX)
11347   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11348    * at least through VMS V6.1, which causes a type-conversion warning.
11349    */
11350 #  pragma message save
11351 #  pragma message disable cvtdiftypes
11352 #endif
11353   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11354   struct fibdef myfib;
11355 #if defined (__DECC) && defined (__VAX)
11356   /* This should be right after the declaration of myatr, but due
11357    * to a bug in VAX DEC C, this takes effect a statement early.
11358    */
11359 #  pragma message restore
11360 #endif
11361   /* cast ok for read only parameter */
11362   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11363                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11364                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
11365
11366   if (file == NULL || *file == '\0') {
11367     SETERRNO(ENOENT, LIB$_INVARG);
11368     return -1;
11369   }
11370
11371   /* Convert to VMS format ensuring that it will fit in 255 characters */
11372   if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
11373       SETERRNO(ENOENT, LIB$_INVARG);
11374       return -1;
11375   }
11376   if (utimes != NULL) {
11377     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
11378      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11379      * Since time_t is unsigned long int, and lib$emul takes a signed long int
11380      * as input, we force the sign bit to be clear by shifting unixtime right
11381      * one bit, then multiplying by an extra factor of 2 in lib$emul().
11382      */
11383     lowbit = (utimes->modtime & 1) ? secscale : 0;
11384     unixtime = (long int) utimes->modtime;
11385 #   ifdef VMSISH_TIME
11386     /* If input was UTC; convert to local for sys svc */
11387     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
11388 #   endif
11389     unixtime >>= 1;  secscale <<= 1;
11390     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11391     if (!(retsts & 1)) {
11392       SETERRNO(EVMSERR, retsts);
11393       return -1;
11394     }
11395     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11396     if (!(retsts & 1)) {
11397       SETERRNO(EVMSERR, retsts);
11398       return -1;
11399     }
11400   }
11401   else {
11402     /* Just get the current time in VMS format directly */
11403     retsts = sys$gettim(bintime);
11404     if (!(retsts & 1)) {
11405       SETERRNO(EVMSERR, retsts);
11406       return -1;
11407     }
11408   }
11409
11410   myfab.fab$l_fna = vmsspec;
11411   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11412   myfab.fab$l_nam = &mynam;
11413   mynam.nam$l_esa = esa;
11414   mynam.nam$b_ess = (unsigned char) sizeof esa;
11415   mynam.nam$l_rsa = rsa;
11416   mynam.nam$b_rss = (unsigned char) sizeof rsa;
11417   if (decc_efs_case_preserve)
11418       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
11419
11420   /* Look for the file to be affected, letting RMS parse the file
11421    * specification for us as well.  I have set errno using only
11422    * values documented in the utime() man page for VMS POSIX.
11423    */
11424   retsts = sys$parse(&myfab,0,0);
11425   if (!(retsts & 1)) {
11426     set_vaxc_errno(retsts);
11427     if      (retsts == RMS$_PRV) set_errno(EACCES);
11428     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11429     else                         set_errno(EVMSERR);
11430     return -1;
11431   }
11432   retsts = sys$search(&myfab,0,0);
11433   if (!(retsts & 1)) {
11434     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11435     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11436     set_vaxc_errno(retsts);
11437     if      (retsts == RMS$_PRV) set_errno(EACCES);
11438     else if (retsts == RMS$_FNF) set_errno(ENOENT);
11439     else                         set_errno(EVMSERR);
11440     return -1;
11441   }
11442
11443   devdsc.dsc$w_length = mynam.nam$b_dev;
11444   /* cast ok for read only parameter */
11445   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11446
11447   retsts = sys$assign(&devdsc,&chan,0,0);
11448   if (!(retsts & 1)) {
11449     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11450     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11451     set_vaxc_errno(retsts);
11452     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
11453     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
11454     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
11455     else                               set_errno(EVMSERR);
11456     return -1;
11457   }
11458
11459   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11460   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11461
11462   memset((void *) &myfib, 0, sizeof myfib);
11463 #if defined(__DECC) || defined(__DECCXX)
11464   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11465   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11466   /* This prevents the revision time of the file being reset to the current
11467    * time as a result of our IO$_MODIFY $QIO. */
11468   myfib.fib$l_acctl = FIB$M_NORECORD;
11469 #else
11470   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11471   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11472   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11473 #endif
11474   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
11475   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11476   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11477   _ckvmssts(sys$dassgn(chan));
11478   if (retsts & 1) retsts = iosb[0];
11479   if (!(retsts & 1)) {
11480     set_vaxc_errno(retsts);
11481     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11482     else                      set_errno(EVMSERR);
11483     return -1;
11484   }
11485
11486   return 0;
11487
11488 #endif /* #if __CRTL_VER >= 70300000 */
11489
11490 }  /* end of my_utime() */
11491 /*}}}*/
11492
11493 /*
11494  * flex_stat, flex_lstat, flex_fstat
11495  * basic stat, but gets it right when asked to stat
11496  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11497  */
11498
11499 #ifndef _USE_STD_STAT
11500 /* encode_dev packs a VMS device name string into an integer to allow
11501  * simple comparisons. This can be used, for example, to check whether two
11502  * files are located on the same device, by comparing their encoded device
11503  * names. Even a string comparison would not do, because stat() reuses the
11504  * device name buffer for each call; so without encode_dev, it would be
11505  * necessary to save the buffer and use strcmp (this would mean a number of
11506  * changes to the standard Perl code, to say nothing of what a Perl script
11507  * would have to do.
11508  *
11509  * The device lock id, if it exists, should be unique (unless perhaps compared
11510  * with lock ids transferred from other nodes). We have a lock id if the disk is
11511  * mounted cluster-wide, which is when we tend to get long (host-qualified)
11512  * device names. Thus we use the lock id in preference, and only if that isn't
11513  * available, do we try to pack the device name into an integer (flagged by
11514  * the sign bit (LOCKID_MASK) being set).
11515  *
11516  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11517  * name and its encoded form, but it seems very unlikely that we will find
11518  * two files on different disks that share the same encoded device names,
11519  * and even more remote that they will share the same file id (if the test
11520  * is to check for the same file).
11521  *
11522  * A better method might be to use sys$device_scan on the first call, and to
11523  * search for the device, returning an index into the cached array.
11524  * The number returned would be more intelligible.
11525  * This is probably not worth it, and anyway would take quite a bit longer
11526  * on the first call.
11527  */
11528 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
11529 static mydev_t encode_dev (pTHX_ const char *dev)
11530 {
11531   int i;
11532   unsigned long int f;
11533   mydev_t enc;
11534   char c;
11535   const char *q;
11536
11537   if (!dev || !dev[0]) return 0;
11538
11539 #if LOCKID_MASK
11540   {
11541     struct dsc$descriptor_s dev_desc;
11542     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11543
11544     /* For cluster-mounted disks, the disk lock identifier is unique, so we
11545        can try that first. */
11546     dev_desc.dsc$w_length =  strlen (dev);
11547     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
11548     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
11549     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
11550     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11551     if (!$VMS_STATUS_SUCCESS(status)) {
11552       switch (status) {
11553         case SS$_NOSUCHDEV:
11554           SETERRNO(ENODEV, status);
11555           return 0;
11556         default:
11557           _ckvmssts(status);
11558       }
11559     }
11560     if (lockid) return (lockid & ~LOCKID_MASK);
11561   }
11562 #endif
11563
11564   /* Otherwise we try to encode the device name */
11565   enc = 0;
11566   f = 1;
11567   i = 0;
11568   for (q = dev + strlen(dev); q--; q >= dev) {
11569     if (*q == ':')
11570         break;
11571     if (isdigit (*q))
11572       c= (*q) - '0';
11573     else if (isalpha (toupper (*q)))
11574       c= toupper (*q) - 'A' + (char)10;
11575     else
11576       continue; /* Skip '$'s */
11577     i++;
11578     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
11579     if (i>1) f *= 36;
11580     enc += f * (unsigned long int) c;
11581   }
11582   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
11583
11584 }  /* end of encode_dev() */
11585 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11586         device_no = encode_dev(aTHX_ devname)
11587 #else
11588 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11589         device_no = new_dev_no
11590 #endif
11591
11592 static int
11593 is_null_device(name)
11594     const char *name;
11595 {
11596   if (decc_bug_devnull != 0) {
11597     if (strncmp("/dev/null", name, 9) == 0)
11598       return 1;
11599   }
11600     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11601        The underscore prefix, controller letter, and unit number are
11602        independently optional; for our purposes, the colon punctuation
11603        is not.  The colon can be trailed by optional directory and/or
11604        filename, but two consecutive colons indicates a nodename rather
11605        than a device.  [pr]  */
11606   if (*name == '_') ++name;
11607   if (tolower(*name++) != 'n') return 0;
11608   if (tolower(*name++) != 'l') return 0;
11609   if (tolower(*name) == 'a') ++name;
11610   if (*name == '0') ++name;
11611   return (*name++ == ':') && (*name != ':');
11612 }
11613
11614
11615 static I32
11616 Perl_cando_by_name_int
11617    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
11618 {
11619   char usrname[L_cuserid];
11620   struct dsc$descriptor_s usrdsc =
11621          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11622   char *vmsname = NULL, *fileified = NULL;
11623   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11624   unsigned short int retlen, trnlnm_iter_count;
11625   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11626   union prvdef curprv;
11627   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11628          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11629          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11630   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11631          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11632          {0,0,0,0}};
11633   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11634          {0,0,0,0}};
11635   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11636   Stat_t st;
11637   static int profile_context = -1;
11638
11639   if (!fname || !*fname) return FALSE;
11640
11641   /* Make sure we expand logical names, since sys$check_access doesn't */
11642   fileified = PerlMem_malloc(VMS_MAXRSS);
11643   if (fileified == NULL) _ckvmssts(SS$_INSFMEM);
11644   if (!strpbrk(fname,"/]>:")) {
11645       strcpy(fileified,fname);
11646       trnlnm_iter_count = 0;
11647       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11648         trnlnm_iter_count++;
11649         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11650       }
11651       fname = fileified;
11652   }
11653
11654   vmsname = PerlMem_malloc(VMS_MAXRSS);
11655   if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
11656   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11657     /* Don't know if already in VMS format, so make sure */
11658     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11659       PerlMem_free(fileified);
11660       PerlMem_free(vmsname);
11661       return FALSE;
11662     }
11663   }
11664   else {
11665     strcpy(vmsname,fname);
11666   }
11667
11668   /* sys$check_access needs a file spec, not a directory spec.
11669    * Don't use flex_stat here, as that depends on thread context
11670    * having been initialized, and we may get here during startup.
11671    */
11672
11673   retlen = namdsc.dsc$w_length = strlen(vmsname);
11674   if (vmsname[retlen-1] == ']'
11675       || vmsname[retlen-1] == '>'
11676       || vmsname[retlen-1] == ':'
11677       || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
11678
11679       if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) {
11680         PerlMem_free(fileified);
11681         PerlMem_free(vmsname);
11682         return FALSE;
11683       }
11684       fname = fileified;
11685   }
11686   else {
11687       fname = vmsname;
11688   }
11689
11690   retlen = namdsc.dsc$w_length = strlen(fname);
11691   namdsc.dsc$a_pointer = (char *)fname;
11692
11693   switch (bit) {
11694     case S_IXUSR: case S_IXGRP: case S_IXOTH:
11695       access = ARM$M_EXECUTE;
11696       flags = CHP$M_READ;
11697       break;
11698     case S_IRUSR: case S_IRGRP: case S_IROTH:
11699       access = ARM$M_READ;
11700       flags = CHP$M_READ | CHP$M_USEREADALL;
11701       break;
11702     case S_IWUSR: case S_IWGRP: case S_IWOTH:
11703       access = ARM$M_WRITE;
11704       flags = CHP$M_READ | CHP$M_WRITE;
11705       break;
11706     case S_IDUSR: case S_IDGRP: case S_IDOTH:
11707       access = ARM$M_DELETE;
11708       flags = CHP$M_READ | CHP$M_WRITE;
11709       break;
11710     default:
11711       if (fileified != NULL)
11712         PerlMem_free(fileified);
11713       if (vmsname != NULL)
11714         PerlMem_free(vmsname);
11715       return FALSE;
11716   }
11717
11718   /* Before we call $check_access, create a user profile with the current
11719    * process privs since otherwise it just uses the default privs from the
11720    * UAF and might give false positives or negatives.  This only works on
11721    * VMS versions v6.0 and later since that's when sys$create_user_profile
11722    * became available.
11723    */
11724
11725   /* get current process privs and username */
11726   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11727   _ckvmssts(iosb[0]);
11728
11729 #if defined(__VMS_VER) && __VMS_VER >= 60000000
11730
11731   /* find out the space required for the profile */
11732   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11733                                     &usrprodsc.dsc$w_length,&profile_context));
11734
11735   /* allocate space for the profile and get it filled in */
11736   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11737   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
11738   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11739                                     &usrprodsc.dsc$w_length,&profile_context));
11740
11741   /* use the profile to check access to the file; free profile & analyze results */
11742   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
11743   PerlMem_free(usrprodsc.dsc$a_pointer);
11744   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11745
11746 #else
11747
11748   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11749
11750 #endif
11751
11752   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
11753       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11754       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11755     set_vaxc_errno(retsts);
11756     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11757     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11758     else set_errno(ENOENT);
11759     if (fileified != NULL)
11760       PerlMem_free(fileified);
11761     if (vmsname != NULL)
11762       PerlMem_free(vmsname);
11763     return FALSE;
11764   }
11765   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11766     if (fileified != NULL)
11767       PerlMem_free(fileified);
11768     if (vmsname != NULL)
11769       PerlMem_free(vmsname);
11770     return TRUE;
11771   }
11772   _ckvmssts(retsts);
11773
11774   if (fileified != NULL)
11775     PerlMem_free(fileified);
11776   if (vmsname != NULL)
11777     PerlMem_free(vmsname);
11778   return FALSE;  /* Should never get here */
11779
11780 }
11781
11782 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
11783 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11784  * subset of the applicable information.
11785  */
11786 bool
11787 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11788 {
11789   return cando_by_name_int
11790         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11791 }  /* end of cando() */
11792 /*}}}*/
11793
11794
11795 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11796 I32
11797 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11798 {
11799    return cando_by_name_int(bit, effective, fname, 0);
11800
11801 }  /* end of cando_by_name() */
11802 /*}}}*/
11803
11804
11805 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
11806 int
11807 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
11808 {
11809   if (!fstat(fd,(stat_t *) statbufp)) {
11810     char *cptr;
11811     char *vms_filename;
11812     vms_filename = PerlMem_malloc(VMS_MAXRSS);
11813     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
11814
11815     /* Save name for cando by name in VMS format */
11816     cptr = getname(fd, vms_filename, 1);
11817
11818     /* This should not happen, but just in case */
11819     if (cptr == NULL) {
11820         statbufp->st_devnam[0] = 0;
11821     }
11822     else {
11823         /* Make sure that the saved name fits in 255 characters */
11824         cptr = do_rmsexpand
11825                        (vms_filename,
11826                         statbufp->st_devnam,
11827                         0,
11828                         NULL,
11829                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
11830                         NULL,
11831                         NULL);
11832         if (cptr == NULL)
11833             statbufp->st_devnam[0] = 0;
11834     }
11835     PerlMem_free(vms_filename);
11836
11837     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11838     VMS_DEVICE_ENCODE
11839         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11840
11841 #   ifdef RTL_USES_UTC
11842 #   ifdef VMSISH_TIME
11843     if (VMSISH_TIME) {
11844       statbufp->st_mtime = _toloc(statbufp->st_mtime);
11845       statbufp->st_atime = _toloc(statbufp->st_atime);
11846       statbufp->st_ctime = _toloc(statbufp->st_ctime);
11847     }
11848 #   endif
11849 #   else
11850 #   ifdef VMSISH_TIME
11851     if (!VMSISH_TIME) { /* Return UTC instead of local time */
11852 #   else
11853     if (1) {
11854 #   endif
11855       statbufp->st_mtime = _toutc(statbufp->st_mtime);
11856       statbufp->st_atime = _toutc(statbufp->st_atime);
11857       statbufp->st_ctime = _toutc(statbufp->st_ctime);
11858     }
11859 #endif
11860     return 0;
11861   }
11862   return -1;
11863
11864 }  /* end of flex_fstat() */
11865 /*}}}*/
11866
11867 #if !defined(__VAX) && __CRTL_VER >= 80200000
11868 #ifdef lstat
11869 #undef lstat
11870 #endif
11871 #else
11872 #ifdef lstat
11873 #undef lstat
11874 #endif
11875 #define lstat(_x, _y) stat(_x, _y)
11876 #endif
11877
11878 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11879
11880 static int
11881 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
11882 {
11883     char fileified[VMS_MAXRSS];
11884     char temp_fspec[VMS_MAXRSS];
11885     char *save_spec;
11886     int retval = -1;
11887     int saved_errno, saved_vaxc_errno;
11888
11889     if (!fspec) return retval;
11890     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
11891     strcpy(temp_fspec, fspec);
11892
11893     if (decc_bug_devnull != 0) {
11894       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
11895         memset(statbufp,0,sizeof *statbufp);
11896         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
11897         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
11898         statbufp->st_uid = 0x00010001;
11899         statbufp->st_gid = 0x0001;
11900         time((time_t *)&statbufp->st_mtime);
11901         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
11902         return 0;
11903       }
11904     }
11905
11906     /* Try for a directory name first.  If fspec contains a filename without
11907      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
11908      * and sea:[wine.dark]water. exist, we prefer the directory here.
11909      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
11910      * not sea:[wine.dark]., if the latter exists.  If the intended target is
11911      * the file with null type, specify this by calling flex_stat() with
11912      * a '.' at the end of fspec.
11913      *
11914      * If we are in Posix filespec mode, accept the filename as is.
11915      */
11916
11917
11918 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11919   /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
11920    * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
11921    */
11922   if (!decc_efs_charset)
11923     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
11924 #endif
11925
11926 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11927   if (decc_posix_compliant_pathnames == 0) {
11928 #endif
11929     if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
11930       if (lstat_flag == 0)
11931         retval = stat(fileified,(stat_t *) statbufp);
11932       else
11933         retval = lstat(fileified,(stat_t *) statbufp);
11934       save_spec = fileified;
11935     }
11936     if (retval) {
11937       if (lstat_flag == 0)
11938         retval = stat(temp_fspec,(stat_t *) statbufp);
11939       else
11940         retval = lstat(temp_fspec,(stat_t *) statbufp);
11941       save_spec = temp_fspec;
11942     }
11943 /*
11944  * In debugging, on 8.3 Alpha, I found a case where stat was returning a
11945  * file not found error for a directory named foo:[bar.t] or /foo/bar/t
11946  * and lstat was working correctly for the same file.
11947  * The only syntax that was working for stat was "foo:[bar]t.dir".
11948  *
11949  * Other directories with the same syntax worked fine.
11950  * So work around the problem when it shows up here.
11951  */
11952     if (retval) {
11953         int save_errno = errno;
11954         if (do_tovmsspec(fspec, temp_fspec, 0, NULL) != NULL) {
11955             if (do_fileify_dirspec(temp_fspec, fileified, 0, NULL) != NULL) {
11956                 retval = stat(fileified, (stat_t *) statbufp);
11957                 save_spec = fileified;
11958             }
11959         }
11960         /* Restore the errno value if third stat does not succeed */
11961         if (retval != 0)
11962             errno = save_errno;
11963     }
11964 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11965   } else {
11966     if (lstat_flag == 0)
11967       retval = stat(temp_fspec,(stat_t *) statbufp);
11968     else
11969       retval = lstat(temp_fspec,(stat_t *) statbufp);
11970       save_spec = temp_fspec;
11971   }
11972 #endif
11973
11974 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11975   /* As you were... */
11976   if (!decc_efs_charset)
11977     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
11978 #endif
11979
11980     if (!retval) {
11981     char * cptr;
11982     int rmsex_flags = PERL_RMSEXPAND_M_VMS;
11983
11984       /* If this is an lstat, do not follow the link */
11985       if (lstat_flag)
11986         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
11987
11988       cptr = do_rmsexpand
11989        (save_spec, statbufp->st_devnam, 0, NULL, rmsex_flags, NULL, NULL);
11990       if (cptr == NULL)
11991         statbufp->st_devnam[0] = 0;
11992
11993       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11994       VMS_DEVICE_ENCODE
11995         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11996 #     ifdef RTL_USES_UTC
11997 #     ifdef VMSISH_TIME
11998       if (VMSISH_TIME) {
11999         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12000         statbufp->st_atime = _toloc(statbufp->st_atime);
12001         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12002       }
12003 #     endif
12004 #     else
12005 #     ifdef VMSISH_TIME
12006       if (!VMSISH_TIME) { /* Return UTC instead of local time */
12007 #     else
12008       if (1) {
12009 #     endif
12010         statbufp->st_mtime = _toutc(statbufp->st_mtime);
12011         statbufp->st_atime = _toutc(statbufp->st_atime);
12012         statbufp->st_ctime = _toutc(statbufp->st_ctime);
12013       }
12014 #     endif
12015     }
12016     /* If we were successful, leave errno where we found it */
12017     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
12018     return retval;
12019
12020 }  /* end of flex_stat_int() */
12021
12022
12023 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12024 int
12025 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12026 {
12027    return flex_stat_int(fspec, statbufp, 0);
12028 }
12029 /*}}}*/
12030
12031 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12032 int
12033 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12034 {
12035    return flex_stat_int(fspec, statbufp, 1);
12036 }
12037 /*}}}*/
12038
12039
12040 /*{{{char *my_getlogin()*/
12041 /* VMS cuserid == Unix getlogin, except calling sequence */
12042 char *
12043 my_getlogin(void)
12044 {
12045     static char user[L_cuserid];
12046     return cuserid(user);
12047 }
12048 /*}}}*/
12049
12050
12051 /*  rmscopy - copy a file using VMS RMS routines
12052  *
12053  *  Copies contents and attributes of spec_in to spec_out, except owner
12054  *  and protection information.  Name and type of spec_in are used as
12055  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
12056  *  should try to propagate timestamps from the input file to the output file.
12057  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
12058  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
12059  *  propagated to the output file at creation iff the output file specification
12060  *  did not contain an explicit name or type, and the revision date is always
12061  *  updated at the end of the copy operation.  If it is greater than 0, then
12062  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12063  *  other than the revision date should be propagated, and bit 1 indicates
12064  *  that the revision date should be propagated.
12065  *
12066  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12067  *
12068  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12069  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
12070  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
12071  * as part of the Perl standard distribution under the terms of the
12072  * GNU General Public License or the Perl Artistic License.  Copies
12073  * of each may be found in the Perl standard distribution.
12074  */ /* FIXME */
12075 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12076 int
12077 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12078 {
12079     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12080          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12081     unsigned long int i, sts, sts2;
12082     int dna_len;
12083     struct FAB fab_in, fab_out;
12084     struct RAB rab_in, rab_out;
12085     rms_setup_nam(nam);
12086     rms_setup_nam(nam_out);
12087     struct XABDAT xabdat;
12088     struct XABFHC xabfhc;
12089     struct XABRDT xabrdt;
12090     struct XABSUM xabsum;
12091
12092     vmsin = PerlMem_malloc(VMS_MAXRSS);
12093     if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
12094     vmsout = PerlMem_malloc(VMS_MAXRSS);
12095     if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
12096     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
12097         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
12098       PerlMem_free(vmsin);
12099       PerlMem_free(vmsout);
12100       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12101       return 0;
12102     }
12103
12104     esa = PerlMem_malloc(VMS_MAXRSS);
12105     if (esa == NULL) _ckvmssts(SS$_INSFMEM);
12106     esal = NULL;
12107 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12108     esal = PerlMem_malloc(VMS_MAXRSS);
12109     if (esal == NULL) _ckvmssts(SS$_INSFMEM);
12110 #endif
12111     fab_in = cc$rms_fab;
12112     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12113     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12114     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12115     fab_in.fab$l_fop = FAB$M_SQO;
12116     rms_bind_fab_nam(fab_in, nam);
12117     fab_in.fab$l_xab = (void *) &xabdat;
12118
12119     rsa = PerlMem_malloc(VMS_MAXRSS);
12120     if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
12121     rsal = NULL;
12122 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12123     rsal = PerlMem_malloc(VMS_MAXRSS);
12124     if (rsal == NULL) _ckvmssts(SS$_INSFMEM);
12125 #endif
12126     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12127     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12128     rms_nam_esl(nam) = 0;
12129     rms_nam_rsl(nam) = 0;
12130     rms_nam_esll(nam) = 0;
12131     rms_nam_rsll(nam) = 0;
12132 #ifdef NAM$M_NO_SHORT_UPCASE
12133     if (decc_efs_case_preserve)
12134         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12135 #endif
12136
12137     xabdat = cc$rms_xabdat;        /* To get creation date */
12138     xabdat.xab$l_nxt = (void *) &xabfhc;
12139
12140     xabfhc = cc$rms_xabfhc;        /* To get record length */
12141     xabfhc.xab$l_nxt = (void *) &xabsum;
12142
12143     xabsum = cc$rms_xabsum;        /* To get key and area information */
12144
12145     if (!((sts = sys$open(&fab_in)) & 1)) {
12146       PerlMem_free(vmsin);
12147       PerlMem_free(vmsout);
12148       PerlMem_free(esa);
12149       if (esal != NULL)
12150         PerlMem_free(esal);
12151       PerlMem_free(rsa);
12152       if (rsal != NULL)
12153         PerlMem_free(rsal);
12154       set_vaxc_errno(sts);
12155       switch (sts) {
12156         case RMS$_FNF: case RMS$_DNF:
12157           set_errno(ENOENT); break;
12158         case RMS$_DIR:
12159           set_errno(ENOTDIR); break;
12160         case RMS$_DEV:
12161           set_errno(ENODEV); break;
12162         case RMS$_SYN:
12163           set_errno(EINVAL); break;
12164         case RMS$_PRV:
12165           set_errno(EACCES); break;
12166         default:
12167           set_errno(EVMSERR);
12168       }
12169       return 0;
12170     }
12171
12172     nam_out = nam;
12173     fab_out = fab_in;
12174     fab_out.fab$w_ifi = 0;
12175     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12176     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12177     fab_out.fab$l_fop = FAB$M_SQO;
12178     rms_bind_fab_nam(fab_out, nam_out);
12179     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12180     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12181     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12182     esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12183     if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
12184     rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12185     if (rsa_out == NULL) _ckvmssts(SS$_INSFMEM);
12186     esal_out = NULL;
12187     rsal_out = NULL;
12188 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12189     esal_out = PerlMem_malloc(VMS_MAXRSS);
12190     if (esal_out == NULL) _ckvmssts(SS$_INSFMEM);
12191     rsal_out = PerlMem_malloc(VMS_MAXRSS);
12192     if (rsal_out == NULL) _ckvmssts(SS$_INSFMEM);
12193 #endif
12194     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12195     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12196
12197     if (preserve_dates == 0) {  /* Act like DCL COPY */
12198       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12199       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
12200       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12201         PerlMem_free(vmsin);
12202         PerlMem_free(vmsout);
12203         PerlMem_free(esa);
12204         if (esal != NULL)
12205             PerlMem_free(esal);
12206         PerlMem_free(rsa);
12207         if (rsal != NULL)
12208             PerlMem_free(rsal);
12209         PerlMem_free(esa_out);
12210         if (esal_out != NULL)
12211             PerlMem_free(esal_out);
12212         PerlMem_free(rsa_out);
12213         if (rsal_out != NULL)
12214             PerlMem_free(rsal_out);
12215         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12216         set_vaxc_errno(sts);
12217         return 0;
12218       }
12219       fab_out.fab$l_xab = (void *) &xabdat;
12220       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12221         preserve_dates = 1;
12222     }
12223     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
12224       preserve_dates =0;      /* bitmask from this point forward   */
12225
12226     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12227     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12228       PerlMem_free(vmsin);
12229       PerlMem_free(vmsout);
12230       PerlMem_free(esa);
12231       if (esal != NULL)
12232           PerlMem_free(esal);
12233       PerlMem_free(rsa);
12234       if (rsal != NULL)
12235           PerlMem_free(rsal);
12236       PerlMem_free(esa_out);
12237       if (esal_out != NULL)
12238           PerlMem_free(esal_out);
12239       PerlMem_free(rsa_out);
12240       if (rsal_out != NULL)
12241           PerlMem_free(rsal_out);
12242       set_vaxc_errno(sts);
12243       switch (sts) {
12244         case RMS$_DNF:
12245           set_errno(ENOENT); break;
12246         case RMS$_DIR:
12247           set_errno(ENOTDIR); break;
12248         case RMS$_DEV:
12249           set_errno(ENODEV); break;
12250         case RMS$_SYN:
12251           set_errno(EINVAL); break;
12252         case RMS$_PRV:
12253           set_errno(EACCES); break;
12254         default:
12255           set_errno(EVMSERR);
12256       }
12257       return 0;
12258     }
12259     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
12260     if (preserve_dates & 2) {
12261       /* sys$close() will process xabrdt, not xabdat */
12262       xabrdt = cc$rms_xabrdt;
12263 #ifndef __GNUC__
12264       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12265 #else
12266       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12267        * is unsigned long[2], while DECC & VAXC use a struct */
12268       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12269 #endif
12270       fab_out.fab$l_xab = (void *) &xabrdt;
12271     }
12272
12273     ubf = PerlMem_malloc(32256);
12274     if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
12275     rab_in = cc$rms_rab;
12276     rab_in.rab$l_fab = &fab_in;
12277     rab_in.rab$l_rop = RAB$M_BIO;
12278     rab_in.rab$l_ubf = ubf;
12279     rab_in.rab$w_usz = 32256;
12280     if (!((sts = sys$connect(&rab_in)) & 1)) {
12281       sys$close(&fab_in); sys$close(&fab_out);
12282       PerlMem_free(vmsin);
12283       PerlMem_free(vmsout);
12284       PerlMem_free(ubf);
12285       PerlMem_free(esa);
12286       if (esal != NULL)
12287           PerlMem_free(esal);
12288       PerlMem_free(rsa);
12289       if (rsal != NULL)
12290           PerlMem_free(rsal);
12291       PerlMem_free(esa_out);
12292       if (esal_out != NULL)
12293           PerlMem_free(esal_out);
12294       PerlMem_free(rsa_out);
12295       if (rsal_out != NULL)
12296           PerlMem_free(rsal_out);
12297       set_errno(EVMSERR); set_vaxc_errno(sts);
12298       return 0;
12299     }
12300
12301     rab_out = cc$rms_rab;
12302     rab_out.rab$l_fab = &fab_out;
12303     rab_out.rab$l_rbf = ubf;
12304     if (!((sts = sys$connect(&rab_out)) & 1)) {
12305       sys$close(&fab_in); sys$close(&fab_out);
12306       PerlMem_free(vmsin);
12307       PerlMem_free(vmsout);
12308       PerlMem_free(ubf);
12309       PerlMem_free(esa);
12310       if (esal != NULL)
12311           PerlMem_free(esal);
12312       PerlMem_free(rsa);
12313       if (rsal != NULL)
12314           PerlMem_free(rsal);
12315       PerlMem_free(esa_out);
12316       if (esal_out != NULL)
12317           PerlMem_free(esal_out);
12318       PerlMem_free(rsa_out);
12319       if (rsal_out != NULL)
12320           PerlMem_free(rsal_out);
12321       set_errno(EVMSERR); set_vaxc_errno(sts);
12322       return 0;
12323     }
12324
12325     while ((sts = sys$read(&rab_in))) {  /* always true  */
12326       if (sts == RMS$_EOF) break;
12327       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12328       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12329         sys$close(&fab_in); sys$close(&fab_out);
12330         PerlMem_free(vmsin);
12331         PerlMem_free(vmsout);
12332         PerlMem_free(ubf);
12333         PerlMem_free(esa);
12334         if (esal != NULL)
12335             PerlMem_free(esal);
12336         PerlMem_free(rsa);
12337         if (rsal != NULL)
12338             PerlMem_free(rsal);
12339         PerlMem_free(esa_out);
12340         if (esal_out != NULL)
12341             PerlMem_free(esal_out);
12342         PerlMem_free(rsa_out);
12343         if (rsal_out != NULL)
12344             PerlMem_free(rsal_out);
12345         set_errno(EVMSERR); set_vaxc_errno(sts);
12346         return 0;
12347       }
12348     }
12349
12350
12351     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
12352     sys$close(&fab_in);  sys$close(&fab_out);
12353     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12354
12355     PerlMem_free(vmsin);
12356     PerlMem_free(vmsout);
12357     PerlMem_free(ubf);
12358     PerlMem_free(esa);
12359     if (esal != NULL)
12360         PerlMem_free(esal);
12361     PerlMem_free(rsa);
12362     if (rsal != NULL)
12363         PerlMem_free(rsal);
12364     PerlMem_free(esa_out);
12365     if (esal_out != NULL)
12366         PerlMem_free(esal_out);
12367     PerlMem_free(rsa_out);
12368     if (rsal_out != NULL)
12369         PerlMem_free(rsal_out);
12370
12371     if (!(sts & 1)) {
12372       set_errno(EVMSERR); set_vaxc_errno(sts);
12373       return 0;
12374     }
12375
12376     return 1;
12377
12378 }  /* end of rmscopy() */
12379 /*}}}*/
12380
12381
12382 /***  The following glue provides 'hooks' to make some of the routines
12383  * from this file available from Perl.  These routines are sufficiently
12384  * basic, and are required sufficiently early in the build process,
12385  * that's it's nice to have them available to miniperl as well as the
12386  * full Perl, so they're set up here instead of in an extension.  The
12387  * Perl code which handles importation of these names into a given
12388  * package lives in [.VMS]Filespec.pm in @INC.
12389  */
12390
12391 void
12392 rmsexpand_fromperl(pTHX_ CV *cv)
12393 {
12394   dXSARGS;
12395   char *fspec, *defspec = NULL, *rslt;
12396   STRLEN n_a;
12397   int fs_utf8, dfs_utf8;
12398
12399   fs_utf8 = 0;
12400   dfs_utf8 = 0;
12401   if (!items || items > 2)
12402     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12403   fspec = SvPV(ST(0),n_a);
12404   fs_utf8 = SvUTF8(ST(0));
12405   if (!fspec || !*fspec) XSRETURN_UNDEF;
12406   if (items == 2) {
12407     defspec = SvPV(ST(1),n_a);
12408     dfs_utf8 = SvUTF8(ST(1));
12409   }
12410   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12411   ST(0) = sv_newmortal();
12412   if (rslt != NULL) {
12413     sv_usepvn(ST(0),rslt,strlen(rslt));
12414     if (fs_utf8) {
12415         SvUTF8_on(ST(0));
12416     }
12417   }
12418   XSRETURN(1);
12419 }
12420
12421 void
12422 vmsify_fromperl(pTHX_ CV *cv)
12423 {
12424   dXSARGS;
12425   char *vmsified;
12426   STRLEN n_a;
12427   int utf8_fl;
12428
12429   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12430   utf8_fl = SvUTF8(ST(0));
12431   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12432   ST(0) = sv_newmortal();
12433   if (vmsified != NULL) {
12434     sv_usepvn(ST(0),vmsified,strlen(vmsified));
12435     if (utf8_fl) {
12436         SvUTF8_on(ST(0));
12437     }
12438   }
12439   XSRETURN(1);
12440 }
12441
12442 void
12443 unixify_fromperl(pTHX_ CV *cv)
12444 {
12445   dXSARGS;
12446   char *unixified;
12447   STRLEN n_a;
12448   int utf8_fl;
12449
12450   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12451   utf8_fl = SvUTF8(ST(0));
12452   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12453   ST(0) = sv_newmortal();
12454   if (unixified != NULL) {
12455     sv_usepvn(ST(0),unixified,strlen(unixified));
12456     if (utf8_fl) {
12457         SvUTF8_on(ST(0));
12458     }
12459   }
12460   XSRETURN(1);
12461 }
12462
12463 void
12464 fileify_fromperl(pTHX_ CV *cv)
12465 {
12466   dXSARGS;
12467   char *fileified;
12468   STRLEN n_a;
12469   int utf8_fl;
12470
12471   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12472   utf8_fl = SvUTF8(ST(0));
12473   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12474   ST(0) = sv_newmortal();
12475   if (fileified != NULL) {
12476     sv_usepvn(ST(0),fileified,strlen(fileified));
12477     if (utf8_fl) {
12478         SvUTF8_on(ST(0));
12479     }
12480   }
12481   XSRETURN(1);
12482 }
12483
12484 void
12485 pathify_fromperl(pTHX_ CV *cv)
12486 {
12487   dXSARGS;
12488   char *pathified;
12489   STRLEN n_a;
12490   int utf8_fl;
12491
12492   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12493   utf8_fl = SvUTF8(ST(0));
12494   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12495   ST(0) = sv_newmortal();
12496   if (pathified != NULL) {
12497     sv_usepvn(ST(0),pathified,strlen(pathified));
12498     if (utf8_fl) {
12499         SvUTF8_on(ST(0));
12500     }
12501   }
12502   XSRETURN(1);
12503 }
12504
12505 void
12506 vmspath_fromperl(pTHX_ CV *cv)
12507 {
12508   dXSARGS;
12509   char *vmspath;
12510   STRLEN n_a;
12511   int utf8_fl;
12512
12513   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12514   utf8_fl = SvUTF8(ST(0));
12515   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12516   ST(0) = sv_newmortal();
12517   if (vmspath != NULL) {
12518     sv_usepvn(ST(0),vmspath,strlen(vmspath));
12519     if (utf8_fl) {
12520         SvUTF8_on(ST(0));
12521     }
12522   }
12523   XSRETURN(1);
12524 }
12525
12526 void
12527 unixpath_fromperl(pTHX_ CV *cv)
12528 {
12529   dXSARGS;
12530   char *unixpath;
12531   STRLEN n_a;
12532   int utf8_fl;
12533
12534   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12535   utf8_fl = SvUTF8(ST(0));
12536   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12537   ST(0) = sv_newmortal();
12538   if (unixpath != NULL) {
12539     sv_usepvn(ST(0),unixpath,strlen(unixpath));
12540     if (utf8_fl) {
12541         SvUTF8_on(ST(0));
12542     }
12543   }
12544   XSRETURN(1);
12545 }
12546
12547 void
12548 candelete_fromperl(pTHX_ CV *cv)
12549 {
12550   dXSARGS;
12551   char *fspec, *fsp;
12552   SV *mysv;
12553   IO *io;
12554   STRLEN n_a;
12555
12556   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12557
12558   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12559   Newx(fspec, VMS_MAXRSS, char);
12560   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12561   if (SvTYPE(mysv) == SVt_PVGV) {
12562     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12563       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12564       ST(0) = &PL_sv_no;
12565       Safefree(fspec);
12566       XSRETURN(1);
12567     }
12568     fsp = fspec;
12569   }
12570   else {
12571     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12572       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12573       ST(0) = &PL_sv_no;
12574       Safefree(fspec);
12575       XSRETURN(1);
12576     }
12577   }
12578
12579   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12580   Safefree(fspec);
12581   XSRETURN(1);
12582 }
12583
12584 void
12585 rmscopy_fromperl(pTHX_ CV *cv)
12586 {
12587   dXSARGS;
12588   char *inspec, *outspec, *inp, *outp;
12589   int date_flag;
12590   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
12591                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12592   unsigned long int sts;
12593   SV *mysv;
12594   IO *io;
12595   STRLEN n_a;
12596
12597   if (items < 2 || items > 3)
12598     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12599
12600   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12601   Newx(inspec, VMS_MAXRSS, char);
12602   if (SvTYPE(mysv) == SVt_PVGV) {
12603     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12604       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12605       ST(0) = &PL_sv_no;
12606       Safefree(inspec);
12607       XSRETURN(1);
12608     }
12609     inp = inspec;
12610   }
12611   else {
12612     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12613       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12614       ST(0) = &PL_sv_no;
12615       Safefree(inspec);
12616       XSRETURN(1);
12617     }
12618   }
12619   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12620   Newx(outspec, VMS_MAXRSS, char);
12621   if (SvTYPE(mysv) == SVt_PVGV) {
12622     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12623       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12624       ST(0) = &PL_sv_no;
12625       Safefree(inspec);
12626       Safefree(outspec);
12627       XSRETURN(1);
12628     }
12629     outp = outspec;
12630   }
12631   else {
12632     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12633       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12634       ST(0) = &PL_sv_no;
12635       Safefree(inspec);
12636       Safefree(outspec);
12637       XSRETURN(1);
12638     }
12639   }
12640   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12641
12642   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
12643   Safefree(inspec);
12644   Safefree(outspec);
12645   XSRETURN(1);
12646 }
12647
12648 /* The mod2fname is limited to shorter filenames by design, so it should
12649  * not be modified to support longer EFS pathnames
12650  */
12651 void
12652 mod2fname(pTHX_ CV *cv)
12653 {
12654   dXSARGS;
12655   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12656        workbuff[NAM$C_MAXRSS*1 + 1];
12657   int total_namelen = 3, counter, num_entries;
12658   /* ODS-5 ups this, but we want to be consistent, so... */
12659   int max_name_len = 39;
12660   AV *in_array = (AV *)SvRV(ST(0));
12661
12662   num_entries = av_len(in_array);
12663
12664   /* All the names start with PL_. */
12665   strcpy(ultimate_name, "PL_");
12666
12667   /* Clean up our working buffer */
12668   Zero(work_name, sizeof(work_name), char);
12669
12670   /* Run through the entries and build up a working name */
12671   for(counter = 0; counter <= num_entries; counter++) {
12672     /* If it's not the first name then tack on a __ */
12673     if (counter) {
12674       strcat(work_name, "__");
12675     }
12676     strcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)));
12677   }
12678
12679   /* Check to see if we actually have to bother...*/
12680   if (strlen(work_name) + 3 <= max_name_len) {
12681     strcat(ultimate_name, work_name);
12682   } else {
12683     /* It's too darned big, so we need to go strip. We use the same */
12684     /* algorithm as xsubpp does. First, strip out doubled __ */
12685     char *source, *dest, last;
12686     dest = workbuff;
12687     last = 0;
12688     for (source = work_name; *source; source++) {
12689       if (last == *source && last == '_') {
12690         continue;
12691       }
12692       *dest++ = *source;
12693       last = *source;
12694     }
12695     /* Go put it back */
12696     strcpy(work_name, workbuff);
12697     /* Is it still too big? */
12698     if (strlen(work_name) + 3 > max_name_len) {
12699       /* Strip duplicate letters */
12700       last = 0;
12701       dest = workbuff;
12702       for (source = work_name; *source; source++) {
12703         if (last == toupper(*source)) {
12704         continue;
12705         }
12706         *dest++ = *source;
12707         last = toupper(*source);
12708       }
12709       strcpy(work_name, workbuff);
12710     }
12711
12712     /* Is it *still* too big? */
12713     if (strlen(work_name) + 3 > max_name_len) {
12714       /* Too bad, we truncate */
12715       work_name[max_name_len - 2] = 0;
12716     }
12717     strcat(ultimate_name, work_name);
12718   }
12719
12720   /* Okay, return it */
12721   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
12722   XSRETURN(1);
12723 }
12724
12725 void
12726 hushexit_fromperl(pTHX_ CV *cv)
12727 {
12728     dXSARGS;
12729
12730     if (items > 0) {
12731         VMSISH_HUSHED = SvTRUE(ST(0));
12732     }
12733     ST(0) = boolSV(VMSISH_HUSHED);
12734     XSRETURN(1);
12735 }
12736
12737
12738 PerlIO *
12739 Perl_vms_start_glob
12740    (pTHX_ SV *tmpglob,
12741     IO *io)
12742 {
12743     PerlIO *fp;
12744     struct vs_str_st *rslt;
12745     char *vmsspec;
12746     char *rstr;
12747     char *begin, *cp;
12748     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
12749     PerlIO *tmpfp;
12750     STRLEN i;
12751     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12752     struct dsc$descriptor_vs rsdsc;
12753     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
12754     unsigned long hasver = 0, isunix = 0;
12755     unsigned long int lff_flags = 0;
12756     int rms_sts;
12757
12758 #ifdef VMS_LONGNAME_SUPPORT
12759     lff_flags = LIB$M_FIL_LONG_NAMES;
12760 #endif
12761     /* The Newx macro will not allow me to assign a smaller array
12762      * to the rslt pointer, so we will assign it to the begin char pointer
12763      * and then copy the value into the rslt pointer.
12764      */
12765     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
12766     rslt = (struct vs_str_st *)begin;
12767     rslt->length = 0;
12768     rstr = &rslt->str[0];
12769     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
12770     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
12771     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
12772     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
12773
12774     Newx(vmsspec, VMS_MAXRSS, char);
12775
12776         /* We could find out if there's an explicit dev/dir or version
12777            by peeking into lib$find_file's internal context at
12778            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
12779            but that's unsupported, so I don't want to do it now and
12780            have it bite someone in the future. */
12781         /* Fix-me: vms_split_path() is the only way to do this, the
12782            existing method will fail with many legal EFS or UNIX specifications
12783          */
12784
12785     cp = SvPV(tmpglob,i);
12786
12787     for (; i; i--) {
12788         if (cp[i] == ';') hasver = 1;
12789         if (cp[i] == '.') {
12790             if (sts) hasver = 1;
12791             else sts = 1;
12792         }
12793         if (cp[i] == '/') {
12794             hasdir = isunix = 1;
12795             break;
12796         }
12797         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
12798             hasdir = 1;
12799             break;
12800         }
12801     }
12802     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
12803         int found = 0;
12804         Stat_t st;
12805         int stat_sts;
12806         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
12807         if (!stat_sts && S_ISDIR(st.st_mode)) {
12808             wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
12809             ok = (wilddsc.dsc$a_pointer != NULL);
12810             /* maybe passed 'foo' rather than '[.foo]', thus not detected above */
12811             hasdir = 1;
12812         }
12813         else {
12814             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
12815             ok = (wilddsc.dsc$a_pointer != NULL);
12816         }
12817         if (ok)
12818             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
12819
12820         /* If not extended character set, replace ? with % */
12821         /* With extended character set, ? is a wildcard single character */
12822         if (!decc_efs_case_preserve) {
12823             for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
12824                 if (*cp == '?') *cp = '%';
12825         }
12826         sts = SS$_NORMAL;
12827         while (ok && $VMS_STATUS_SUCCESS(sts)) {
12828          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
12829          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
12830
12831             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
12832                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
12833             if (!$VMS_STATUS_SUCCESS(sts))
12834                 break;
12835
12836             found++;
12837
12838             /* with varying string, 1st word of buffer contains result length */
12839             rstr[rslt->length] = '\0';
12840
12841              /* Find where all the components are */
12842              v_sts = vms_split_path
12843                        (rstr,
12844                         &v_spec,
12845                         &v_len,
12846                         &r_spec,
12847                         &r_len,
12848                         &d_spec,
12849                         &d_len,
12850                         &n_spec,
12851                         &n_len,
12852                         &e_spec,
12853                         &e_len,
12854                         &vs_spec,
12855                         &vs_len);
12856
12857             /* If no version on input, truncate the version on output */
12858             if (!hasver && (vs_len > 0)) {
12859                 *vs_spec = '\0';
12860                 vs_len = 0;
12861
12862                 /* No version & a null extension on UNIX handling */
12863                 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
12864                     e_len = 0;
12865                     *e_spec = '\0';
12866                 }
12867             }
12868
12869             if (!decc_efs_case_preserve) {
12870                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
12871             }
12872
12873             if (hasdir) {
12874                 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
12875                 begin = rstr;
12876             }
12877             else {
12878                 /* Start with the name */
12879                 begin = n_spec;
12880             }
12881             strcat(begin,"\n");
12882             ok = (PerlIO_puts(tmpfp,begin) != EOF);
12883         }
12884         if (cxt) (void)lib$find_file_end(&cxt);
12885
12886         if (!found) {
12887             /* Be POSIXish: return the input pattern when no matches */
12888             strcpy(rstr,SvPVX(tmpglob));
12889             strcat(rstr,"\n");
12890             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
12891         }
12892
12893         if (ok && sts != RMS$_NMF &&
12894             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
12895         if (!ok) {
12896             if (!(sts & 1)) {
12897                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
12898             }
12899             PerlIO_close(tmpfp);
12900             fp = NULL;
12901         }
12902         else {
12903             PerlIO_rewind(tmpfp);
12904             IoTYPE(io) = IoTYPE_RDONLY;
12905             IoIFP(io) = fp = tmpfp;
12906             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
12907         }
12908     }
12909     Safefree(vmsspec);
12910     Safefree(rslt);
12911     return fp;
12912 }
12913
12914
12915 static char *
12916 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
12917                    int *utf8_fl);
12918
12919 void
12920 unixrealpath_fromperl(pTHX_ CV *cv)
12921 {
12922     dXSARGS;
12923     char *fspec, *rslt_spec, *rslt;
12924     STRLEN n_a;
12925
12926     if (!items || items != 1)
12927         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
12928
12929     fspec = SvPV(ST(0),n_a);
12930     if (!fspec || !*fspec) XSRETURN_UNDEF;
12931
12932     Newx(rslt_spec, VMS_MAXRSS + 1, char);
12933     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
12934
12935     ST(0) = sv_newmortal();
12936     if (rslt != NULL)
12937         sv_usepvn(ST(0),rslt,strlen(rslt));
12938     else
12939         Safefree(rslt_spec);
12940         XSRETURN(1);
12941 }
12942
12943 static char *
12944 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
12945                    int *utf8_fl);
12946
12947 void
12948 vmsrealpath_fromperl(pTHX_ CV *cv)
12949 {
12950     dXSARGS;
12951     char *fspec, *rslt_spec, *rslt;
12952     STRLEN n_a;
12953
12954     if (!items || items != 1)
12955         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
12956
12957     fspec = SvPV(ST(0),n_a);
12958     if (!fspec || !*fspec) XSRETURN_UNDEF;
12959
12960     Newx(rslt_spec, VMS_MAXRSS + 1, char);
12961     rslt = do_vms_realname(fspec, rslt_spec, NULL);
12962
12963     ST(0) = sv_newmortal();
12964     if (rslt != NULL)
12965         sv_usepvn(ST(0),rslt,strlen(rslt));
12966     else
12967         Safefree(rslt_spec);
12968         XSRETURN(1);
12969 }
12970
12971 #ifdef HAS_SYMLINK
12972 /*
12973  * A thin wrapper around decc$symlink to make sure we follow the
12974  * standard and do not create a symlink with a zero-length name.
12975  */
12976 /*{{{ int my_symlink(const char *path1, const char *path2)*/
12977 int my_symlink(const char *path1, const char *path2) {
12978   if (!path2 || !*path2) {
12979     SETERRNO(ENOENT, SS$_NOSUCHFILE);
12980     return -1;
12981   }
12982   return symlink(path1, path2);
12983 }
12984 /*}}}*/
12985
12986 #endif /* HAS_SYMLINK */
12987
12988 int do_vms_case_tolerant(void);
12989
12990 void
12991 case_tolerant_process_fromperl(pTHX_ CV *cv)
12992 {
12993   dXSARGS;
12994   ST(0) = boolSV(do_vms_case_tolerant());
12995   XSRETURN(1);
12996 }
12997
12998 void
12999 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13000                           struct interp_intern *dst)
13001 {
13002     memcpy(dst,src,sizeof(struct interp_intern));
13003 }
13004
13005 void
13006 Perl_sys_intern_clear(pTHX)
13007 {
13008 }
13009
13010 void
13011 Perl_sys_intern_init(pTHX)
13012 {
13013     unsigned int ix = RAND_MAX;
13014     double x;
13015
13016     VMSISH_HUSHED = 0;
13017
13018     /* fix me later to track running under GNV */
13019     /* this allows some limited testing */
13020     MY_POSIX_EXIT = decc_filename_unix_report;
13021
13022     x = (float)ix;
13023     MY_INV_RAND_MAX = 1./x;
13024 }
13025
13026 void
13027 init_os_extras(void)
13028 {
13029   dTHX;
13030   char* file = __FILE__;
13031   if (decc_disable_to_vms_logname_translation) {
13032     no_translate_barewords = TRUE;
13033   } else {
13034     no_translate_barewords = FALSE;
13035   }
13036
13037   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13038   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13039   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13040   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13041   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13042   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13043   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13044   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13045   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13046   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13047   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13048   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13049   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13050   newXSproto("VMS::Filespec::case_tolerant_process",
13051       case_tolerant_process_fromperl,file,"");
13052
13053   store_pipelocs(aTHX);         /* will redo any earlier attempts */
13054
13055   return;
13056 }
13057
13058 #if __CRTL_VER == 80200000
13059 /* This missed getting in to the DECC SDK for 8.2 */
13060 char *realpath(const char *file_name, char * resolved_name, ...);
13061 #endif
13062
13063 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13064 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13065  * The perl fallback routine to provide realpath() is not as efficient
13066  * on OpenVMS.
13067  */
13068
13069 /* Hack, use old stat() as fastest way of getting ino_t and device */
13070 int decc$stat(const char *name, void * statbuf);
13071
13072
13073 /* Realpath is fragile.  In 8.3 it does not work if the feature
13074  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13075  * links are implemented in RMS, not the CRTL. It also can fail if the
13076  * user does not have read/execute access to some of the directories.
13077  * So in order for Do What I Mean mode to work, if realpath() fails,
13078  * fall back to looking up the filename by the device name and FID.
13079  */
13080
13081 int vms_fid_to_name(char * outname, int outlen, const char * name)
13082 {
13083 struct statbuf_t {
13084     char           * st_dev;
13085     unsigned short st_ino[3];
13086     unsigned short padw;
13087     unsigned long  padl[30];  /* plenty of room */
13088 } statbuf;
13089 int sts;
13090 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13091 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13092
13093     sts = decc$stat(name, &statbuf);
13094     if (sts == 0) {
13095
13096         dvidsc.dsc$a_pointer=statbuf.st_dev;
13097        dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13098
13099         specdsc.dsc$a_pointer = outname;
13100         specdsc.dsc$w_length = outlen-1;
13101
13102        sts = lib$fid_to_name
13103             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13104        if ($VMS_STATUS_SUCCESS(sts)) {
13105             outname[specdsc.dsc$w_length] = 0;
13106             return 0;
13107         }
13108     }
13109     return sts;
13110 }
13111
13112
13113
13114 static char *
13115 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13116                    int *utf8_fl)
13117 {
13118     char * rslt = NULL;
13119
13120 #ifdef HAS_SYMLINK
13121     if (decc_posix_compliant_pathnames > 0 ) {
13122         /* realpath currently only works if posix compliant pathnames are
13123          * enabled.  It may start working when they are not, but in that
13124          * case we still want the fallback behavior for backwards compatibility
13125          */
13126         rslt = realpath(filespec, outbuf);
13127     }
13128 #endif
13129
13130     if (rslt == NULL) {
13131         char * vms_spec;
13132         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13133         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13134         int file_len;
13135
13136         /* Fall back to fid_to_name */
13137
13138         Newx(vms_spec, VMS_MAXRSS + 1, char);
13139
13140         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec);
13141         if (sts == 0) {
13142
13143
13144             /* Now need to trim the version off */
13145             sts = vms_split_path
13146                   (vms_spec,
13147                    &v_spec,
13148                    &v_len,
13149                    &r_spec,
13150                    &r_len,
13151                    &d_spec,
13152                    &d_len,
13153                    &n_spec,
13154                    &n_len,
13155                    &e_spec,
13156                    &e_len,
13157                    &vs_spec,
13158                    &vs_len);
13159
13160
13161                 if (sts == 0) {
13162                     int haslower = 0;
13163                     const char *cp;
13164
13165                     /* Trim off the version */
13166                     int file_len = v_len + r_len + d_len + n_len + e_len;
13167                     vms_spec[file_len] = 0;
13168
13169                     /* The result is expected to be in UNIX format */
13170                     rslt = do_tounixspec(vms_spec, outbuf, 0, utf8_fl);
13171
13172                     /* Downcase if input had any lower case letters and
13173                      * case preservation is not in effect.
13174                      */
13175                     if (!decc_efs_case_preserve) {
13176                         for (cp = filespec; *cp; cp++)
13177                             if (islower(*cp)) { haslower = 1; break; }
13178
13179                         if (haslower) __mystrtolower(rslt);
13180                     }
13181                 }
13182         }
13183
13184         Safefree(vms_spec);
13185     }
13186     return rslt;
13187 }
13188
13189 static char *
13190 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13191                    int *utf8_fl)
13192 {
13193     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13194     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13195     int file_len;
13196
13197     /* Fall back to fid_to_name */
13198
13199     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec);
13200     if (sts != 0) {
13201         return NULL;
13202     }
13203     else {
13204
13205
13206         /* Now need to trim the version off */
13207         sts = vms_split_path
13208                   (outbuf,
13209                    &v_spec,
13210                    &v_len,
13211                    &r_spec,
13212                    &r_len,
13213                    &d_spec,
13214                    &d_len,
13215                    &n_spec,
13216                    &n_len,
13217                    &e_spec,
13218                    &e_len,
13219                    &vs_spec,
13220                    &vs_len);
13221
13222
13223         if (sts == 0) {
13224             int haslower = 0;
13225             const char *cp;
13226
13227             /* Trim off the version */
13228             int file_len = v_len + r_len + d_len + n_len + e_len;
13229             outbuf[file_len] = 0;
13230
13231             /* Downcase if input had any lower case letters and
13232              * case preservation is not in effect.
13233              */
13234             if (!decc_efs_case_preserve) {
13235                 for (cp = filespec; *cp; cp++)
13236                     if (islower(*cp)) { haslower = 1; break; }
13237
13238                 if (haslower) __mystrtolower(outbuf);
13239             }
13240         }
13241     }
13242     return outbuf;
13243 }
13244
13245
13246 /*}}}*/
13247 /* External entry points */
13248 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13249 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
13250
13251 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13252 { return do_vms_realname(filespec, outbuf, utf8_fl); }
13253
13254 /* case_tolerant */
13255
13256 /*{{{int do_vms_case_tolerant(void)*/
13257 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13258  * controlled by a process setting.
13259  */
13260 int do_vms_case_tolerant(void)
13261 {
13262     return vms_process_case_tolerant;
13263 }
13264 /*}}}*/
13265 /* External entry points */
13266 #if __CRTL_VER >= 70301000 && !defined(__VAX)
13267 int Perl_vms_case_tolerant(void)
13268 { return do_vms_case_tolerant(); }
13269 #else
13270 int Perl_vms_case_tolerant(void)
13271 { return vms_process_case_tolerant; }
13272 #endif
13273
13274
13275  /* Start of DECC RTL Feature handling */
13276
13277 static int sys_trnlnm
13278    (const char * logname,
13279     char * value,
13280     int value_len)
13281 {
13282     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
13283     const unsigned long attr = LNM$M_CASE_BLIND;
13284     struct dsc$descriptor_s name_dsc;
13285     int status;
13286     unsigned short result;
13287     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
13288                                 {0, 0, 0, 0}};
13289
13290     name_dsc.dsc$w_length = strlen(logname);
13291     name_dsc.dsc$a_pointer = (char *)logname;
13292     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13293     name_dsc.dsc$b_class = DSC$K_CLASS_S;
13294
13295     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
13296
13297     if ($VMS_STATUS_SUCCESS(status)) {
13298
13299          /* Null terminate and return the string */
13300         /*--------------------------------------*/
13301         value[result] = 0;
13302     }
13303
13304     return status;
13305 }
13306
13307 static int sys_crelnm
13308    (const char * logname,
13309     const char * value)
13310 {
13311     int ret_val;
13312     const char * proc_table = "LNM$PROCESS_TABLE";
13313     struct dsc$descriptor_s proc_table_dsc;
13314     struct dsc$descriptor_s logname_dsc;
13315     struct itmlst_3 item_list[2];
13316
13317     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
13318     proc_table_dsc.dsc$w_length = strlen(proc_table);
13319     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13320     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
13321
13322     logname_dsc.dsc$a_pointer = (char *) logname;
13323     logname_dsc.dsc$w_length = strlen(logname);
13324     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13325     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
13326
13327     item_list[0].buflen = strlen(value);
13328     item_list[0].itmcode = LNM$_STRING;
13329     item_list[0].bufadr = (char *)value;
13330     item_list[0].retlen = NULL;
13331
13332     item_list[1].buflen = 0;
13333     item_list[1].itmcode = 0;
13334
13335     ret_val = sys$crelnm
13336                        (NULL,
13337                         (const struct dsc$descriptor_s *)&proc_table_dsc,
13338                         (const struct dsc$descriptor_s *)&logname_dsc,
13339                         NULL,
13340                         (const struct item_list_3 *) item_list);
13341
13342     return ret_val;
13343 }
13344
13345 /* C RTL Feature settings */
13346
13347 static int set_features
13348    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
13349     int (* cli_routine)(void),  /* Not documented */
13350     void *image_info)           /* Not documented */
13351 {
13352     int status;
13353     int s;
13354     int dflt;
13355     char* str;
13356     char val_str[10];
13357 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13358     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13359     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13360     unsigned long case_perm;
13361     unsigned long case_image;
13362 #endif
13363
13364     /* Allow an exception to bring Perl into the VMS debugger */
13365     vms_debug_on_exception = 0;
13366     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
13367     if ($VMS_STATUS_SUCCESS(status)) {
13368        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13369          vms_debug_on_exception = 1;
13370        else
13371          vms_debug_on_exception = 0;
13372     }
13373
13374     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
13375     vms_vtf7_filenames = 0;
13376     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
13377     if ($VMS_STATUS_SUCCESS(status)) {
13378        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13379          vms_vtf7_filenames = 1;
13380        else
13381          vms_vtf7_filenames = 0;
13382     }
13383
13384
13385     /* unlink all versions on unlink() or rename() */
13386     vms_unlink_all_versions = 0;
13387     status = sys_trnlnm
13388         ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13389     if ($VMS_STATUS_SUCCESS(status)) {
13390        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13391          vms_unlink_all_versions = 1;
13392        else
13393          vms_unlink_all_versions = 0;
13394     }
13395
13396     /* Dectect running under GNV Bash or other UNIX like shell */
13397 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13398     gnv_unix_shell = 0;
13399     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
13400     if ($VMS_STATUS_SUCCESS(status)) {
13401        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13402          gnv_unix_shell = 1;
13403          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
13404          set_feature_default("DECC$EFS_CHARSET", 1);
13405          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
13406          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
13407          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
13408          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
13409          vms_unlink_all_versions = 1;
13410        }
13411        else
13412          gnv_unix_shell = 0;
13413     }
13414 #endif
13415
13416     /* hacks to see if known bugs are still present for testing */
13417
13418     /* Readdir is returning filenames in VMS syntax always */
13419     decc_bug_readdir_efs1 = 1;
13420     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
13421     if ($VMS_STATUS_SUCCESS(status)) {
13422        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13423          decc_bug_readdir_efs1 = 1;
13424        else
13425          decc_bug_readdir_efs1 = 0;
13426     }
13427
13428     /* PCP mode requires creating /dev/null special device file */
13429     decc_bug_devnull = 0;
13430     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
13431     if ($VMS_STATUS_SUCCESS(status)) {
13432        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13433           decc_bug_devnull = 1;
13434        else
13435           decc_bug_devnull = 0;
13436     }
13437
13438     /* fgetname returning a VMS name in UNIX mode */
13439     decc_bug_fgetname = 1;
13440     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
13441     if ($VMS_STATUS_SUCCESS(status)) {
13442       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13443         decc_bug_fgetname = 1;
13444       else
13445         decc_bug_fgetname = 0;
13446     }
13447
13448     /* UNIX directory names with no paths are broken in a lot of places */
13449     decc_dir_barename = 1;
13450     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
13451     if ($VMS_STATUS_SUCCESS(status)) {
13452       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13453         decc_dir_barename = 1;
13454       else
13455         decc_dir_barename = 0;
13456     }
13457
13458 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13459     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
13460     if (s >= 0) {
13461         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
13462         if (decc_disable_to_vms_logname_translation < 0)
13463             decc_disable_to_vms_logname_translation = 0;
13464     }
13465
13466     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
13467     if (s >= 0) {
13468         decc_efs_case_preserve = decc$feature_get_value(s, 1);
13469         if (decc_efs_case_preserve < 0)
13470             decc_efs_case_preserve = 0;
13471     }
13472
13473     s = decc$feature_get_index("DECC$EFS_CHARSET");
13474     if (s >= 0) {
13475         decc_efs_charset = decc$feature_get_value(s, 1);
13476         if (decc_efs_charset < 0)
13477             decc_efs_charset = 0;
13478     }
13479
13480     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
13481     if (s >= 0) {
13482         decc_filename_unix_report = decc$feature_get_value(s, 1);
13483         if (decc_filename_unix_report > 0)
13484             decc_filename_unix_report = 1;
13485         else
13486             decc_filename_unix_report = 0;
13487     }
13488
13489     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
13490     if (s >= 0) {
13491         decc_filename_unix_only = decc$feature_get_value(s, 1);
13492         if (decc_filename_unix_only > 0) {
13493             decc_filename_unix_only = 1;
13494         }
13495         else {
13496             decc_filename_unix_only = 0;
13497         }
13498     }
13499
13500     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
13501     if (s >= 0) {
13502         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
13503         if (decc_filename_unix_no_version < 0)
13504             decc_filename_unix_no_version = 0;
13505     }
13506
13507     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
13508     if (s >= 0) {
13509         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
13510         if (decc_readdir_dropdotnotype < 0)
13511             decc_readdir_dropdotnotype = 0;
13512     }
13513
13514     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
13515     if ($VMS_STATUS_SUCCESS(status)) {
13516         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
13517         if (s >= 0) {
13518             dflt = decc$feature_get_value(s, 4);
13519             if (dflt > 0) {
13520                 decc_disable_posix_root = decc$feature_get_value(s, 1);
13521                 if (decc_disable_posix_root <= 0) {
13522                     decc$feature_set_value(s, 1, 1);
13523                     decc_disable_posix_root = 1;
13524                 }
13525             }
13526             else {
13527                 /* Traditionally Perl assumes this is off */
13528                 decc_disable_posix_root = 1;
13529                 decc$feature_set_value(s, 1, 1);
13530             }
13531         }
13532     }
13533
13534 #if __CRTL_VER >= 80200000
13535     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
13536     if (s >= 0) {
13537         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
13538         if (decc_posix_compliant_pathnames < 0)
13539             decc_posix_compliant_pathnames = 0;
13540         if (decc_posix_compliant_pathnames > 4)
13541             decc_posix_compliant_pathnames = 0;
13542     }
13543
13544 #endif
13545 #else
13546     status = sys_trnlnm
13547         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
13548     if ($VMS_STATUS_SUCCESS(status)) {
13549         val_str[0] = _toupper(val_str[0]);
13550         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13551            decc_disable_to_vms_logname_translation = 1;
13552         }
13553     }
13554
13555 #ifndef __VAX
13556     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
13557     if ($VMS_STATUS_SUCCESS(status)) {
13558         val_str[0] = _toupper(val_str[0]);
13559         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13560            decc_efs_case_preserve = 1;
13561         }
13562     }
13563 #endif
13564
13565     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
13566     if ($VMS_STATUS_SUCCESS(status)) {
13567         val_str[0] = _toupper(val_str[0]);
13568         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13569            decc_filename_unix_report = 1;
13570         }
13571     }
13572     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
13573     if ($VMS_STATUS_SUCCESS(status)) {
13574         val_str[0] = _toupper(val_str[0]);
13575         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13576            decc_filename_unix_only = 1;
13577            decc_filename_unix_report = 1;
13578         }
13579     }
13580     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
13581     if ($VMS_STATUS_SUCCESS(status)) {
13582         val_str[0] = _toupper(val_str[0]);
13583         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13584            decc_filename_unix_no_version = 1;
13585         }
13586     }
13587     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
13588     if ($VMS_STATUS_SUCCESS(status)) {
13589         val_str[0] = _toupper(val_str[0]);
13590         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13591            decc_readdir_dropdotnotype = 1;
13592         }
13593     }
13594 #endif
13595
13596 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13597
13598      /* Report true case tolerance */
13599     /*----------------------------*/
13600     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
13601     if (!$VMS_STATUS_SUCCESS(status))
13602         case_perm = PPROP$K_CASE_BLIND;
13603     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
13604     if (!$VMS_STATUS_SUCCESS(status))
13605         case_image = PPROP$K_CASE_BLIND;
13606     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
13607         (case_image == PPROP$K_CASE_SENSITIVE))
13608         vms_process_case_tolerant = 0;
13609
13610 #endif
13611
13612
13613     /* CRTL can be initialized past this point, but not before. */
13614 /*    DECC$CRTL_INIT(); */
13615
13616     return SS$_NORMAL;
13617 }
13618
13619 #ifdef __DECC
13620 #pragma nostandard
13621 #pragma extern_model save
13622 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
13623         const __align (LONGWORD) int spare[8] = {0};
13624
13625 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
13626 #if __DECC_VER >= 60560002
13627 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
13628 #else
13629 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
13630 #endif
13631 #endif /* __DECC */
13632
13633 const long vms_cc_features = (const long)set_features;
13634
13635 /*
13636 ** Force a reference to LIB$INITIALIZE to ensure it
13637 ** exists in the image.
13638 */
13639 int lib$initialize(void);
13640 #ifdef __DECC
13641 #pragma extern_model strict_refdef
13642 #endif
13643     int lib_init_ref = (int) lib$initialize;
13644
13645 #ifdef __DECC
13646 #pragma extern_model restore
13647 #pragma standard
13648 #endif
13649
13650 /*  End of vms.c */