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  *        "The Lay of Leithian", Canto II, lines 135-40
  22  *
  23  *     [p.162 of _The Lays of Beleriand_]
  24  */
  25
  26 #include <acedef.h>
  27 #include <acldef.h>
  28 #include <armdef.h>
  29 #include <atrdef.h>
  30 #include <chpdef.h>
  31 #include <clidef.h>
  32 #include <climsgdef.h>
  33 #include <dcdef.h>
  34 #include <descrip.h>
  35 #include <devdef.h>
  36 #include <dvidef.h>
  37 #include <fibdef.h>
  38 #include <float.h>
  39 #include <fscndef.h>
  40 #include <iodef.h>
  41 #include <jpidef.h>
  42 #include <kgbdef.h>
  43 #include <libclidef.h>
  44 #include <libdef.h>
  45 #include <lib$routines.h>
  46 #include <lnmdef.h>
  47 #include <msgdef.h>
  48 #include <ossdef.h>
  49 #if __CRTL_VER >= 70301000 && !defined(__VAX)
  50 #include <ppropdef.h>
  51 #endif
  52 #include <prvdef.h>
  53 #include <psldef.h>
  54 #include <rms.h>
  55 #include <shrdef.h>
  56 #include <ssdef.h>
  57 #include <starlet.h>
  58 #include <strdef.h>
  59 #include <str$routines.h>
  60 #include <syidef.h>
  61 #include <uaidef.h>
  62 #include <uicdef.h>
  63 #include <stsdef.h>
  64 #include <rmsdef.h>
  65 #include <smgdef.h>
  66 #if __CRTL_VER >= 70000000 /* FIXME to earliest version */
  67 #include <efndef.h>
  68 #define NO_EFN EFN$C_ENF
  69 #else
  70 #define NO_EFN 0;
  71 #endif
  72
  73 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  74 int   decc$feature_get_index(const char *name);
  75 char* decc$feature_get_name(int index);
  76 int   decc$feature_get_value(int index, int mode);
  77 int   decc$feature_set_value(int index, int mode, int value);
  78 #else
  79 #include <unixlib.h>
  80 #endif
  81
  82 #pragma member_alignment save
  83 #pragma nomember_alignment longword
  84 struct item_list_3 {
  85         unsigned short len;
  86         unsigned short code;
  87         void * bufadr;
  88         unsigned short * retadr;
  89 };
  90 #pragma member_alignment restore
  91
  92 /* More specific prototype than in starlet_c.h makes programming errors
  93    more visible.
  94  */
  95 #ifdef sys$getdviw
  96 #undef sys$getdviw
  97 int sys$getdviw
  98        (unsigned long efn,
  99         unsigned short chan,
 100         const struct dsc$descriptor_s * devnam,
 101         const struct item_list_3 * itmlst,
 102         void * iosb,
 103         void * (astadr)(unsigned long),
 104         void * astprm,
 105         void * nullarg);
 106 #endif
 107
 108 #ifdef sys$get_security
 109 #undef sys$get_security
 110 int sys$get_security
 111        (const struct dsc$descriptor_s * clsnam,
 112         const struct dsc$descriptor_s * objnam,
 113         const unsigned int *objhan,
 114         unsigned int flags,
 115         const struct item_list_3 * itmlst,
 116         unsigned int * contxt,
 117         const unsigned int * acmode);
 118 #endif
 119
 120 #ifdef sys$set_security
 121 #undef sys$set_security
 122 int sys$set_security
 123        (const struct dsc$descriptor_s * clsnam,
 124         const struct dsc$descriptor_s * objnam,
 125         const unsigned int *objhan,
 126         unsigned int flags,
 127         const struct item_list_3 * itmlst,
 128         unsigned int * contxt,
 129         const unsigned int * acmode);
 130 #endif
 131
 132 #ifdef lib$find_image_symbol
 133 #undef lib$find_image_symbol
 134 int lib$find_image_symbol
 135        (const struct dsc$descriptor_s * imgname,
 136         const struct dsc$descriptor_s * symname,
 137         void * symval,
 138         const struct dsc$descriptor_s * defspec,
 139         unsigned long flag);
 140 #endif
 141
 142 #ifdef lib$rename_file
 143 #undef lib$rename_file
 144 int lib$rename_file
 145        (const struct dsc$descriptor_s * old_file_dsc,
 146         const struct dsc$descriptor_s * new_file_dsc,
 147         const struct dsc$descriptor_s * default_file_dsc,
 148         const struct dsc$descriptor_s * related_file_dsc,
 149         const unsigned long * flags,
 150         void * (success)(const struct dsc$descriptor_s * old_dsc,
 151                          const struct dsc$descriptor_s * new_dsc,
 152                          const void *),
 153         void * (error)(const struct dsc$descriptor_s * old_dsc,
 154                        const struct dsc$descriptor_s * new_dsc,
 155                        const int * rms_sts,
 156                        const int * rms_stv,
 157                        const int * error_src,
 158                        const void * usr_arg),
 159         int (confirm)(const struct dsc$descriptor_s * old_dsc,
 160                       const struct dsc$descriptor_s * new_dsc,
 161                       const void * old_fab,
 162                       const void * usr_arg),
 163         void * user_arg,
 164         struct dsc$descriptor_s * old_result_name_dsc,
 165         struct dsc$descriptor_s * new_result_name_dsc,
 166         unsigned long * file_scan_context);
 167 #endif
 168
 169 #if __CRTL_VER >= 70300000 && !defined(__VAX)
 170
 171 static int set_feature_default(const char *name, int value)
 172 {
 173     int status;
 174     int index;
 175
 176     index = decc$feature_get_index(name);
 177
 178     status = decc$feature_set_value(index, 1, value);
 179     if (index == -1 || (status == -1)) {
 180       return -1;
 181     }
 182
 183     status = decc$feature_get_value(index, 1);
 184     if (status != value) {
 185       return -1;
 186     }
 187
 188 return 0;
 189 }
 190 #endif
 191
 192 /* Older versions of ssdef.h don't have these */
 193 #ifndef SS$_INVFILFOROP
 194 #  define SS$_INVFILFOROP 3930
 195 #endif
 196 #ifndef SS$_NOSUCHOBJECT
 197 #  define SS$_NOSUCHOBJECT 2696
 198 #endif
 199
 200 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
 201 #define PERLIO_NOT_STDIO 0
 202
 203 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
 204  * code below needs to get to the underlying CRTL routines. */
 205 #define DONT_MASK_RTL_CALLS
 206 #include "EXTERN.h"
 207 #include "perl.h"
 208 #include "XSUB.h"
 209 /* Anticipating future expansion in lexical warnings . . . */
 210 #ifndef WARN_INTERNAL
 211 #  define WARN_INTERNAL WARN_MISC
 212 #endif
 213
 214 #ifdef VMS_LONGNAME_SUPPORT
 215 #include <libfildef.h>
 216 #endif
 217
 218 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
 219 #  define RTL_USES_UTC 1
 220 #endif
 221
 222 /* Routine to create a decterm for use with the Perl debugger */
 223 /* No headers, this information was found in the Programming Concepts Manual */
 224
 225 static int (*decw_term_port)
 226    (const struct dsc$descriptor_s * display,
 227     const struct dsc$descriptor_s * setup_file,
 228     const struct dsc$descriptor_s * customization,
 229     struct dsc$descriptor_s * result_device_name,
 230     unsigned short * result_device_name_length,
 231     void * controller,
 232     void * char_buffer,
 233     void * char_change_buffer) = 0;
 234
 235 /* gcc's header files don't #define direct access macros
 236  * corresponding to VAXC's variant structs */
 237 #ifdef __GNUC__
 238 #  define uic$v_format uic$r_uic_form.uic$v_format
 239 #  define uic$v_group uic$r_uic_form.uic$v_group
 240 #  define uic$v_member uic$r_uic_form.uic$v_member
 241 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 242 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 243 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 244 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 245 #endif
 246
 247 #if defined(NEED_AN_H_ERRNO)
 248 dEXT int h_errno;
 249 #endif
 250
 251 #ifdef __DECC
 252 #pragma message disable pragma
 253 #pragma member_alignment save
 254 #pragma nomember_alignment longword
 255 #pragma message save
 256 #pragma message disable misalgndmem
 257 #endif
 258 struct itmlst_3 {
 259   unsigned short int buflen;
 260   unsigned short int itmcode;
 261   void *bufadr;
 262   unsigned short int *retlen;
 263 };
 264
 265 struct filescan_itmlst_2 {
 266     unsigned short length;
 267     unsigned short itmcode;
 268     char * component;
 269 };
 270
 271 struct vs_str_st {
 272     unsigned short length;
 273     char str[65536];
 274 };
 275
 276 #ifdef __DECC
 277 #pragma message restore
 278 #pragma member_alignment restore
 279 #endif
 280
 281 #define do_fileify_dirspec(a,b,c,d)     mp_do_fileify_dirspec(aTHX_ a,b,c,d)
 282 #define do_pathify_dirspec(a,b,c,d)     mp_do_pathify_dirspec(aTHX_ a,b,c,d)
 283 #define do_tovmsspec(a,b,c,d)           mp_do_tovmsspec(aTHX_ a,b,c,0,d)
 284 #define do_tovmspath(a,b,c,d)           mp_do_tovmspath(aTHX_ a,b,c,d)
 285 #define do_rmsexpand(a,b,c,d,e,f,g)     mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
 286 #define do_vms_realpath(a,b,c)          mp_do_vms_realpath(aTHX_ a,b,c)
 287 #define do_vms_realname(a,b,c)          mp_do_vms_realname(aTHX_ a,b,c)
 288 #define do_tounixspec(a,b,c,d)          mp_do_tounixspec(aTHX_ a,b,c,d)
 289 #define do_tounixpath(a,b,c,d)          mp_do_tounixpath(aTHX_ a,b,c,d)
 290 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 291 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 292 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 293
 294 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
 295 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
 296 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
 297 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
 298
 299 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 300 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 301
 302 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 303  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 304  * the Perl facility.
 305  */
 306 #define PERL_LNM_MAX_ITER 10
 307
 308   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 309 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 310 #define MAX_DCL_SYMBOL          (8192)
 311 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 312 #else
 313 #define MAX_DCL_SYMBOL          (1024)
 314 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 315 #endif
 316
 317 static char *__mystrtolower(char *str)
 318 {
 319   if (str) for (; *str; ++str) *str= tolower(*str);
 320   return str;
 321 }
 322
 323 static struct dsc$descriptor_s fildevdsc =
 324   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 325 static struct dsc$descriptor_s crtlenvdsc =
 326   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 327 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 328 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 329 static struct dsc$descriptor_s **env_tables = defenv;
 330 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 331
 332 /* True if we shouldn't treat barewords as logicals during directory */
 333 /* munching */
 334 static int no_translate_barewords;
 335
 336 #ifndef RTL_USES_UTC
 337 static int tz_updated = 1;
 338 #endif
 339
 340 /* DECC Features that may need to affect how Perl interprets
 341  * displays filename information
 342  */
 343 static int decc_disable_to_vms_logname_translation = 1;
 344 static int decc_disable_posix_root = 1;
 345 int decc_efs_case_preserve = 0;
 346 static int decc_efs_charset = 0;
 347 static int decc_efs_charset_index = -1;
 348 static int decc_filename_unix_no_version = 0;
 349 static int decc_filename_unix_only = 0;
 350 int decc_filename_unix_report = 0;
 351 int decc_posix_compliant_pathnames = 0;
 352 int decc_readdir_dropdotnotype = 0;
 353 static int vms_process_case_tolerant = 1;
 354 int vms_vtf7_filenames = 0;
 355 int gnv_unix_shell = 0;
 356 static int vms_unlink_all_versions = 0;
 357 static int vms_posix_exit = 0;
 358
 359 /* bug workarounds if needed */
 360 int decc_bug_devnull = 1;
 361 int decc_dir_barename = 0;
 362 int vms_bug_stat_filename = 0;
 363
 364 static int vms_debug_on_exception = 0;
 365 static int vms_debug_fileify = 0;
 366
 367 /* Simple logical name translation */
 368 static int simple_trnlnm
 369    (const char * logname,
 370     char * value,
 371     int value_len)
 372 {
 373     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
 374     const unsigned long attr = LNM$M_CASE_BLIND;
 375     struct dsc$descriptor_s name_dsc;
 376     int status;
 377     unsigned short result;
 378     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
 379                                 {0, 0, 0, 0}};
 380
 381     name_dsc.dsc$w_length = strlen(logname);
 382     name_dsc.dsc$a_pointer = (char *)logname;
 383     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
 384     name_dsc.dsc$b_class = DSC$K_CLASS_S;
 385
 386     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
 387
 388     if ($VMS_STATUS_SUCCESS(status)) {
 389
 390          /* Null terminate and return the string */
 391         /*--------------------------------------*/
 392         value[result] = 0;
 393         return result;
 394     }
 395
 396     return 0;
 397 }
 398
 399
 400 /* Is this a UNIX file specification?
 401  *   No longer a simple check with EFS file specs
 402  *   For now, not a full check, but need to
 403  *   handle POSIX ^UP^ specifications
 404  *   Fixing to handle ^/ cases would require
 405  *   changes to many other conversion routines.
 406  */
 407
 408 static int is_unix_filespec(const char *path)
 409 {
 410 int ret_val;
 411 const char * pch1;
 412
 413     ret_val = 0;
 414     if (strncmp(path,"\"^UP^",5) != 0) {
 415         pch1 = strchr(path, '/');
 416         if (pch1 != NULL)
 417             ret_val = 1;
 418         else {
 419
 420             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 421             if (decc_filename_unix_report || decc_filename_unix_only) {
 422             if (strcmp(path,".") == 0)
 423                 ret_val = 1;
 424             }
 425         }
 426     }
 427     return ret_val;
 428 }
 429
 430 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 431  */
 432
 433 static void ucs2_to_vtf7
 434    (char *outspec,
 435     unsigned long ucs2_char,
 436     int * output_cnt)
 437 {
 438 unsigned char * ucs_ptr;
 439 int hex;
 440
 441     ucs_ptr = (unsigned char *)&ucs2_char;
 442
 443     outspec[0] = '^';
 444     outspec[1] = 'U';
 445     hex = (ucs_ptr[1] >> 4) & 0xf;
 446     if (hex < 0xA)
 447         outspec[2] = hex + '0';
 448     else
 449         outspec[2] = (hex - 9) + 'A';
 450     hex = ucs_ptr[1] & 0xF;
 451     if (hex < 0xA)
 452         outspec[3] = hex + '0';
 453     else {
 454         outspec[3] = (hex - 9) + 'A';
 455     }
 456     hex = (ucs_ptr[0] >> 4) & 0xf;
 457     if (hex < 0xA)
 458         outspec[4] = hex + '0';
 459     else
 460         outspec[4] = (hex - 9) + 'A';
 461     hex = ucs_ptr[1] & 0xF;
 462     if (hex < 0xA)
 463         outspec[5] = hex + '0';
 464     else {
 465         outspec[5] = (hex - 9) + 'A';
 466     }
 467     *output_cnt = 6;
 468 }
 469
 470
 471 /* This handles the conversion of a UNIX extended character set to a ^
 472  * escaped VMS character.
 473  * in a UNIX file specification.
 474  *
 475  * The output count variable contains the number of characters added
 476  * to the output string.
 477  *
 478  * The return value is the number of characters read from the input string
 479  */
 480 static int copy_expand_unix_filename_escape
 481   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 482 {
 483 int count;
 484 int scnt;
 485 int utf8_flag;
 486
 487     utf8_flag = 0;
 488     if (utf8_fl)
 489       utf8_flag = *utf8_fl;
 490
 491     count = 0;
 492     *output_cnt = 0;
 493     if (*inspec >= 0x80) {
 494         if (utf8_fl && vms_vtf7_filenames) {
 495         unsigned long ucs_char;
 496
 497             ucs_char = 0;
 498
 499             if ((*inspec & 0xE0) == 0xC0) {
 500                 /* 2 byte Unicode */
 501                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 502                 if (ucs_char >= 0x80) {
 503                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 504                     return 2;
 505                 }
 506             } else if ((*inspec & 0xF0) == 0xE0) {
 507                 /* 3 byte Unicode */
 508                 ucs_char = ((inspec[0] & 0xF) << 12) +
 509                    ((inspec[1] & 0x3f) << 6) +
 510                    (inspec[2] & 0x3f);
 511                 if (ucs_char >= 0x800) {
 512                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 513                     return 3;
 514                 }
 515
 516 #if 0 /* I do not see longer sequences supported by OpenVMS */
 517       /* Maybe some one can fix this later */
 518             } else if ((*inspec & 0xF8) == 0xF0) {
 519                 /* 4 byte Unicode */
 520                 /* UCS-4 to UCS-2 */
 521             } else if ((*inspec & 0xFC) == 0xF8) {
 522                 /* 5 byte Unicode */
 523                 /* UCS-4 to UCS-2 */
 524             } else if ((*inspec & 0xFE) == 0xFC) {
 525                 /* 6 byte Unicode */
 526                 /* UCS-4 to UCS-2 */
 527 #endif
 528             }
 529         }
 530
 531         /* High bit set, but not a Unicode character! */
 532
 533         /* Non printing DECMCS or ISO Latin-1 character? */
 534         if (*inspec <= 0x9F) {
 535         int hex;
 536             outspec[0] = '^';
 537             outspec++;
 538             hex = (*inspec >> 4) & 0xF;
 539             if (hex < 0xA)
 540                 outspec[1] = hex + '0';
 541             else {
 542                 outspec[1] = (hex - 9) + 'A';
 543             }
 544             hex = *inspec & 0xF;
 545             if (hex < 0xA)
 546                 outspec[2] = hex + '0';
 547             else {
 548                 outspec[2] = (hex - 9) + 'A';
 549             }
 550             *output_cnt = 3;
 551             return 1;
 552         } else if (*inspec == 0xA0) {
 553             outspec[0] = '^';
 554             outspec[1] = 'A';
 555             outspec[2] = '0';
 556             *output_cnt = 3;
 557             return 1;
 558         } else if (*inspec == 0xFF) {
 559             outspec[0] = '^';
 560             outspec[1] = 'F';
 561             outspec[2] = 'F';
 562             *output_cnt = 3;
 563             return 1;
 564         }
 565         *outspec = *inspec;
 566         *output_cnt = 1;
 567         return 1;
 568     }
 569
 570     /* Is this a macro that needs to be passed through?
 571      * Macros start with $( and an alpha character, followed
 572      * by a string of alpha numeric characters ending with a )
 573      * If this does not match, then encode it as ODS-5.
 574      */
 575     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 576     int tcnt;
 577
 578         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 579             tcnt = 3;
 580             outspec[0] = inspec[0];
 581             outspec[1] = inspec[1];
 582             outspec[2] = inspec[2];
 583
 584             while(isalnum(inspec[tcnt]) ||
 585                   (inspec[2] == '.') || (inspec[2] == '_')) {
 586                 outspec[tcnt] = inspec[tcnt];
 587                 tcnt++;
 588             }
 589             if (inspec[tcnt] == ')') {
 590                 outspec[tcnt] = inspec[tcnt];
 591                 tcnt++;
 592                 *output_cnt = tcnt;
 593                 return tcnt;
 594             }
 595         }
 596     }
 597
 598     switch (*inspec) {
 599     case 0x7f:
 600         outspec[0] = '^';
 601         outspec[1] = '7';
 602         outspec[2] = 'F';
 603         *output_cnt = 3;
 604         return 1;
 605         break;
 606     case '?':
 607         if (decc_efs_charset == 0)
 608           outspec[0] = '%';
 609         else
 610           outspec[0] = '?';
 611         *output_cnt = 1;
 612         return 1;
 613         break;
 614     case '.':
 615     case '~':
 616     case '!':
 617     case '#':
 618     case '&':
 619     case '\'':
 620     case '`':
 621     case '(':
 622     case ')':
 623     case '+':
 624     case '@':
 625     case '{':
 626     case '}':
 627     case ',':
 628     case ';':
 629     case '[':
 630     case ']':
 631     case '%':
 632     case '^':
 633     case '\\':
 634         /* Don't escape again if following character is
 635          * already something we escape.
 636          */
 637         if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
 638             *outspec = *inspec;
 639             *output_cnt = 1;
 640             return 1;
 641             break;
 642         }
 643         /* But otherwise fall through and escape it. */
 644     case '=':
 645         /* Assume that this is to be escaped */
 646         outspec[0] = '^';
 647         outspec[1] = *inspec;
 648         *output_cnt = 2;
 649         return 1;
 650         break;
 651     case ' ': /* space */
 652         /* Assume that this is to be escaped */
 653         outspec[0] = '^';
 654         outspec[1] = '_';
 655         *output_cnt = 2;
 656         return 1;
 657         break;
 658     default:
 659         *outspec = *inspec;
 660         *output_cnt = 1;
 661         return 1;
 662         break;
 663     }
 664 }
 665
 666
 667 /* This handles the expansion of a '^' prefix to the proper character
 668  * in a UNIX file specification.
 669  *
 670  * The output count variable contains the number of characters added
 671  * to the output string.
 672  *
 673  * The return value is the number of characters read from the input
 674  * string
 675  */
 676 static int copy_expand_vms_filename_escape
 677   (char *outspec, const char *inspec, int *output_cnt)
 678 {
 679 int count;
 680 int scnt;
 681
 682     count = 0;
 683     *output_cnt = 0;
 684     if (*inspec == '^') {
 685         inspec++;
 686         switch (*inspec) {
 687         /* Spaces and non-trailing dots should just be passed through,
 688          * but eat the escape character.
 689          */
 690         case '.':
 691             *outspec = *inspec;
 692             count += 2;
 693             (*output_cnt)++;
 694             break;
 695         case '_': /* space */
 696             *outspec = ' ';
 697             count += 2;
 698             (*output_cnt)++;
 699             break;
 700         case '^':
 701             /* Hmm.  Better leave the escape escaped. */
 702             outspec[0] = '^';
 703             outspec[1] = '^';
 704             count += 2;
 705             (*output_cnt) += 2;
 706             break;
 707         case 'U': /* Unicode - FIX-ME this is wrong. */
 708             inspec++;
 709             count++;
 710             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 711             if (scnt == 4) {
 712                 unsigned int c1, c2;
 713                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 714                 outspec[0] == c1 & 0xff;
 715                 outspec[1] == c2 & 0xff;
 716                 if (scnt > 1) {
 717                     (*output_cnt) += 2;
 718                     count += 4;
 719                 }
 720             }
 721             else {
 722                 /* Error - do best we can to continue */
 723                 *outspec = 'U';
 724                 outspec++;
 725                 (*output_cnt++);
 726                 *outspec = *inspec;
 727                 count++;
 728                 (*output_cnt++);
 729             }
 730             break;
 731         default:
 732             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 733             if (scnt == 2) {
 734                 /* Hex encoded */
 735                 unsigned int c1;
 736                 scnt = sscanf(inspec, "%2x", &c1);
 737                 outspec[0] = c1 & 0xff;
 738                 if (scnt > 0) {
 739                     (*output_cnt++);
 740                     count += 2;
 741                 }
 742             }
 743             else {
 744                 *outspec = *inspec;
 745                 count++;
 746                 (*output_cnt++);
 747             }
 748         }
 749     }
 750     else {
 751         *outspec = *inspec;
 752         count++;
 753         (*output_cnt)++;
 754     }
 755     return count;
 756 }
 757
 758 #ifdef sys$filescan
 759 #undef sys$filescan
 760 int sys$filescan
 761    (const struct dsc$descriptor_s * srcstr,
 762     struct filescan_itmlst_2 * valuelist,
 763     unsigned long * fldflags,
 764     struct dsc$descriptor_s *auxout,
 765     unsigned short * retlen);
 766 #endif
 767
 768 /* vms_split_path - Verify that the input file specification is a
 769  * VMS format file specification, and provide pointers to the components of
 770  * it.  With EFS format filenames, this is virtually the only way to
 771  * parse a VMS path specification into components.
 772  *
 773  * If the sum of the components do not add up to the length of the
 774  * string, then the passed file specification is probably a UNIX style
 775  * path.
 776  */
 777 static int vms_split_path
 778    (const char * path,
 779     char * * volume,
 780     int * vol_len,
 781     char * * root,
 782     int * root_len,
 783     char * * dir,
 784     int * dir_len,
 785     char * * name,
 786     int * name_len,
 787     char * * ext,
 788     int * ext_len,
 789     char * * version,
 790     int * ver_len)
 791 {
 792 struct dsc$descriptor path_desc;
 793 int status;
 794 unsigned long flags;
 795 int ret_stat;
 796 struct filescan_itmlst_2 item_list[9];
 797 const int filespec = 0;
 798 const int nodespec = 1;
 799 const int devspec = 2;
 800 const int rootspec = 3;
 801 const int dirspec = 4;
 802 const int namespec = 5;
 803 const int typespec = 6;
 804 const int verspec = 7;
 805
 806     /* Assume the worst for an easy exit */
 807     ret_stat = -1;
 808     *volume = NULL;
 809     *vol_len = 0;
 810     *root = NULL;
 811     *root_len = 0;
 812     *dir = NULL;
 813     *dir_len;
 814     *name = NULL;
 815     *name_len = 0;
 816     *ext = NULL;
 817     *ext_len = 0;
 818     *version = NULL;
 819     *ver_len = 0;
 820
 821     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 822     path_desc.dsc$w_length = strlen(path);
 823     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 824     path_desc.dsc$b_class = DSC$K_CLASS_S;
 825
 826     /* Get the total length, if it is shorter than the string passed
 827      * then this was probably not a VMS formatted file specification
 828      */
 829     item_list[filespec].itmcode = FSCN$_FILESPEC;
 830     item_list[filespec].length = 0;
 831     item_list[filespec].component = NULL;
 832
 833     /* If the node is present, then it gets considered as part of the
 834      * volume name to hopefully make things simple.
 835      */
 836     item_list[nodespec].itmcode = FSCN$_NODE;
 837     item_list[nodespec].length = 0;
 838     item_list[nodespec].component = NULL;
 839
 840     item_list[devspec].itmcode = FSCN$_DEVICE;
 841     item_list[devspec].length = 0;
 842     item_list[devspec].component = NULL;
 843
 844     /* root is a special case,  adding it to either the directory or
 845      * the device components will probalby complicate things for the
 846      * callers of this routine, so leave it separate.
 847      */
 848     item_list[rootspec].itmcode = FSCN$_ROOT;
 849     item_list[rootspec].length = 0;
 850     item_list[rootspec].component = NULL;
 851
 852     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 853     item_list[dirspec].length = 0;
 854     item_list[dirspec].component = NULL;
 855
 856     item_list[namespec].itmcode = FSCN$_NAME;
 857     item_list[namespec].length = 0;
 858     item_list[namespec].component = NULL;
 859
 860     item_list[typespec].itmcode = FSCN$_TYPE;
 861     item_list[typespec].length = 0;
 862     item_list[typespec].component = NULL;
 863
 864     item_list[verspec].itmcode = FSCN$_VERSION;
 865     item_list[verspec].length = 0;
 866     item_list[verspec].component = NULL;
 867
 868     item_list[8].itmcode = 0;
 869     item_list[8].length = 0;
 870     item_list[8].component = NULL;
 871
 872     status = sys$filescan
 873        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 874         &flags, NULL, NULL);
 875     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 876
 877     /* If we parsed it successfully these two lengths should be the same */
 878     if (path_desc.dsc$w_length != item_list[filespec].length)
 879         return ret_stat;
 880
 881     /* If we got here, then it is a VMS file specification */
 882     ret_stat = 0;
 883
 884     /* set the volume name */
 885     if (item_list[nodespec].length > 0) {
 886         *volume = item_list[nodespec].component;
 887         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 888     }
 889     else {
 890         *volume = item_list[devspec].component;
 891         *vol_len = item_list[devspec].length;
 892     }
 893
 894     *root = item_list[rootspec].component;
 895     *root_len = item_list[rootspec].length;
 896
 897     *dir = item_list[dirspec].component;
 898     *dir_len = item_list[dirspec].length;
 899
 900     /* Now fun with versions and EFS file specifications
 901      * The parser can not tell the difference when a "." is a version
 902      * delimiter or a part of the file specification.
 903      */
 904     if ((decc_efs_charset) &&
 905         (item_list[verspec].length > 0) &&
 906         (item_list[verspec].component[0] == '.')) {
 907         *name = item_list[namespec].component;
 908         *name_len = item_list[namespec].length + item_list[typespec].length;
 909         *ext = item_list[verspec].component;
 910         *ext_len = item_list[verspec].length;
 911         *version = NULL;
 912         *ver_len = 0;
 913     }
 914     else {
 915         *name = item_list[namespec].component;
 916         *name_len = item_list[namespec].length;
 917         *ext = item_list[typespec].component;
 918         *ext_len = item_list[typespec].length;
 919         *version = item_list[verspec].component;
 920         *ver_len = item_list[verspec].length;
 921     }
 922     return ret_stat;
 923 }
 924
 925
 926 /* my_maxidx
 927  * Routine to retrieve the maximum equivalence index for an input
 928  * logical name.  Some calls to this routine have no knowledge if
 929  * the variable is a logical or not.  So on error we return a max
 930  * index of zero.
 931  */
 932 /*{{{int my_maxidx(const char *lnm) */
 933 static int
 934 my_maxidx(const char *lnm)
 935 {
 936     int status;
 937     int midx;
 938     int attr = LNM$M_CASE_BLIND;
 939     struct dsc$descriptor lnmdsc;
 940     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 941                                 {0, 0, 0, 0}};
 942
 943     lnmdsc.dsc$w_length = strlen(lnm);
 944     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 945     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 946     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 947
 948     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 949     if ((status & 1) == 0)
 950        midx = 0;
 951
 952     return (midx);
 953 }
 954 /*}}}*/
 955
 956 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 957 int
 958 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 959   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 960 {
 961     const char *cp1;
 962     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 963     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 964     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 965     int midx;
 966     unsigned char acmode;
 967     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 968                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 969     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 970                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 971                                  {0, 0, 0, 0}};
 972     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 973 #if defined(PERL_IMPLICIT_CONTEXT)
 974     pTHX = NULL;
 975     if (PL_curinterp) {
 976       aTHX = PERL_GET_INTERP;
 977     } else {
 978       aTHX = NULL;
 979     }
 980 #endif
 981
 982     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 983       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 984     }
 985     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 986       *cp2 = _toupper(*cp1);
 987       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 988         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 989         return 0;
 990       }
 991     }
 992     lnmdsc.dsc$w_length = cp1 - lnm;
 993     lnmdsc.dsc$a_pointer = uplnm;
 994     uplnm[lnmdsc.dsc$w_length] = '\0';
 995     secure = flags & PERL__TRNENV_SECURE;
 996     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 997     if (!tabvec || !*tabvec) tabvec = env_tables;
 998
 999     for (curtab = 0; tabvec[curtab]; curtab++) {
1000       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1001         if (!ivenv && !secure) {
1002           char *eq, *end;
1003           int i;
1004           if (!environ) {
1005             ivenv = 1;
1006 #if defined(PERL_IMPLICIT_CONTEXT)
1007             if (aTHX == NULL) {
1008                 fprintf(stderr,
1009                     "%%PERL-W-VMS_INIT Can't read CRTL environ\n");
1010             } else
1011 #endif
1012                 Perl_warn(aTHX_ "Can't read CRTL environ\n");
1013             continue;
1014           }
1015           retsts = SS$_NOLOGNAM;
1016           for (i = 0; environ[i]; i++) {
1017             if ((eq = strchr(environ[i],'=')) &&
1018                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
1019                 !strncmp(environ[i],uplnm,eq - environ[i])) {
1020               eq++;
1021               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
1022               if (!eqvlen) continue;
1023               retsts = SS$_NORMAL;
1024               break;
1025             }
1026           }
1027           if (retsts != SS$_NOLOGNAM) break;
1028         }
1029       }
1030       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1031                !str$case_blind_compare(&tmpdsc,&clisym)) {
1032         if (!ivsym && !secure) {
1033           unsigned short int deflen = LNM$C_NAMLENGTH;
1034           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1035           /* dynamic dsc to accomodate possible long value */
1036           _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
1037           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
1038           if (retsts & 1) {
1039             if (eqvlen > MAX_DCL_SYMBOL) {
1040               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
1041               eqvlen = MAX_DCL_SYMBOL;
1042               /* Special hack--we might be called before the interpreter's */
1043               /* fully initialized, in which case either thr or PL_curcop */
1044               /* might be bogus. We have to check, since ckWARN needs them */
1045               /* both to be valid if running threaded */
1046 #if defined(PERL_IMPLICIT_CONTEXT)
1047               if (aTHX == NULL) {
1048                   fprintf(stderr,
1049                      "%Perl-VMS-Init, Value of CLI symbol \"%s\" too long",lnm);
1050               } else
1051 #endif
1052                 if (ckWARN(WARN_MISC)) {
1053                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
1054                 }
1055             }
1056             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
1057           }
1058           _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
1059           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1060           if (retsts == LIB$_NOSUCHSYM) continue;
1061           break;
1062         }
1063       }
1064       else if (!ivlnm) {
1065         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
1066           midx = my_maxidx(lnm);
1067           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1068             lnmlst[1].bufadr = cp2;
1069             eqvlen = 0;
1070             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1071             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1072             if (retsts == SS$_NOLOGNAM) break;
1073             /* PPFs have a prefix */
1074             if (
1075 #if INTSIZE == 4
1076                  *((int *)uplnm) == *((int *)"SYS$")                    &&
1077 #endif
1078                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
1079                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
1080                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
1081                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
1082                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
1083               memmove(eqv,eqv+4,eqvlen-4);
1084               eqvlen -= 4;
1085             }
1086             cp2 += eqvlen;
1087             *cp2 = '\0';
1088           }
1089           if ((retsts == SS$_IVLOGNAM) ||
1090               (retsts == SS$_NOLOGNAM)) { continue; }
1091         }
1092         else {
1093           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1094           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1095           if (retsts == SS$_NOLOGNAM) continue;
1096           eqv[eqvlen] = '\0';
1097         }
1098         eqvlen = strlen(eqv);
1099         break;
1100       }
1101     }
1102     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1103     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1104              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
1105              retsts == SS$_NOLOGNAM) {
1106       set_errno(EINVAL);  set_vaxc_errno(retsts);
1107     }
1108     else _ckvmssts_noperl(retsts);
1109     return 0;
1110 }  /* end of vmstrnenv */
1111 /*}}}*/
1112
1113 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1114 /* Define as a function so we can access statics. */
1115 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1116 {
1117     int flags = 0;
1118
1119 #if defined(PERL_IMPLICIT_CONTEXT)
1120     if (aTHX != NULL)
1121 #endif
1122 #ifdef SECURE_INTERNAL_GETENV
1123         flags = (PL_curinterp ? PL_tainting : will_taint) ?
1124                  PERL__TRNENV_SECURE : 0;
1125 #endif
1126
1127     return vmstrnenv(lnm, eqv, idx, fildev, flags);
1128 }
1129 /*}}}*/
1130
1131 /* my_getenv
1132  * Note: Uses Perl temp to store result so char * can be returned to
1133  * caller; this pointer will be invalidated at next Perl statement
1134  * transition.
1135  * We define this as a function rather than a macro in terms of my_getenv_len()
1136  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1137  * allocate SVs).
1138  */
1139 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1140 char *
1141 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1142 {
1143     const char *cp1;
1144     static char *__my_getenv_eqv = NULL;
1145     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1146     unsigned long int idx = 0;
1147     int trnsuccess, success, secure, saverr, savvmserr;
1148     int midx, flags;
1149     SV *tmpsv;
1150
1151     midx = my_maxidx(lnm) + 1;
1152
1153     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1154       /* Set up a temporary buffer for the return value; Perl will
1155        * clean it up at the next statement transition */
1156       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1157       if (!tmpsv) return NULL;
1158       eqv = SvPVX(tmpsv);
1159     }
1160     else {
1161       /* Assume no interpreter ==> single thread */
1162       if (__my_getenv_eqv != NULL) {
1163         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1164       }
1165       else {
1166         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1167       }
1168       eqv = __my_getenv_eqv;
1169     }
1170
1171     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1172     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1173       int len;
1174       getcwd(eqv,LNM$C_NAMLENGTH);
1175
1176       len = strlen(eqv);
1177
1178       /* Get rid of "000000/ in rooted filespecs */
1179       if (len > 7) {
1180         char * zeros;
1181         zeros = strstr(eqv, "/000000/");
1182         if (zeros != NULL) {
1183           int mlen;
1184           mlen = len - (zeros - eqv) - 7;
1185           memmove(zeros, &zeros[7], mlen);
1186           len = len - 7;
1187           eqv[len] = '\0';
1188         }
1189       }
1190       return eqv;
1191     }
1192     else {
1193       /* Impose security constraints only if tainting */
1194       if (sys) {
1195         /* Impose security constraints only if tainting */
1196         secure = PL_curinterp ? PL_tainting : will_taint;
1197         saverr = errno;  savvmserr = vaxc$errno;
1198       }
1199       else {
1200         secure = 0;
1201       }
1202
1203       flags =
1204 #ifdef SECURE_INTERNAL_GETENV
1205               secure ? PERL__TRNENV_SECURE : 0
1206 #else
1207               0
1208 #endif
1209       ;
1210
1211       /* For the getenv interface we combine all the equivalence names
1212        * of a search list logical into one value to acquire a maximum
1213        * value length of 255*128 (assuming %ENV is using logicals).
1214        */
1215       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1216
1217       /* If the name contains a semicolon-delimited index, parse it
1218        * off and make sure we only retrieve the equivalence name for
1219        * that index.  */
1220       if ((cp2 = strchr(lnm,';')) != NULL) {
1221         strcpy(uplnm,lnm);
1222         uplnm[cp2-lnm] = '\0';
1223         idx = strtoul(cp2+1,NULL,0);
1224         lnm = uplnm;
1225         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1226       }
1227
1228       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1229
1230       /* Discard NOLOGNAM on internal calls since we're often looking
1231        * for an optional name, and this "error" often shows up as the
1232        * (bogus) exit status for a die() call later on.  */
1233       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1234       return success ? eqv : NULL;
1235     }
1236
1237 }  /* end of my_getenv() */
1238 /*}}}*/
1239
1240
1241 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1242 char *
1243 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1244 {
1245     const char *cp1;
1246     char *buf, *cp2;
1247     unsigned long idx = 0;
1248     int midx, flags;
1249     static char *__my_getenv_len_eqv = NULL;
1250     int secure, saverr, savvmserr;
1251     SV *tmpsv;
1252
1253     midx = my_maxidx(lnm) + 1;
1254
1255     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1256       /* Set up a temporary buffer for the return value; Perl will
1257        * clean it up at the next statement transition */
1258       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1259       if (!tmpsv) return NULL;
1260       buf = SvPVX(tmpsv);
1261     }
1262     else {
1263       /* Assume no interpreter ==> single thread */
1264       if (__my_getenv_len_eqv != NULL) {
1265         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1266       }
1267       else {
1268         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1269       }
1270       buf = __my_getenv_len_eqv;
1271     }
1272
1273     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1274     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1275     char * zeros;
1276
1277       getcwd(buf,LNM$C_NAMLENGTH);
1278       *len = strlen(buf);
1279
1280       /* Get rid of "000000/ in rooted filespecs */
1281       if (*len > 7) {
1282       zeros = strstr(buf, "/000000/");
1283       if (zeros != NULL) {
1284         int mlen;
1285         mlen = *len - (zeros - buf) - 7;
1286         memmove(zeros, &zeros[7], mlen);
1287         *len = *len - 7;
1288         buf[*len] = '\0';
1289         }
1290       }
1291       return buf;
1292     }
1293     else {
1294       if (sys) {
1295         /* Impose security constraints only if tainting */
1296         secure = PL_curinterp ? PL_tainting : will_taint;
1297         saverr = errno;  savvmserr = vaxc$errno;
1298       }
1299       else {
1300         secure = 0;
1301       }
1302
1303       flags =
1304 #ifdef SECURE_INTERNAL_GETENV
1305               secure ? PERL__TRNENV_SECURE : 0
1306 #else
1307               0
1308 #endif
1309       ;
1310
1311       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1312
1313       if ((cp2 = strchr(lnm,';')) != NULL) {
1314         strcpy(buf,lnm);
1315         buf[cp2-lnm] = '\0';
1316         idx = strtoul(cp2+1,NULL,0);
1317         lnm = buf;
1318         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1319       }
1320
1321       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1322
1323       /* Get rid of "000000/ in rooted filespecs */
1324       if (*len > 7) {
1325       char * zeros;
1326         zeros = strstr(buf, "/000000/");
1327         if (zeros != NULL) {
1328           int mlen;
1329           mlen = *len - (zeros - buf) - 7;
1330           memmove(zeros, &zeros[7], mlen);
1331           *len = *len - 7;
1332           buf[*len] = '\0';
1333         }
1334       }
1335
1336       /* Discard NOLOGNAM on internal calls since we're often looking
1337        * for an optional name, and this "error" often shows up as the
1338        * (bogus) exit status for a die() call later on.  */
1339       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1340       return *len ? buf : NULL;
1341     }
1342
1343 }  /* end of my_getenv_len() */
1344 /*}}}*/
1345
1346 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
1347
1348 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1349
1350 /*{{{ void prime_env_iter() */
1351 void
1352 prime_env_iter(void)
1353 /* Fill the %ENV associative array with all logical names we can
1354  * find, in preparation for iterating over it.
1355  */
1356 {
1357   static int primed = 0;
1358   HV *seenhv = NULL, *envhv;
1359   SV *sv = NULL;
1360   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1361   unsigned short int chan;
1362 #ifndef CLI$M_TRUSTED
1363 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1364 #endif
1365   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1366   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1367   long int i;
1368   bool have_sym = FALSE, have_lnm = FALSE;
1369   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1370   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1371   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1372   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1373   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1374 #if defined(PERL_IMPLICIT_CONTEXT)
1375   pTHX;
1376 #endif
1377 #if defined(USE_ITHREADS)
1378   static perl_mutex primenv_mutex;
1379   MUTEX_INIT(&primenv_mutex);
1380 #endif
1381
1382 #if defined(PERL_IMPLICIT_CONTEXT)
1383     /* We jump through these hoops because we can be called at */
1384     /* platform-specific initialization time, which is before anything is */
1385     /* set up--we can't even do a plain dTHX since that relies on the */
1386     /* interpreter structure to be initialized */
1387     if (PL_curinterp) {
1388       aTHX = PERL_GET_INTERP;
1389     } else {
1390       /* we never get here because the NULL pointer will cause the */
1391       /* several of the routines called by this routine to access violate */
1392
1393       /* This routine is only called by hv.c/hv_iterinit which has a */
1394       /* context, so the real fix may be to pass it through instead of */
1395       /* the hoops above */
1396       aTHX = NULL;
1397     }
1398 #endif
1399
1400   if (primed || !PL_envgv) return;
1401   MUTEX_LOCK(&primenv_mutex);
1402   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1403   envhv = GvHVn(PL_envgv);
1404   /* Perform a dummy fetch as an lval to insure that the hash table is
1405    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1406   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1407
1408   for (i = 0; env_tables[i]; i++) {
1409      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1410          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1411      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1412   }
1413   if (have_sym || have_lnm) {
1414     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1415     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1416     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1417     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1418   }
1419
1420   for (i--; i >= 0; i--) {
1421     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1422       char *start;
1423       int j;
1424       for (j = 0; environ[j]; j++) {
1425         if (!(start = strchr(environ[j],'='))) {
1426           if (ckWARN(WARN_INTERNAL))
1427             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1428         }
1429         else {
1430           start++;
1431           sv = newSVpv(start,0);
1432           SvTAINTED_on(sv);
1433           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1434         }
1435       }
1436       continue;
1437     }
1438     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1439              !str$case_blind_compare(&tmpdsc,&clisym)) {
1440       strcpy(cmd,"Show Symbol/Global *");
1441       cmddsc.dsc$w_length = 20;
1442       if (env_tables[i]->dsc$w_length == 12 &&
1443           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1444           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1445       flags = defflags | CLI$M_NOLOGNAM;
1446     }
1447     else {
1448       strcpy(cmd,"Show Logical *");
1449       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1450         strcat(cmd," /Table=");
1451         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1452         cmddsc.dsc$w_length = strlen(cmd);
1453       }
1454       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1455       flags = defflags | CLI$M_NOCLISYM;
1456     }
1457
1458     /* Create a new subprocess to execute each command, to exclude the
1459      * remote possibility that someone could subvert a mbx or file used
1460      * to write multiple commands to a single subprocess.
1461      */
1462     do {
1463       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1464                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1465       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1466       defflags &= ~CLI$M_TRUSTED;
1467     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1468     _ckvmssts(retsts);
1469     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1470     if (seenhv) SvREFCNT_dec(seenhv);
1471     seenhv = newHV();
1472     while (1) {
1473       char *cp1, *cp2, *key;
1474       unsigned long int sts, iosb[2], retlen, keylen;
1475       register U32 hash;
1476
1477       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1478       if (sts & 1) sts = iosb[0] & 0xffff;
1479       if (sts == SS$_ENDOFFILE) {
1480         int wakect = 0;
1481         while (substs == 0) { sys$hiber(); wakect++;}
1482         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1483         _ckvmssts(substs);
1484         break;
1485       }
1486       _ckvmssts(sts);
1487       retlen = iosb[0] >> 16;
1488       if (!retlen) continue;  /* blank line */
1489       buf[retlen] = '\0';
1490       if (iosb[1] != subpid) {
1491         if (iosb[1]) {
1492           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1493         }
1494         continue;
1495       }
1496       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1497         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1498
1499       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1500       if (*cp1 == '(' || /* Logical name table name */
1501           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1502       if (*cp1 == '"') cp1++;
1503       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1504       key = cp1;  keylen = cp2 - cp1;
1505       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1506       while (*cp2 && *cp2 != '=') cp2++;
1507       while (*cp2 && *cp2 == '=') cp2++;
1508       while (*cp2 && *cp2 == ' ') cp2++;
1509       if (*cp2 == '"') {  /* String translation; may embed "" */
1510         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1511         cp2++;  cp1--; /* Skip "" surrounding translation */
1512       }
1513       else {  /* Numeric translation */
1514         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1515         cp1--;  /* stop on last non-space char */
1516       }
1517       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1518         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1519         continue;
1520       }
1521       PERL_HASH(hash,key,keylen);
1522
1523       if (cp1 == cp2 && *cp2 == '.') {
1524         /* A single dot usually means an unprintable character, such as a null
1525          * to indicate a zero-length value.  Get the actual value to make sure.
1526          */
1527         char lnm[LNM$C_NAMLENGTH+1];
1528         char eqv[MAX_DCL_SYMBOL+1];
1529         int trnlen;
1530         strncpy(lnm, key, keylen);
1531         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1532         sv = newSVpvn(eqv, strlen(eqv));
1533       }
1534       else {
1535         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1536       }
1537
1538       SvTAINTED_on(sv);
1539       hv_store(envhv,key,keylen,sv,hash);
1540       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1541     }
1542     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1543       /* get the PPFs for this process, not the subprocess */
1544       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1545       char eqv[LNM$C_NAMLENGTH+1];
1546       int trnlen, i;
1547       for (i = 0; ppfs[i]; i++) {
1548         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1549         sv = newSVpv(eqv,trnlen);
1550         SvTAINTED_on(sv);
1551         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1552       }
1553     }
1554   }
1555   primed = 1;
1556   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1557   if (buf) Safefree(buf);
1558   if (seenhv) SvREFCNT_dec(seenhv);
1559   MUTEX_UNLOCK(&primenv_mutex);
1560   return;
1561
1562 }  /* end of prime_env_iter */
1563 /*}}}*/
1564
1565
1566 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1567 /* Define or delete an element in the same "environment" as
1568  * vmstrnenv().  If an element is to be deleted, it's removed from
1569  * the first place it's found.  If it's to be set, it's set in the
1570  * place designated by the first element of the table vector.
1571  * Like setenv() returns 0 for success, non-zero on error.
1572  */
1573 int
1574 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1575 {
1576     const char *cp1;
1577     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1578     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1579     int nseg = 0, j;
1580     unsigned long int retsts, usermode = PSL$C_USER;
1581     struct itmlst_3 *ile, *ilist;
1582     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1583                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1584                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1585     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1586     $DESCRIPTOR(local,"_LOCAL");
1587
1588     if (!lnm) {
1589         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1590         return SS$_IVLOGNAM;
1591     }
1592
1593     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1594       *cp2 = _toupper(*cp1);
1595       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1596         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1597         return SS$_IVLOGNAM;
1598       }
1599     }
1600     lnmdsc.dsc$w_length = cp1 - lnm;
1601     if (!tabvec || !*tabvec) tabvec = env_tables;
1602
1603     if (!eqv) {  /* we're deleting n element */
1604       for (curtab = 0; tabvec[curtab]; curtab++) {
1605         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1606         int i;
1607           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1608             if ((cp1 = strchr(environ[i],'=')) &&
1609                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1610                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1611 #ifdef HAS_SETENV
1612               return setenv(lnm,"",1) ? vaxc$errno : 0;
1613             }
1614           }
1615           ivenv = 1; retsts = SS$_NOLOGNAM;
1616 #else
1617               if (ckWARN(WARN_INTERNAL))
1618                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1619               ivenv = 1; retsts = SS$_NOSUCHPGM;
1620               break;
1621             }
1622           }
1623 #endif
1624         }
1625         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1626                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1627           unsigned int symtype;
1628           if (tabvec[curtab]->dsc$w_length == 12 &&
1629               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1630               !str$case_blind_compare(&tmpdsc,&local))
1631             symtype = LIB$K_CLI_LOCAL_SYM;
1632           else symtype = LIB$K_CLI_GLOBAL_SYM;
1633           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1634           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1635           if (retsts == LIB$_NOSUCHSYM) continue;
1636           break;
1637         }
1638         else if (!ivlnm) {
1639           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1640           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1641           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1642           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1643           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1644         }
1645       }
1646     }
1647     else {  /* we're defining a value */
1648       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1649 #ifdef HAS_SETENV
1650         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1651 #else
1652         if (ckWARN(WARN_INTERNAL))
1653           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1654         retsts = SS$_NOSUCHPGM;
1655 #endif
1656       }
1657       else {
1658         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1659         eqvdsc.dsc$w_length  = strlen(eqv);
1660         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1661             !str$case_blind_compare(&tmpdsc,&clisym)) {
1662           unsigned int symtype;
1663           if (tabvec[0]->dsc$w_length == 12 &&
1664               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1665                !str$case_blind_compare(&tmpdsc,&local))
1666             symtype = LIB$K_CLI_LOCAL_SYM;
1667           else symtype = LIB$K_CLI_GLOBAL_SYM;
1668           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1669         }
1670         else {
1671           if (!*eqv) eqvdsc.dsc$w_length = 1;
1672           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1673
1674             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1675             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1676               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1677                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1678               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1679               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1680             }
1681
1682             Newx(ilist,nseg+1,struct itmlst_3);
1683             ile = ilist;
1684             if (!ile) {
1685               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1686               return SS$_INSFMEM;
1687             }
1688             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1689
1690             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1691               ile->itmcode = LNM$_STRING;
1692               ile->bufadr = c;
1693               if ((j+1) == nseg) {
1694                 ile->buflen = strlen(c);
1695                 /* in case we are truncating one that's too long */
1696                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1697               }
1698               else {
1699                 ile->buflen = LNM$C_NAMLENGTH;
1700               }
1701             }
1702
1703             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1704             Safefree (ilist);
1705           }
1706           else {
1707             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1708           }
1709         }
1710       }
1711     }
1712     if (!(retsts & 1)) {
1713       switch (retsts) {
1714         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1715         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1716           set_errno(EVMSERR); break;
1717         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1718         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1719           set_errno(EINVAL); break;
1720         case SS$_NOPRIV:
1721           set_errno(EACCES); break;
1722         default:
1723           _ckvmssts(retsts);
1724           set_errno(EVMSERR);
1725        }
1726        set_vaxc_errno(retsts);
1727        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1728     }
1729     else {
1730       /* We reset error values on success because Perl does an hv_fetch()
1731        * before each hv_store(), and if the thing we're setting didn't
1732        * previously exist, we've got a leftover error message.  (Of course,
1733        * this fails in the face of
1734        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1735        * in that the error reported in $! isn't spurious,
1736        * but it's right more often than not.)
1737        */
1738       set_errno(0); set_vaxc_errno(retsts);
1739       return 0;
1740     }
1741
1742 }  /* end of vmssetenv() */
1743 /*}}}*/
1744
1745 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1746 /* This has to be a function since there's a prototype for it in proto.h */
1747 void
1748 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1749 {
1750     if (lnm && *lnm) {
1751       int len = strlen(lnm);
1752       if  (len == 7) {
1753         char uplnm[8];
1754         int i;
1755         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1756         if (!strcmp(uplnm,"DEFAULT")) {
1757           if (eqv && *eqv) my_chdir(eqv);
1758           return;
1759         }
1760     }
1761 #ifndef RTL_USES_UTC
1762     if (len == 6 || len == 2) {
1763       char uplnm[7];
1764       int i;
1765       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1766       uplnm[len] = '\0';
1767       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1768       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1769     }
1770 #endif
1771   }
1772   (void) vmssetenv(lnm,eqv,NULL);
1773 }
1774 /*}}}*/
1775
1776 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1777 /*  vmssetuserlnm
1778  *  sets a user-mode logical in the process logical name table
1779  *  used for redirection of sys$error
1780  */
1781 void
1782 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1783 {
1784     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1785     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1786     unsigned long int iss, attr = LNM$M_CONFINE;
1787     unsigned char acmode = PSL$C_USER;
1788     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1789                                  {0, 0, 0, 0}};
1790     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1791     d_name.dsc$w_length = strlen(name);
1792
1793     lnmlst[0].buflen = strlen(eqv);
1794     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1795
1796     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1797     if (!(iss&1)) lib$signal(iss);
1798 }
1799 /*}}}*/
1800
1801
1802 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1803 /* my_crypt - VMS password hashing
1804  * my_crypt() provides an interface compatible with the Unix crypt()
1805  * C library function, and uses sys$hash_password() to perform VMS
1806  * password hashing.  The quadword hashed password value is returned
1807  * as a NUL-terminated 8 character string.  my_crypt() does not change
1808  * the case of its string arguments; in order to match the behavior
1809  * of LOGINOUT et al., alphabetic characters in both arguments must
1810  *  be upcased by the caller.
1811  *
1812  * - fix me to call ACM services when available
1813  */
1814 char *
1815 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1816 {
1817 #   ifndef UAI$C_PREFERRED_ALGORITHM
1818 #     define UAI$C_PREFERRED_ALGORITHM 127
1819 #   endif
1820     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1821     unsigned short int salt = 0;
1822     unsigned long int sts;
1823     struct const_dsc {
1824         unsigned short int dsc$w_length;
1825         unsigned char      dsc$b_type;
1826         unsigned char      dsc$b_class;
1827         const char *       dsc$a_pointer;
1828     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1829        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1830     struct itmlst_3 uailst[3] = {
1831         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1832         { sizeof salt, UAI$_SALT,    &salt, 0},
1833         { 0,           0,            NULL,  NULL}};
1834     static char hash[9];
1835
1836     usrdsc.dsc$w_length = strlen(usrname);
1837     usrdsc.dsc$a_pointer = usrname;
1838     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1839       switch (sts) {
1840         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1841           set_errno(EACCES);
1842           break;
1843         case RMS$_RNF:
1844           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1845           break;
1846         default:
1847           set_errno(EVMSERR);
1848       }
1849       set_vaxc_errno(sts);
1850       if (sts != RMS$_RNF) return NULL;
1851     }
1852
1853     txtdsc.dsc$w_length = strlen(textpasswd);
1854     txtdsc.dsc$a_pointer = textpasswd;
1855     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1856       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1857     }
1858
1859     return (char *) hash;
1860
1861 }  /* end of my_crypt() */
1862 /*}}}*/
1863
1864
1865 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1866 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1867 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1868
1869 /* fixup barenames that are directories for internal use.
1870  * There have been problems with the consistent handling of UNIX
1871  * style directory names when routines are presented with a name that
1872  * has no directory delimitors at all.  So this routine will eventually
1873  * fix the issue.
1874  */
1875 static char * fixup_bare_dirnames(const char * name)
1876 {
1877   if (decc_disable_to_vms_logname_translation) {
1878 /* fix me */
1879   }
1880   return NULL;
1881 }
1882
1883 /* 8.3, remove() is now broken on symbolic links */
1884 static int rms_erase(const char * vmsname);
1885
1886
1887 /* mp_do_kill_file
1888  * A little hack to get around a bug in some implemenation of remove()
1889  * that do not know how to delete a directory
1890  *
1891  * Delete any file to which user has control access, regardless of whether
1892  * delete access is explicitly allowed.
1893  * Limitations: User must have write access to parent directory.
1894  *              Does not block signals or ASTs; if interrupted in midstream
1895  *              may leave file with an altered ACL.
1896  * HANDLE WITH CARE!
1897  */
1898 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1899 static int
1900 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1901 {
1902     char *vmsname;
1903     char *rslt;
1904     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1905     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1906     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1907     struct myacedef {
1908       unsigned char myace$b_length;
1909       unsigned char myace$b_type;
1910       unsigned short int myace$w_flags;
1911       unsigned long int myace$l_access;
1912       unsigned long int myace$l_ident;
1913     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1914                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1915       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1916      struct itmlst_3
1917        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1918                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1919        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1920        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1921        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1922        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1923
1924     /* Expand the input spec using RMS, since the CRTL remove() and
1925      * system services won't do this by themselves, so we may miss
1926      * a file "hiding" behind a logical name or search list. */
1927     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1928     if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1929
1930     rslt = do_rmsexpand(name,
1931                         vmsname,
1932                         0,
1933                         NULL,
1934                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
1935                         NULL,
1936                         NULL);
1937     if (rslt == NULL) {
1938         PerlMem_free(vmsname);
1939         return -1;
1940       }
1941
1942     /* Erase the file */
1943     rmsts = rms_erase(vmsname);
1944
1945     /* Did it succeed */
1946     if ($VMS_STATUS_SUCCESS(rmsts)) {
1947         PerlMem_free(vmsname);
1948         return 0;
1949       }
1950
1951     /* If not, can changing protections help? */
1952     if (rmsts != RMS$_PRV) {
1953       set_vaxc_errno(rmsts);
1954       PerlMem_free(vmsname);
1955       return -1;
1956     }
1957
1958     /* No, so we get our own UIC to use as a rights identifier,
1959      * and the insert an ACE at the head of the ACL which allows us
1960      * to delete the file.
1961      */
1962     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1963     fildsc.dsc$w_length = strlen(vmsname);
1964     fildsc.dsc$a_pointer = vmsname;
1965     cxt = 0;
1966     newace.myace$l_ident = oldace.myace$l_ident;
1967     rmsts = -1;
1968     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1969       switch (aclsts) {
1970         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1971           set_errno(ENOENT); break;
1972         case RMS$_DIR:
1973           set_errno(ENOTDIR); break;
1974         case RMS$_DEV:
1975           set_errno(ENODEV); break;
1976         case RMS$_SYN: case SS$_INVFILFOROP:
1977           set_errno(EINVAL); break;
1978         case RMS$_PRV:
1979           set_errno(EACCES); break;
1980         default:
1981           _ckvmssts_noperl(aclsts);
1982       }
1983       set_vaxc_errno(aclsts);
1984       PerlMem_free(vmsname);
1985       return -1;
1986     }
1987     /* Grab any existing ACEs with this identifier in case we fail */
1988     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1989     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1990                     || fndsts == SS$_NOMOREACE ) {
1991       /* Add the new ACE . . . */
1992       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1993         goto yourroom;
1994
1995       rmsts = rms_erase(vmsname);
1996       if ($VMS_STATUS_SUCCESS(rmsts)) {
1997         rmsts = 0;
1998         }
1999         else {
2000         rmsts = -1;
2001         /* We blew it - dir with files in it, no write priv for
2002          * parent directory, etc.  Put things back the way they were. */
2003         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
2004           goto yourroom;
2005         if (fndsts & 1) {
2006           addlst[0].bufadr = &oldace;
2007           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2008             goto yourroom;
2009         }
2010       }
2011     }
2012
2013     yourroom:
2014     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2015     /* We just deleted it, so of course it's not there.  Some versions of
2016      * VMS seem to return success on the unlock operation anyhow (after all
2017      * the unlock is successful), but others don't.
2018      */
2019     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2020     if (aclsts & 1) aclsts = fndsts;
2021     if (!(aclsts & 1)) {
2022       set_errno(EVMSERR);
2023       set_vaxc_errno(aclsts);
2024     }
2025
2026     PerlMem_free(vmsname);
2027     return rmsts;
2028
2029 }  /* end of kill_file() */
2030 /*}}}*/
2031
2032
2033 /*{{{int do_rmdir(char *name)*/
2034 int
2035 Perl_do_rmdir(pTHX_ const char *name)
2036 {
2037     char * dirfile;
2038     int retval;
2039     Stat_t st;
2040
2041     dirfile = PerlMem_malloc(VMS_MAXRSS + 1);
2042     if (dirfile == NULL)
2043         _ckvmssts(SS$_INSFMEM);
2044
2045     /* Force to a directory specification */
2046     if (do_fileify_dirspec(name, dirfile, 0, NULL) == NULL) {
2047         PerlMem_free(dirfile);
2048         return -1;
2049     }
2050     if (Perl_flex_lstat(aTHX_ dirfile, &st) || !S_ISDIR(st.st_mode)) {
2051         errno = ENOTDIR;
2052         retval = -1;
2053     }
2054     else
2055         retval = mp_do_kill_file(aTHX_ dirfile, 1);
2056
2057     PerlMem_free(dirfile);
2058     return retval;
2059
2060 }  /* end of do_rmdir */
2061 /*}}}*/
2062
2063 /* kill_file
2064  * Delete any file to which user has control access, regardless of whether
2065  * delete access is explicitly allowed.
2066  * Limitations: User must have write access to parent directory.
2067  *              Does not block signals or ASTs; if interrupted in midstream
2068  *              may leave file with an altered ACL.
2069  * HANDLE WITH CARE!
2070  */
2071 /*{{{int kill_file(char *name)*/
2072 int
2073 Perl_kill_file(pTHX_ const char *name)
2074 {
2075     char rspec[NAM$C_MAXRSS+1];
2076     char *tspec;
2077     Stat_t st;
2078     int rmsts;
2079
2080    /* Remove() is allowed to delete directories, according to the X/Open
2081     * specifications.
2082     * This may need special handling to work with the ACL hacks.
2083      */
2084    if ((flex_lstat(name, &st) == 0) && S_ISDIR(st.st_mode)) {
2085         rmsts = Perl_do_rmdir(aTHX_ name);
2086         return rmsts;
2087     }
2088
2089    rmsts = mp_do_kill_file(aTHX_ name, 0);
2090
2091     return rmsts;
2092
2093 }  /* end of kill_file() */
2094 /*}}}*/
2095
2096
2097 /*{{{int my_mkdir(char *,Mode_t)*/
2098 int
2099 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2100 {
2101   STRLEN dirlen = strlen(dir);
2102
2103   /* zero length string sometimes gives ACCVIO */
2104   if (dirlen == 0) return -1;
2105
2106   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2107    * null file name/type.  However, it's commonplace under Unix,
2108    * so we'll allow it for a gain in portability.
2109    */
2110   if (dir[dirlen-1] == '/') {
2111     char *newdir = savepvn(dir,dirlen-1);
2112     int ret = mkdir(newdir,mode);
2113     Safefree(newdir);
2114     return ret;
2115   }
2116   else return mkdir(dir,mode);
2117 }  /* end of my_mkdir */
2118 /*}}}*/
2119
2120 /*{{{int my_chdir(char *)*/
2121 int
2122 Perl_my_chdir(pTHX_ const char *dir)
2123 {
2124   STRLEN dirlen = strlen(dir);
2125
2126   /* zero length string sometimes gives ACCVIO */
2127   if (dirlen == 0) return -1;
2128   const char *dir1;
2129
2130   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2131    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2132    * so that existing scripts do not need to be changed.
2133    */
2134   dir1 = dir;
2135   while ((dirlen > 0) && (*dir1 == ' ')) {
2136     dir1++;
2137     dirlen--;
2138   }
2139
2140   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2141    * that implies
2142    * null file name/type.  However, it's commonplace under Unix,
2143    * so we'll allow it for a gain in portability.
2144    *
2145    * - Preview- '/' will be valid soon on VMS
2146    */
2147   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2148     char *newdir = savepvn(dir1,dirlen-1);
2149     int ret = chdir(newdir);
2150     Safefree(newdir);
2151     return ret;
2152   }
2153   else return chdir(dir1);
2154 }  /* end of my_chdir */
2155 /*}}}*/
2156
2157
2158 /*{{{int my_chmod(char *, mode_t)*/
2159 int
2160 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2161 {
2162   STRLEN speclen = strlen(file_spec);
2163
2164   /* zero length string sometimes gives ACCVIO */
2165   if (speclen == 0) return -1;
2166
2167   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2168    * that implies null file name/type.  However, it's commonplace under Unix,
2169    * so we'll allow it for a gain in portability.
2170    *
2171    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2172    * in VMS file.dir notation.
2173    */
2174   if ((speclen > 1) && (file_spec[speclen-1] == '/')) {
2175     char *vms_src, *vms_dir, *rslt;
2176     int ret = -1;
2177     errno = EIO;
2178
2179     /* First convert this to a VMS format specification */
2180     vms_src = PerlMem_malloc(VMS_MAXRSS);
2181     if (vms_src == NULL)
2182         _ckvmssts_noperl(SS$_INSFMEM);
2183
2184     rslt = do_tovmsspec(file_spec, vms_src, 0, NULL);
2185     if (rslt == NULL) {
2186         /* If we fail, then not a file specification */
2187         PerlMem_free(vms_src);
2188         errno = EIO;
2189         return -1;
2190     }
2191
2192     /* Now make it a directory spec so chmod is happy */
2193     vms_dir = PerlMem_malloc(VMS_MAXRSS + 1);
2194     if (vms_dir == NULL)
2195         _ckvmssts_noperl(SS$_INSFMEM);
2196     rslt = do_fileify_dirspec(vms_src, vms_dir, 0, NULL);
2197     PerlMem_free(vms_src);
2198
2199     /* Now do it */
2200     if (rslt != NULL) {
2201         ret = chmod(vms_dir, mode);
2202     } else {
2203         errno = EIO;
2204     }
2205     PerlMem_free(vms_dir);
2206     return ret;
2207   }
2208   else return chmod(file_spec, mode);
2209 }  /* end of my_chmod */
2210 /*}}}*/
2211
2212
2213 /*{{{FILE *my_tmpfile()*/
2214 FILE *
2215 my_tmpfile(void)
2216 {
2217   FILE *fp;
2218   char *cp;
2219
2220   if ((fp = tmpfile())) return fp;
2221
2222   cp = PerlMem_malloc(L_tmpnam+24);
2223   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2224
2225   if (decc_filename_unix_only == 0)
2226     strcpy(cp,"Sys$Scratch:");
2227   else
2228     strcpy(cp,"/tmp/");
2229   tmpnam(cp+strlen(cp));
2230   strcat(cp,".Perltmp");
2231   fp = fopen(cp,"w+","fop=dlt");
2232   PerlMem_free(cp);
2233   return fp;
2234 }
2235 /*}}}*/
2236
2237
2238 #ifndef HOMEGROWN_POSIX_SIGNALS
2239 /*
2240  * The C RTL's sigaction fails to check for invalid signal numbers so we
2241  * help it out a bit.  The docs are correct, but the actual routine doesn't
2242  * do what the docs say it will.
2243  */
2244 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2245 int
2246 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2247                    struct sigaction* oact)
2248 {
2249   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2250         SETERRNO(EINVAL, SS$_INVARG);
2251         return -1;
2252   }
2253   return sigaction(sig, act, oact);
2254 }
2255 /*}}}*/
2256 #endif
2257
2258 #ifdef KILL_BY_SIGPRC
2259 #include <errnodef.h>
2260
2261 /* We implement our own kill() using the undocumented system service
2262    sys$sigprc for one of two reasons:
2263
2264    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2265    target process to do a sys$exit, which usually can't be handled
2266    gracefully...certainly not by Perl and the %SIG{} mechanism.
2267
2268    2.) If the kill() in the CRTL can't be called from a signal
2269    handler without disappearing into the ether, i.e., the signal
2270    it purportedly sends is never trapped. Still true as of VMS 7.3.
2271
2272    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2273    in the target process rather than calling sys$exit.
2274
2275    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2276    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2277    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2278    with condition codes C$_SIG0+nsig*8, catching the exception on the
2279    target process and resignaling with appropriate arguments.
2280
2281    But we don't have that VMS 7.0+ exception handler, so if you
2282    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2283
2284    Also note that SIGTERM is listed in the docs as being "unimplemented",
2285    yet always seems to be signaled with a VMS condition code of 4 (and
2286    correctly handled for that code).  So we hardwire it in.
2287
2288    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2289    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2290    than signalling with an unrecognized (and unhandled by CRTL) code.
2291 */
2292
2293 #define _MY_SIG_MAX 28
2294
2295 static unsigned int
2296 Perl_sig_to_vmscondition_int(int sig)
2297 {
2298     static unsigned int sig_code[_MY_SIG_MAX+1] =
2299     {
2300         0,                  /*  0 ZERO     */
2301         SS$_HANGUP,         /*  1 SIGHUP   */
2302         SS$_CONTROLC,       /*  2 SIGINT   */
2303         SS$_CONTROLY,       /*  3 SIGQUIT  */
2304         SS$_RADRMOD,        /*  4 SIGILL   */
2305         SS$_BREAK,          /*  5 SIGTRAP  */
2306         SS$_OPCCUS,         /*  6 SIGABRT  */
2307         SS$_COMPAT,         /*  7 SIGEMT   */
2308 #ifdef __VAX
2309         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2310 #else
2311         SS$_HPARITH,        /*  8 SIGFPE AXP */
2312 #endif
2313         SS$_ABORT,          /*  9 SIGKILL  */
2314         SS$_ACCVIO,         /* 10 SIGBUS   */
2315         SS$_ACCVIO,         /* 11 SIGSEGV  */
2316         SS$_BADPARAM,       /* 12 SIGSYS   */
2317         SS$_NOMBX,          /* 13 SIGPIPE  */
2318         SS$_ASTFLT,         /* 14 SIGALRM  */
2319         4,                  /* 15 SIGTERM  */
2320         0,                  /* 16 SIGUSR1  */
2321         0,                  /* 17 SIGUSR2  */
2322         0,                  /* 18 */
2323         0,                  /* 19 */
2324         0,                  /* 20 SIGCHLD  */
2325         0,                  /* 21 SIGCONT  */
2326         0,                  /* 22 SIGSTOP  */
2327         0,                  /* 23 SIGTSTP  */
2328         0,                  /* 24 SIGTTIN  */
2329         0,                  /* 25 SIGTTOU  */
2330         0,                  /* 26 */
2331         0,                  /* 27 */
2332         0                   /* 28 SIGWINCH  */
2333     };
2334
2335 #if __VMS_VER >= 60200000
2336     static int initted = 0;
2337     if (!initted) {
2338         initted = 1;
2339         sig_code[16] = C$_SIGUSR1;
2340         sig_code[17] = C$_SIGUSR2;
2341 #if __CRTL_VER >= 70000000
2342         sig_code[20] = C$_SIGCHLD;
2343 #endif
2344 #if __CRTL_VER >= 70300000
2345         sig_code[28] = C$_SIGWINCH;
2346 #endif
2347     }
2348 #endif
2349
2350     if (sig < _SIG_MIN) return 0;
2351     if (sig > _MY_SIG_MAX) return 0;
2352     return sig_code[sig];
2353 }
2354
2355 unsigned int
2356 Perl_sig_to_vmscondition(int sig)
2357 {
2358 #ifdef SS$_DEBUG
2359     if (vms_debug_on_exception != 0)
2360         lib$signal(SS$_DEBUG);
2361 #endif
2362     return Perl_sig_to_vmscondition_int(sig);
2363 }
2364
2365
2366 int
2367 Perl_my_kill(int pid, int sig)
2368 {
2369     dTHX;
2370     int iss;
2371     unsigned int code;
2372     int sys$sigprc(unsigned int *pidadr,
2373                      struct dsc$descriptor_s *prcname,
2374                      unsigned int code);
2375
2376      /* sig 0 means validate the PID */
2377     /*------------------------------*/
2378     if (sig == 0) {
2379         const unsigned long int jpicode = JPI$_PID;
2380         pid_t ret_pid;
2381         int status;
2382         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2383         if ($VMS_STATUS_SUCCESS(status))
2384            return 0;
2385         switch (status) {
2386         case SS$_NOSUCHNODE:
2387         case SS$_UNREACHABLE:
2388         case SS$_NONEXPR:
2389            errno = ESRCH;
2390            break;
2391         case SS$_NOPRIV:
2392            errno = EPERM;
2393            break;
2394         default:
2395            errno = EVMSERR;
2396         }
2397         vaxc$errno=status;
2398         return -1;
2399     }
2400
2401     code = Perl_sig_to_vmscondition_int(sig);
2402
2403     if (!code) {
2404         SETERRNO(EINVAL, SS$_BADPARAM);
2405         return -1;
2406     }
2407
2408     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2409      * signals are to be sent to multiple processes.
2410      *  pid = 0 - all processes in group except ones that the system exempts
2411      *  pid = -1 - all processes except ones that the system exempts
2412      *  pid = -n - all processes in group (abs(n)) except ...
2413      * For now, just report as not supported.
2414      */
2415
2416     if (pid <= 0) {
2417         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2418         return -1;
2419     }
2420
2421     iss = sys$sigprc((unsigned int *)&pid,0,code);
2422     if (iss&1) return 0;
2423
2424     switch (iss) {
2425       case SS$_NOPRIV:
2426         set_errno(EPERM);  break;
2427       case SS$_NONEXPR:
2428       case SS$_NOSUCHNODE:
2429       case SS$_UNREACHABLE:
2430         set_errno(ESRCH);  break;
2431       case SS$_INSFMEM:
2432         set_errno(ENOMEM); break;
2433       default:
2434         _ckvmssts_noperl(iss);
2435         set_errno(EVMSERR);
2436     }
2437     set_vaxc_errno(iss);
2438
2439     return -1;
2440 }
2441 #endif
2442
2443 /* Routine to convert a VMS status code to a UNIX status code.
2444 ** More tricky than it appears because of conflicting conventions with
2445 ** existing code.
2446 **
2447 ** VMS status codes are a bit mask, with the least significant bit set for
2448 ** success.
2449 **
2450 ** Special UNIX status of EVMSERR indicates that no translation is currently
2451 ** available, and programs should check the VMS status code.
2452 **
2453 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2454 ** decoding.
2455 */
2456
2457 #ifndef C_FACILITY_NO
2458 #define C_FACILITY_NO 0x350000
2459 #endif
2460 #ifndef DCL_IVVERB
2461 #define DCL_IVVERB 0x38090
2462 #endif
2463
2464 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2465 {
2466 int facility;
2467 int fac_sp;
2468 int msg_no;
2469 int msg_status;
2470 int unix_status;
2471
2472   /* Assume the best or the worst */
2473   if (vms_status & STS$M_SUCCESS)
2474     unix_status = 0;
2475   else
2476     unix_status = EVMSERR;
2477
2478   msg_status = vms_status & ~STS$M_CONTROL;
2479
2480   facility = vms_status & STS$M_FAC_NO;
2481   fac_sp = vms_status & STS$M_FAC_SP;
2482   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2483
2484   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2485     switch(msg_no) {
2486     case SS$_NORMAL:
2487         unix_status = 0;
2488         break;
2489     case SS$_ACCVIO:
2490         unix_status = EFAULT;
2491         break;
2492     case SS$_DEVOFFLINE:
2493         unix_status = EBUSY;
2494         break;
2495     case SS$_CLEARED:
2496         unix_status = ENOTCONN;
2497         break;
2498     case SS$_IVCHAN:
2499     case SS$_IVLOGNAM:
2500     case SS$_BADPARAM:
2501     case SS$_IVLOGTAB:
2502     case SS$_NOLOGNAM:
2503     case SS$_NOLOGTAB:
2504     case SS$_INVFILFOROP:
2505     case SS$_INVARG:
2506     case SS$_NOSUCHID:
2507     case SS$_IVIDENT:
2508         unix_status = EINVAL;
2509         break;
2510     case SS$_UNSUPPORTED:
2511         unix_status = ENOTSUP;
2512         break;
2513     case SS$_FILACCERR:
2514     case SS$_NOGRPPRV:
2515     case SS$_NOSYSPRV:
2516         unix_status = EACCES;
2517         break;
2518     case SS$_DEVICEFULL:
2519         unix_status = ENOSPC;
2520         break;
2521     case SS$_NOSUCHDEV:
2522         unix_status = ENODEV;
2523         break;
2524     case SS$_NOSUCHFILE:
2525     case SS$_NOSUCHOBJECT:
2526         unix_status = ENOENT;
2527         break;
2528     case SS$_ABORT:                                 /* Fatal case */
2529     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2530     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2531         unix_status = EINTR;
2532         break;
2533     case SS$_BUFFEROVF:
2534         unix_status = E2BIG;
2535         break;
2536     case SS$_INSFMEM:
2537         unix_status = ENOMEM;
2538         break;
2539     case SS$_NOPRIV:
2540         unix_status = EPERM;
2541         break;
2542     case SS$_NOSUCHNODE:
2543     case SS$_UNREACHABLE:
2544         unix_status = ESRCH;
2545         break;
2546     case SS$_NONEXPR:
2547         unix_status = ECHILD;
2548         break;
2549     default:
2550         if ((facility == 0) && (msg_no < 8)) {
2551           /* These are not real VMS status codes so assume that they are
2552           ** already UNIX status codes
2553           */
2554           unix_status = msg_no;
2555           break;
2556         }
2557     }
2558   }
2559   else {
2560     /* Translate a POSIX exit code to a UNIX exit code */
2561     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2562         unix_status = (msg_no & 0x07F8) >> 3;
2563     }
2564     else {
2565
2566          /* Documented traditional behavior for handling VMS child exits */
2567         /*--------------------------------------------------------------*/
2568         if (child_flag != 0) {
2569
2570              /* Success / Informational return 0 */
2571             /*----------------------------------*/
2572             if (msg_no & STS$K_SUCCESS)
2573                 return 0;
2574
2575              /* Warning returns 1 */
2576             /*-------------------*/
2577             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2578                 return 1;
2579
2580              /* Everything else pass through the severity bits */
2581             /*------------------------------------------------*/
2582             return (msg_no & STS$M_SEVERITY);
2583         }
2584
2585          /* Normal VMS status to ERRNO mapping attempt */
2586         /*--------------------------------------------*/
2587         switch(msg_status) {
2588         /* case RMS$_EOF: */ /* End of File */
2589         case RMS$_FNF:  /* File Not Found */
2590         case RMS$_DNF:  /* Dir Not Found */
2591                 unix_status = ENOENT;
2592                 break;
2593         case RMS$_RNF:  /* Record Not Found */
2594                 unix_status = ESRCH;
2595                 break;
2596         case RMS$_DIR:
2597                 unix_status = ENOTDIR;
2598                 break;
2599         case RMS$_DEV:
2600                 unix_status = ENODEV;
2601                 break;
2602         case RMS$_IFI:
2603         case RMS$_FAC:
2604         case RMS$_ISI:
2605                 unix_status = EBADF;
2606                 break;
2607         case RMS$_FEX:
2608                 unix_status = EEXIST;
2609                 break;
2610         case RMS$_SYN:
2611         case RMS$_FNM:
2612         case LIB$_INVSTRDES:
2613         case LIB$_INVARG:
2614         case LIB$_NOSUCHSYM:
2615         case LIB$_INVSYMNAM:
2616         case DCL_IVVERB:
2617                 unix_status = EINVAL;
2618                 break;
2619         case CLI$_BUFOVF:
2620         case RMS$_RTB:
2621         case CLI$_TKNOVF:
2622         case CLI$_RSLOVF:
2623                 unix_status = E2BIG;
2624                 break;
2625         case RMS$_PRV:  /* No privilege */
2626         case RMS$_ACC:  /* ACP file access failed */
2627         case RMS$_WLK:  /* Device write locked */
2628                 unix_status = EACCES;
2629                 break;
2630         case RMS$_MKD:  /* Failed to mark for delete */
2631                 unix_status = EPERM;
2632                 break;
2633         /* case RMS$_NMF: */  /* No more files */
2634         }
2635     }
2636   }
2637
2638   return unix_status;
2639 }
2640
2641 /* Try to guess at what VMS error status should go with a UNIX errno
2642  * value.  This is hard to do as there could be many possible VMS
2643  * error statuses that caused the errno value to be set.
2644  */
2645
2646 int Perl_unix_status_to_vms(int unix_status)
2647 {
2648 int test_unix_status;
2649
2650      /* Trivial cases first */
2651     /*---------------------*/
2652     if (unix_status == EVMSERR)
2653         return vaxc$errno;
2654
2655      /* Is vaxc$errno sane? */
2656     /*---------------------*/
2657     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2658     if (test_unix_status == unix_status)
2659         return vaxc$errno;
2660
2661      /* If way out of range, must be VMS code already */
2662     /*-----------------------------------------------*/
2663     if (unix_status > EVMSERR)
2664         return unix_status;
2665
2666      /* If out of range, punt */
2667     /*-----------------------*/
2668     if (unix_status > __ERRNO_MAX)
2669         return SS$_ABORT;
2670
2671
2672      /* Ok, now we have to do it the hard way. */
2673     /*----------------------------------------*/
2674     switch(unix_status) {
2675     case 0:     return SS$_NORMAL;
2676     case EPERM: return SS$_NOPRIV;
2677     case ENOENT: return SS$_NOSUCHOBJECT;
2678     case ESRCH: return SS$_UNREACHABLE;
2679     case EINTR: return SS$_ABORT;
2680     /* case EIO: */
2681     /* case ENXIO:  */
2682     case E2BIG: return SS$_BUFFEROVF;
2683     /* case ENOEXEC */
2684     case EBADF: return RMS$_IFI;
2685     case ECHILD: return SS$_NONEXPR;
2686     /* case EAGAIN */
2687     case ENOMEM: return SS$_INSFMEM;
2688     case EACCES: return SS$_FILACCERR;
2689     case EFAULT: return SS$_ACCVIO;
2690     /* case ENOTBLK */
2691     case EBUSY: return SS$_DEVOFFLINE;
2692     case EEXIST: return RMS$_FEX;
2693     /* case EXDEV */
2694     case ENODEV: return SS$_NOSUCHDEV;
2695     case ENOTDIR: return RMS$_DIR;
2696     /* case EISDIR */
2697     case EINVAL: return SS$_INVARG;
2698     /* case ENFILE */
2699     /* case EMFILE */
2700     /* case ENOTTY */
2701     /* case ETXTBSY */
2702     /* case EFBIG */
2703     case ENOSPC: return SS$_DEVICEFULL;
2704     case ESPIPE: return LIB$_INVARG;
2705     /* case EROFS: */
2706     /* case EMLINK: */
2707     /* case EPIPE: */
2708     /* case EDOM */
2709     case ERANGE: return LIB$_INVARG;
2710     /* case EWOULDBLOCK */
2711     /* case EINPROGRESS */
2712     /* case EALREADY */
2713     /* case ENOTSOCK */
2714     /* case EDESTADDRREQ */
2715     /* case EMSGSIZE */
2716     /* case EPROTOTYPE */
2717     /* case ENOPROTOOPT */
2718     /* case EPROTONOSUPPORT */
2719     /* case ESOCKTNOSUPPORT */
2720     /* case EOPNOTSUPP */
2721     /* case EPFNOSUPPORT */
2722     /* case EAFNOSUPPORT */
2723     /* case EADDRINUSE */
2724     /* case EADDRNOTAVAIL */
2725     /* case ENETDOWN */
2726     /* case ENETUNREACH */
2727     /* case ENETRESET */
2728     /* case ECONNABORTED */
2729     /* case ECONNRESET */
2730     /* case ENOBUFS */
2731     /* case EISCONN */
2732     case ENOTCONN: return SS$_CLEARED;
2733     /* case ESHUTDOWN */
2734     /* case ETOOMANYREFS */
2735     /* case ETIMEDOUT */
2736     /* case ECONNREFUSED */
2737     /* case ELOOP */
2738     /* case ENAMETOOLONG */
2739     /* case EHOSTDOWN */
2740     /* case EHOSTUNREACH */
2741     /* case ENOTEMPTY */
2742     /* case EPROCLIM */
2743     /* case EUSERS  */
2744     /* case EDQUOT  */
2745     /* case ENOMSG  */
2746     /* case EIDRM */
2747     /* case EALIGN */
2748     /* case ESTALE */
2749     /* case EREMOTE */
2750     /* case ENOLCK */
2751     /* case ENOSYS */
2752     /* case EFTYPE */
2753     /* case ECANCELED */
2754     /* case EFAIL */
2755     /* case EINPROG */
2756     case ENOTSUP:
2757         return SS$_UNSUPPORTED;
2758     /* case EDEADLK */
2759     /* case ENWAIT */
2760     /* case EILSEQ */
2761     /* case EBADCAT */
2762     /* case EBADMSG */
2763     /* case EABANDONED */
2764     default:
2765         return SS$_ABORT; /* punt */
2766     }
2767
2768   return SS$_ABORT; /* Should not get here */
2769 }
2770
2771
2772 /* default piping mailbox size */
2773 #define PERL_BUFSIZ        512
2774
2775
2776 static void
2777 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2778 {
2779   unsigned long int mbxbufsiz;
2780   static unsigned long int syssize = 0;
2781   unsigned long int dviitm = DVI$_DEVNAM;
2782   char csize[LNM$C_NAMLENGTH+1];
2783   int sts;
2784
2785   if (!syssize) {
2786     unsigned long syiitm = SYI$_MAXBUF;
2787     /*
2788      * Get the SYSGEN parameter MAXBUF
2789      *
2790      * If the logical 'PERL_MBX_SIZE' is defined
2791      * use the value of the logical instead of PERL_BUFSIZ, but
2792      * keep the size between 128 and MAXBUF.
2793      *
2794      */
2795     _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2796   }
2797
2798   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2799       mbxbufsiz = atoi(csize);
2800   } else {
2801       mbxbufsiz = PERL_BUFSIZ;
2802   }
2803   if (mbxbufsiz < 128) mbxbufsiz = 128;
2804   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2805
2806   _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2807
2808   sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2809   _ckvmssts_noperl(sts);
2810   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2811
2812 }  /* end of create_mbx() */
2813
2814
2815 /*{{{  my_popen and my_pclose*/
2816
2817 typedef struct _iosb           IOSB;
2818 typedef struct _iosb*         pIOSB;
2819 typedef struct _pipe           Pipe;
2820 typedef struct _pipe*         pPipe;
2821 typedef struct pipe_details    Info;
2822 typedef struct pipe_details*  pInfo;
2823 typedef struct _srqp            RQE;
2824 typedef struct _srqp*          pRQE;
2825 typedef struct _tochildbuf      CBuf;
2826 typedef struct _tochildbuf*    pCBuf;
2827
2828 struct _iosb {
2829     unsigned short status;
2830     unsigned short count;
2831     unsigned long  dvispec;
2832 };
2833
2834 #pragma member_alignment save
2835 #pragma nomember_alignment quadword
2836 struct _srqp {          /* VMS self-relative queue entry */
2837     unsigned long qptr[2];
2838 };
2839 #pragma member_alignment restore
2840 static RQE  RQE_ZERO = {0,0};
2841
2842 struct _tochildbuf {
2843     RQE             q;
2844     int             eof;
2845     unsigned short  size;
2846     char            *buf;
2847 };
2848
2849 struct _pipe {
2850     RQE            free;
2851     RQE            wait;
2852     int            fd_out;
2853     unsigned short chan_in;
2854     unsigned short chan_out;
2855     char          *buf;
2856     unsigned int   bufsize;
2857     IOSB           iosb;
2858     IOSB           iosb2;
2859     int           *pipe_done;
2860     int            retry;
2861     int            type;
2862     int            shut_on_empty;
2863     int            need_wake;
2864     pPipe         *home;
2865     pInfo          info;
2866     pCBuf          curr;
2867     pCBuf          curr2;
2868 #if defined(PERL_IMPLICIT_CONTEXT)
2869     void            *thx;           /* Either a thread or an interpreter */
2870                                     /* pointer, depending on how we're built */
2871 #endif
2872 };
2873
2874
2875 struct pipe_details
2876 {
2877     pInfo           next;
2878     PerlIO *fp;  /* file pointer to pipe mailbox */
2879     int useFILE; /* using stdio, not perlio */
2880     int pid;   /* PID of subprocess */
2881     int mode;  /* == 'r' if pipe open for reading */
2882     int done;  /* subprocess has completed */
2883     int waiting; /* waiting for completion/closure */
2884     int             closing;        /* my_pclose is closing this pipe */
2885     unsigned long   completion;     /* termination status of subprocess */
2886     pPipe           in;             /* pipe in to sub */
2887     pPipe           out;            /* pipe out of sub */
2888     pPipe           err;            /* pipe of sub's sys$error */
2889     int             in_done;        /* true when in pipe finished */
2890     int             out_done;
2891     int             err_done;
2892     unsigned short  xchan;          /* channel to debug xterm */
2893     unsigned short  xchan_valid;    /* channel is assigned */
2894 };
2895
2896 struct exit_control_block
2897 {
2898     struct exit_control_block *flink;
2899     unsigned long int   (*exit_routine)();
2900     unsigned long int arg_count;
2901     unsigned long int *status_address;
2902     unsigned long int exit_status;
2903 };
2904
2905 typedef struct _closed_pipes    Xpipe;
2906 typedef struct _closed_pipes*  pXpipe;
2907
2908 struct _closed_pipes {
2909     int             pid;            /* PID of subprocess */
2910     unsigned long   completion;     /* termination status of subprocess */
2911 };
2912 #define NKEEPCLOSED 50
2913 static Xpipe closed_list[NKEEPCLOSED];
2914 static int   closed_index = 0;
2915 static int   closed_num = 0;
2916
2917 #define RETRY_DELAY     "0 ::0.20"
2918 #define MAX_RETRY              50
2919
2920 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2921 static unsigned long mypid;
2922 static unsigned long delaytime[2];
2923
2924 static pInfo open_pipes = NULL;
2925 static $DESCRIPTOR(nl_desc, "NL:");
2926
2927 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2928
2929
2930
2931 static unsigned long int
2932 pipe_exit_routine()
2933 {
2934     pInfo info;
2935     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2936     int sts, did_stuff, need_eof, j;
2937
2938    /*
2939     * Flush any pending i/o, but since we are in process run-down, be
2940     * careful about referencing PerlIO structures that may already have
2941     * been deallocated.  We may not even have an interpreter anymore.
2942     */
2943     info = open_pipes;
2944     while (info) {
2945         if (info->fp) {
2946 #if defined(PERL_IMPLICIT_CONTEXT)
2947            /* We need to use the Perl context of the thread that created */
2948            /* the pipe. */
2949            pTHX;
2950            if (info->err)
2951                aTHX = info->err->thx;
2952            else if (info->out)
2953                aTHX = info->out->thx;
2954            else if (info->in)
2955                aTHX = info->in->thx;
2956 #endif
2957            if (!info->useFILE
2958 #if defined(USE_ITHREADS)
2959              && my_perl
2960 #endif
2961              && PL_perlio_fd_refcnt)
2962                PerlIO_flush(info->fp);
2963            else
2964                fflush((FILE *)info->fp);
2965         }
2966         info = info->next;
2967     }
2968
2969     /*
2970      next we try sending an EOF...ignore if doesn't work, make sure we
2971      don't hang
2972     */
2973     did_stuff = 0;
2974     info = open_pipes;
2975
2976     while (info) {
2977       int need_eof;
2978       _ckvmssts_noperl(sys$setast(0));
2979       if (info->in && !info->in->shut_on_empty) {
2980         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2981                                  0, 0, 0, 0, 0, 0));
2982         info->waiting = 1;
2983         did_stuff = 1;
2984       }
2985       _ckvmssts_noperl(sys$setast(1));
2986       info = info->next;
2987     }
2988
2989     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2990
2991     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2992         int nwait = 0;
2993
2994         info = open_pipes;
2995         while (info) {
2996           _ckvmssts_noperl(sys$setast(0));
2997           if (info->waiting && info->done)
2998                 info->waiting = 0;
2999           nwait += info->waiting;
3000           _ckvmssts_noperl(sys$setast(1));
3001           info = info->next;
3002         }
3003         if (!nwait) break;
3004         sleep(1);
3005     }
3006
3007     did_stuff = 0;
3008     info = open_pipes;
3009     while (info) {
3010       _ckvmssts_noperl(sys$setast(0));
3011       if (!info->done) { /* Tap them gently on the shoulder . . .*/
3012         sts = sys$forcex(&info->pid,0,&abort);
3013         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3014         did_stuff = 1;
3015       }
3016       _ckvmssts_noperl(sys$setast(1));
3017       info = info->next;
3018     }
3019
3020     /* again, wait for effect */
3021
3022     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3023         int nwait = 0;
3024
3025         info = open_pipes;
3026         while (info) {
3027           _ckvmssts_noperl(sys$setast(0));
3028           if (info->waiting && info->done)
3029                 info->waiting = 0;
3030           nwait += info->waiting;
3031           _ckvmssts_noperl(sys$setast(1));
3032           info = info->next;
3033         }
3034         if (!nwait) break;
3035         sleep(1);
3036     }
3037
3038     info = open_pipes;
3039     while (info) {
3040       _ckvmssts_noperl(sys$setast(0));
3041       if (!info->done) {  /* We tried to be nice . . . */
3042         sts = sys$delprc(&info->pid,0);
3043         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3044         info->done = 1;  /* sys$delprc is as done as we're going to get. */
3045       }
3046       _ckvmssts_noperl(sys$setast(1));
3047       info = info->next;
3048     }
3049
3050     while(open_pipes) {
3051
3052 #if defined(PERL_IMPLICIT_CONTEXT)
3053       /* We need to use the Perl context of the thread that created */
3054       /* the pipe. */
3055       pTHX;
3056       if (open_pipes->err)
3057           aTHX = open_pipes->err->thx;
3058       else if (open_pipes->out)
3059           aTHX = open_pipes->out->thx;
3060       else if (open_pipes->in)
3061           aTHX = open_pipes->in->thx;
3062 #endif
3063       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3064       else if (!(sts & 1)) retsts = sts;
3065     }
3066     return retsts;
3067 }
3068
3069 static struct exit_control_block pipe_exitblock =
3070        {(struct exit_control_block *) 0,
3071         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3072
3073 static void pipe_mbxtofd_ast(pPipe p);
3074 static void pipe_tochild1_ast(pPipe p);
3075 static void pipe_tochild2_ast(pPipe p);
3076
3077 static void
3078 popen_completion_ast(pInfo info)
3079 {
3080   pInfo i = open_pipes;
3081   int iss;
3082   int sts;
3083   pXpipe x;
3084
3085   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3086   closed_list[closed_index].pid = info->pid;
3087   closed_list[closed_index].completion = info->completion;
3088   closed_index++;
3089   if (closed_index == NKEEPCLOSED)
3090     closed_index = 0;
3091   closed_num++;
3092
3093   while (i) {
3094     if (i == info) break;
3095     i = i->next;
3096   }
3097   if (!i) return;       /* unlinked, probably freed too */
3098
3099   info->done = TRUE;
3100
3101 /*
3102     Writing to subprocess ...
3103             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3104
3105             chan_out may be waiting for "done" flag, or hung waiting
3106             for i/o completion to child...cancel the i/o.  This will
3107             put it into "snarf mode" (done but no EOF yet) that discards
3108             input.
3109
3110     Output from subprocess (stdout, stderr) needs to be flushed and
3111     shut down.   We try sending an EOF, but if the mbx is full the pipe
3112     routine should still catch the "shut_on_empty" flag, telling it to
3113     use immediate-style reads so that "mbx empty" -> EOF.
3114
3115
3116 */
3117   if (info->in && !info->in_done) {               /* only for mode=w */
3118         if (info->in->shut_on_empty && info->in->need_wake) {
3119             info->in->need_wake = FALSE;
3120             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3121         } else {
3122             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3123         }
3124   }
3125
3126   if (info->out && !info->out_done) {             /* were we also piping output? */
3127       info->out->shut_on_empty = TRUE;
3128       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3129       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3130       _ckvmssts_noperl(iss);
3131   }
3132
3133   if (info->err && !info->err_done) {        /* we were piping stderr */
3134         info->err->shut_on_empty = TRUE;
3135         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3136         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3137         _ckvmssts_noperl(iss);
3138   }
3139   _ckvmssts_noperl(sys$setef(pipe_ef));
3140
3141 }
3142
3143 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3144 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3145
3146 /*
3147     we actually differ from vmstrnenv since we use this to
3148     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3149     are pointing to the same thing
3150 */
3151
3152 static unsigned short
3153 popen_translate(pTHX_ char *logical, char *result)
3154 {
3155     int iss;
3156     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3157     $DESCRIPTOR(d_log,"");
3158     struct _il3 {
3159         unsigned short length;
3160         unsigned short code;
3161         char *         buffer_addr;
3162         unsigned short *retlenaddr;
3163     } itmlst[2];
3164     unsigned short l, ifi;
3165
3166     d_log.dsc$a_pointer = logical;
3167     d_log.dsc$w_length  = strlen(logical);
3168
3169     itmlst[0].code = LNM$_STRING;
3170     itmlst[0].length = 255;
3171     itmlst[0].buffer_addr = result;
3172     itmlst[0].retlenaddr = &l;
3173
3174     itmlst[1].code = 0;
3175     itmlst[1].length = 0;
3176     itmlst[1].buffer_addr = 0;
3177     itmlst[1].retlenaddr = 0;
3178
3179     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3180     if (iss == SS$_NOLOGNAM) {
3181         iss = SS$_NORMAL;
3182         l = 0;
3183     }
3184     if (!(iss&1)) lib$signal(iss);
3185     result[l] = '\0';
3186 /*
3187     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
3188     strip it off and return the ifi, if any
3189 */
3190     ifi  = 0;
3191     if (result[0] == 0x1b && result[1] == 0x00) {
3192         memmove(&ifi,result+2,2);
3193         strcpy(result,result+4);
3194     }
3195     return ifi;     /* this is the RMS internal file id */
3196 }
3197
3198 static void pipe_infromchild_ast(pPipe p);
3199
3200 /*
3201     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3202     inside an AST routine without worrying about reentrancy and which Perl
3203     memory allocator is being used.
3204
3205     We read data and queue up the buffers, then spit them out one at a
3206     time to the output mailbox when the output mailbox is ready for one.
3207
3208 */
3209 #define INITIAL_TOCHILDQUEUE  2
3210
3211 static pPipe
3212 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3213 {
3214     pPipe p;
3215     pCBuf b;
3216     char mbx1[64], mbx2[64];
3217     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3218                                       DSC$K_CLASS_S, mbx1},
3219                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3220                                       DSC$K_CLASS_S, mbx2};
3221     unsigned int dviitm = DVI$_DEVBUFSIZ;
3222     int j, n;
3223
3224     n = sizeof(Pipe);
3225     _ckvmssts_noperl(lib$get_vm(&n, &p));
3226
3227     create_mbx(&p->chan_in , &d_mbx1);
3228     create_mbx(&p->chan_out, &d_mbx2);
3229     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3230
3231     p->buf           = 0;
3232     p->shut_on_empty = FALSE;
3233     p->need_wake     = FALSE;
3234     p->type          = 0;
3235     p->retry         = 0;
3236     p->iosb.status   = SS$_NORMAL;
3237     p->iosb2.status  = SS$_NORMAL;
3238     p->free          = RQE_ZERO;
3239     p->wait          = RQE_ZERO;
3240     p->curr          = 0;
3241     p->curr2         = 0;
3242     p->info          = 0;
3243 #ifdef PERL_IMPLICIT_CONTEXT
3244     p->thx           = aTHX;
3245 #endif
3246
3247     n = sizeof(CBuf) + p->bufsize;
3248
3249     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3250         _ckvmssts_noperl(lib$get_vm(&n, &b));
3251         b->buf = (char *) b + sizeof(CBuf);
3252         _ckvmssts_noperl(lib$insqhi(b, &p->free));
3253     }
3254
3255     pipe_tochild2_ast(p);
3256     pipe_tochild1_ast(p);
3257     strcpy(wmbx, mbx1);
3258     strcpy(rmbx, mbx2);
3259     return p;
3260 }
3261
3262 /*  reads the MBX Perl is writing, and queues */
3263
3264 static void
3265 pipe_tochild1_ast(pPipe p)
3266 {
3267     pCBuf b = p->curr;
3268     int iss = p->iosb.status;
3269     int eof = (iss == SS$_ENDOFFILE);
3270     int sts;
3271 #ifdef PERL_IMPLICIT_CONTEXT
3272     pTHX = p->thx;
3273 #endif
3274
3275     if (p->retry) {
3276         if (eof) {
3277             p->shut_on_empty = TRUE;
3278             b->eof     = TRUE;
3279             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3280         } else  {
3281             _ckvmssts_noperl(iss);
3282         }
3283
3284         b->eof  = eof;
3285         b->size = p->iosb.count;
3286         _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3287         if (p->need_wake) {
3288             p->need_wake = FALSE;
3289             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3290         }
3291     } else {
3292         p->retry = 1;   /* initial call */
3293     }
3294
3295     if (eof) {                  /* flush the free queue, return when done */
3296         int n = sizeof(CBuf) + p->bufsize;
3297         while (1) {
3298             iss = lib$remqti(&p->free, &b);
3299             if (iss == LIB$_QUEWASEMP) return;
3300             _ckvmssts_noperl(iss);
3301             _ckvmssts_noperl(lib$free_vm(&n, &b));
3302         }
3303     }
3304
3305     iss = lib$remqti(&p->free, &b);
3306     if (iss == LIB$_QUEWASEMP) {
3307         int n = sizeof(CBuf) + p->bufsize;
3308         _ckvmssts_noperl(lib$get_vm(&n, &b));
3309         b->buf = (char *) b + sizeof(CBuf);
3310     } else {
3311        _ckvmssts_noperl(iss);
3312     }
3313
3314     p->curr = b;
3315     iss = sys$qio(0,p->chan_in,
3316              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3317              &p->iosb,
3318              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3319     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3320     _ckvmssts_noperl(iss);
3321 }
3322
3323
3324 /* writes queued buffers to output, waits for each to complete before
3325    doing the next */
3326
3327 static void
3328 pipe_tochild2_ast(pPipe p)
3329 {
3330     pCBuf b = p->curr2;
3331     int iss = p->iosb2.status;
3332     int n = sizeof(CBuf) + p->bufsize;
3333     int done = (p->info && p->info->done) ||
3334               iss == SS$_CANCEL || iss == SS$_ABORT;
3335 #if defined(PERL_IMPLICIT_CONTEXT)
3336     pTHX = p->thx;
3337 #endif
3338
3339     do {
3340         if (p->type) {         /* type=1 has old buffer, dispose */
3341             if (p->shut_on_empty) {
3342                 _ckvmssts_noperl(lib$free_vm(&n, &b));
3343             } else {
3344                 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3345             }
3346             p->type = 0;
3347         }
3348
3349         iss = lib$remqti(&p->wait, &b);
3350         if (iss == LIB$_QUEWASEMP) {
3351             if (p->shut_on_empty) {
3352                 if (done) {
3353                     _ckvmssts_noperl(sys$dassgn(p->chan_out));
3354                     *p->pipe_done = TRUE;
3355                     _ckvmssts_noperl(sys$setef(pipe_ef));
3356                 } else {
3357                     _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3358                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3359                 }
3360                 return;
3361             }
3362             p->need_wake = TRUE;
3363             return;
3364         }
3365         _ckvmssts_noperl(iss);
3366         p->type = 1;
3367     } while (done);
3368
3369
3370     p->curr2 = b;
3371     if (b->eof) {
3372         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3373             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3374     } else {
3375         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3376             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3377     }
3378
3379     return;
3380
3381 }
3382
3383
3384 static pPipe
3385 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3386 {
3387     pPipe p;
3388     char mbx1[64], mbx2[64];
3389     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3390                                       DSC$K_CLASS_S, mbx1},
3391                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3392                                       DSC$K_CLASS_S, mbx2};
3393     unsigned int dviitm = DVI$_DEVBUFSIZ;
3394
3395     int n = sizeof(Pipe);
3396     _ckvmssts_noperl(lib$get_vm(&n, &p));
3397     create_mbx(&p->chan_in , &d_mbx1);
3398     create_mbx(&p->chan_out, &d_mbx2);
3399
3400     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3401     n = p->bufsize * sizeof(char);
3402     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3403     p->shut_on_empty = FALSE;
3404     p->info   = 0;
3405     p->type   = 0;
3406     p->iosb.status = SS$_NORMAL;
3407 #if defined(PERL_IMPLICIT_CONTEXT)
3408     p->thx = aTHX;
3409 #endif
3410     pipe_infromchild_ast(p);
3411
3412     strcpy(wmbx, mbx1);
3413     strcpy(rmbx, mbx2);
3414     return p;
3415 }
3416
3417 static void
3418 pipe_infromchild_ast(pPipe p)
3419 {
3420     int iss = p->iosb.status;
3421     int eof = (iss == SS$_ENDOFFILE);
3422     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3423     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3424 #if defined(PERL_IMPLICIT_CONTEXT)
3425     pTHX = p->thx;
3426 #endif
3427
3428     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3429         _ckvmssts_noperl(sys$dassgn(p->chan_out));
3430         p->chan_out = 0;
3431     }
3432
3433     /* read completed:
3434             input shutdown if EOF from self (done or shut_on_empty)
3435             output shutdown if closing flag set (my_pclose)
3436             send data/eof from child or eof from self
3437             otherwise, re-read (snarf of data from child)
3438     */
3439
3440     if (p->type == 1) {
3441         p->type = 0;
3442         if (myeof && p->chan_in) {                  /* input shutdown */
3443             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3444             p->chan_in = 0;
3445         }
3446
3447         if (p->chan_out) {
3448             if (myeof || kideof) {      /* pass EOF to parent */
3449                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3450                                          pipe_infromchild_ast, p,
3451                                          0, 0, 0, 0, 0, 0));
3452                 return;
3453             } else if (eof) {       /* eat EOF --- fall through to read*/
3454
3455             } else {                /* transmit data */
3456                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3457                                          pipe_infromchild_ast,p,
3458                                          p->buf, p->iosb.count, 0, 0, 0, 0));
3459                 return;
3460             }
3461         }
3462     }
3463
3464     /*  everything shut? flag as done */
3465
3466     if (!p->chan_in && !p->chan_out) {
3467         *p->pipe_done = TRUE;
3468         _ckvmssts_noperl(sys$setef(pipe_ef));
3469         return;
3470     }
3471
3472     /* write completed (or read, if snarfing from child)
3473             if still have input active,
3474                queue read...immediate mode if shut_on_empty so we get EOF if empty
3475             otherwise,
3476                check if Perl reading, generate EOFs as needed
3477     */
3478
3479     if (p->type == 0) {
3480         p->type = 1;
3481         if (p->chan_in) {
3482             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3483                           pipe_infromchild_ast,p,
3484                           p->buf, p->bufsize, 0, 0, 0, 0);
3485             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3486             _ckvmssts_noperl(iss);
3487         } else {           /* send EOFs for extra reads */
3488             p->iosb.status = SS$_ENDOFFILE;
3489             p->iosb.dvispec = 0;
3490             _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3491                                      0, 0, 0,
3492                                      pipe_infromchild_ast, p, 0, 0, 0, 0));
3493         }
3494     }
3495 }
3496
3497 static pPipe
3498 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3499 {
3500     pPipe p;
3501     char mbx[64];
3502     unsigned long dviitm = DVI$_DEVBUFSIZ;
3503     struct stat s;
3504     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3505                                       DSC$K_CLASS_S, mbx};
3506     int n = sizeof(Pipe);
3507
3508     /* things like terminals and mbx's don't need this filter */
3509     if (fd && fstat(fd,&s) == 0) {
3510         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3511         char device[65];
3512         unsigned short dev_len;
3513         struct dsc$descriptor_s d_dev;
3514         char * cptr;
3515         struct item_list_3 items[3];
3516         int status;
3517         unsigned short dvi_iosb[4];
3518
3519         cptr = getname(fd, out, 1);
3520         if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3521         d_dev.dsc$a_pointer = out;
3522         d_dev.dsc$w_length = strlen(out);
3523         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3524         d_dev.dsc$b_class = DSC$K_CLASS_S;
3525
3526         items[0].len = 4;
3527         items[0].code = DVI$_DEVCHAR;
3528         items[0].bufadr = &devchar;
3529         items[0].retadr = NULL;
3530         items[1].len = 64;
3531         items[1].code = DVI$_FULLDEVNAM;
3532         items[1].bufadr = device;
3533         items[1].retadr = &dev_len;
3534         items[2].len = 0;
3535         items[2].code = 0;
3536
3537         status = sys$getdviw
3538                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3539         _ckvmssts_noperl(status);
3540         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3541             device[dev_len] = 0;
3542
3543             if (!(devchar & DEV$M_DIR)) {
3544                 strcpy(out, device);
3545                 return 0;
3546             }
3547         }
3548     }
3549
3550     _ckvmssts_noperl(lib$get_vm(&n, &p));
3551     p->fd_out = dup(fd);
3552     create_mbx(&p->chan_in, &d_mbx);
3553     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3554     n = (p->bufsize+1) * sizeof(char);
3555     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3556     p->shut_on_empty = FALSE;
3557     p->retry = 0;
3558     p->info  = 0;
3559     strcpy(out, mbx);
3560
3561     _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3562                              pipe_mbxtofd_ast, p,
3563                              p->buf, p->bufsize, 0, 0, 0, 0));
3564
3565     return p;
3566 }
3567
3568 static void
3569 pipe_mbxtofd_ast(pPipe p)
3570 {
3571     int iss = p->iosb.status;
3572     int done = p->info->done;
3573     int iss2;
3574     int eof = (iss == SS$_ENDOFFILE);
3575     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3576     int err = !(iss&1) && !eof;
3577 #if defined(PERL_IMPLICIT_CONTEXT)
3578     pTHX = p->thx;
3579 #endif
3580
3581     if (done && myeof) {               /* end piping */
3582         close(p->fd_out);
3583         sys$dassgn(p->chan_in);
3584         *p->pipe_done = TRUE;
3585         _ckvmssts_noperl(sys$setef(pipe_ef));
3586         return;
3587     }
3588
3589     if (!err && !eof) {             /* good data to send to file */
3590         p->buf[p->iosb.count] = '\n';
3591         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3592         if (iss2 < 0) {
3593             p->retry++;
3594             if (p->retry < MAX_RETRY) {
3595                 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3596                 return;
3597             }
3598         }
3599         p->retry = 0;
3600     } else if (err) {
3601         _ckvmssts_noperl(iss);
3602     }
3603
3604
3605     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3606           pipe_mbxtofd_ast, p,
3607           p->buf, p->bufsize, 0, 0, 0, 0);
3608     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3609     _ckvmssts_noperl(iss);
3610 }
3611
3612
3613 typedef struct _pipeloc     PLOC;
3614 typedef struct _pipeloc*   pPLOC;
3615
3616 struct _pipeloc {
3617     pPLOC   next;
3618     char    dir[NAM$C_MAXRSS+1];
3619 };
3620 static pPLOC  head_PLOC = 0;
3621
3622 void
3623 free_pipelocs(pTHX_ void *head)
3624 {
3625     pPLOC p, pnext;
3626     pPLOC *pHead = (pPLOC *)head;
3627
3628     p = *pHead;
3629     while (p) {
3630         pnext = p->next;
3631         PerlMem_free(p);
3632         p = pnext;
3633     }
3634     *pHead = 0;
3635 }
3636
3637 static void
3638 store_pipelocs(pTHX)
3639 {
3640     int    i;
3641     pPLOC  p;
3642     AV    *av = 0;
3643     SV    *dirsv;
3644     GV    *gv;
3645     char  *dir, *x;
3646     char  *unixdir;
3647     char  temp[NAM$C_MAXRSS+1];
3648     STRLEN n_a;
3649
3650     if (head_PLOC)
3651         free_pipelocs(aTHX_ &head_PLOC);
3652
3653 /*  the . directory from @INC comes last */
3654
3655     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3656     if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3657     p->next = head_PLOC;
3658     head_PLOC = p;
3659     strcpy(p->dir,"./");
3660
3661 /*  get the directory from $^X */
3662
3663     unixdir = PerlMem_malloc(VMS_MAXRSS);
3664     if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3665
3666 #ifdef PERL_IMPLICIT_CONTEXT
3667     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3668 #else
3669     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3670 #endif
3671         strcpy(temp, PL_origargv[0]);
3672         x = strrchr(temp,']');
3673         if (x == NULL) {
3674         x = strrchr(temp,'>');
3675           if (x == NULL) {
3676             /* It could be a UNIX path */
3677             x = strrchr(temp,'/');
3678           }
3679         }
3680         if (x)
3681           x[1] = '\0';
3682         else {
3683           /* Got a bare name, so use default directory */
3684           temp[0] = '.';
3685           temp[1] = '\0';
3686         }
3687
3688         if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3689             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3690             if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3691             p->next = head_PLOC;
3692             head_PLOC = p;
3693             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3694             p->dir[NAM$C_MAXRSS] = '\0';
3695         }
3696     }
3697
3698 /*  reverse order of @INC entries, skip "." since entered above */
3699
3700 #ifdef PERL_IMPLICIT_CONTEXT
3701     if (aTHX)
3702 #endif
3703     if (PL_incgv) av = GvAVn(PL_incgv);
3704
3705     for (i = 0; av && i <= AvFILL(av); i++) {
3706         dirsv = *av_fetch(av,i,TRUE);
3707
3708         if (SvROK(dirsv)) continue;
3709         dir = SvPVx(dirsv,n_a);
3710         if (strcmp(dir,".") == 0) continue;
3711         if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3712             continue;
3713
3714         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3715         p->next = head_PLOC;
3716         head_PLOC = p;
3717         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3718         p->dir[NAM$C_MAXRSS] = '\0';
3719     }
3720
3721 /* most likely spot (ARCHLIB) put first in the list */
3722
3723 #ifdef ARCHLIB_EXP
3724     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3725         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3726         if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3727         p->next = head_PLOC;
3728         head_PLOC = p;
3729         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3730         p->dir[NAM$C_MAXRSS] = '\0';
3731     }
3732 #endif
3733     PerlMem_free(unixdir);
3734 }
3735
3736 static I32
3737 Perl_cando_by_name_int
3738    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3739 #if !defined(PERL_IMPLICIT_CONTEXT)
3740 #define cando_by_name_int               Perl_cando_by_name_int
3741 #else
3742 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3743 #endif
3744
3745 static char *
3746 find_vmspipe(pTHX)
3747 {
3748     static int   vmspipe_file_status = 0;
3749     static char  vmspipe_file[NAM$C_MAXRSS+1];
3750
3751     /* already found? Check and use ... need read+execute permission */
3752
3753     if (vmspipe_file_status == 1) {
3754         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3755          && cando_by_name_int
3756            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3757             return vmspipe_file;
3758         }
3759         vmspipe_file_status = 0;
3760     }
3761
3762     /* scan through stored @INC, $^X */
3763
3764     if (vmspipe_file_status == 0) {
3765         char file[NAM$C_MAXRSS+1];
3766         pPLOC  p = head_PLOC;
3767
3768         while (p) {
3769             char * exp_res;
3770             int dirlen;
3771             strcpy(file, p->dir);
3772             dirlen = strlen(file);
3773             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3774             file[NAM$C_MAXRSS] = '\0';
3775             p = p->next;
3776
3777             exp_res = do_rmsexpand
3778                 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3779             if (!exp_res) continue;
3780
3781             if (cando_by_name_int
3782                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3783              && cando_by_name_int
3784                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3785                 vmspipe_file_status = 1;
3786                 return vmspipe_file;
3787             }
3788         }
3789         vmspipe_file_status = -1;   /* failed, use tempfiles */
3790     }
3791
3792     return 0;
3793 }
3794
3795 static FILE *
3796 vmspipe_tempfile(pTHX)
3797 {
3798     char file[NAM$C_MAXRSS+1];
3799     FILE *fp;
3800     static int index = 0;
3801     Stat_t s0, s1;
3802     int cmp_result;
3803
3804     /* create a tempfile */
3805
3806     /* we can't go from   W, shr=get to  R, shr=get without
3807        an intermediate vulnerable state, so don't bother trying...
3808
3809        and lib$spawn doesn't shr=put, so have to close the write
3810
3811        So... match up the creation date/time and the FID to
3812        make sure we're dealing with the same file
3813
3814     */
3815
3816     index++;
3817     if (!decc_filename_unix_only) {
3818       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3819       fp = fopen(file,"w");
3820       if (!fp) {
3821         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3822         fp = fopen(file,"w");
3823         if (!fp) {
3824             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3825             fp = fopen(file,"w");
3826         }
3827       }
3828      }
3829      else {
3830       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3831       fp = fopen(file,"w");
3832       if (!fp) {
3833         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3834         fp = fopen(file,"w");
3835         if (!fp) {
3836           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3837           fp = fopen(file,"w");
3838         }
3839       }
3840     }
3841     if (!fp) return 0;  /* we're hosed */
3842
3843     fprintf(fp,"$! 'f$verify(0)'\n");
3844     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3845     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3846     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3847     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3848     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3849     fprintf(fp,"$ perl_del    = \"delete\"\n");
3850     fprintf(fp,"$ pif         = \"if\"\n");
3851     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3852     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3853     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3854     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3855     fprintf(fp,"$!  --- build command line to get max possible length\n");
3856     fprintf(fp,"$c=perl_popen_cmd0\n");
3857     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3858     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3859     fprintf(fp,"$x=perl_popen_cmd3\n");
3860     fprintf(fp,"$c=c+x\n");
3861     fprintf(fp,"$ perl_on\n");
3862     fprintf(fp,"$ 'c'\n");
3863     fprintf(fp,"$ perl_status = $STATUS\n");
3864     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3865     fprintf(fp,"$ perl_exit 'perl_status'\n");
3866     fsync(fileno(fp));
3867
3868     fgetname(fp, file, 1);
3869     fstat(fileno(fp), (struct stat *)&s0);
3870     fclose(fp);
3871
3872     if (decc_filename_unix_only)
3873         do_tounixspec(file, file, 0, NULL);
3874     fp = fopen(file,"r","shr=get");
3875     if (!fp) return 0;
3876     fstat(fileno(fp), (struct stat *)&s1);
3877
3878     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3879     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3880         fclose(fp);
3881         return 0;
3882     }
3883
3884     return fp;
3885 }
3886
3887
3888 static int vms_is_syscommand_xterm(void)
3889 {
3890     const static struct dsc$descriptor_s syscommand_dsc =
3891       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3892
3893     const static struct dsc$descriptor_s decwdisplay_dsc =
3894       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3895
3896     struct item_list_3 items[2];
3897     unsigned short dvi_iosb[4];
3898     unsigned long devchar;
3899     unsigned long devclass;
3900     int status;
3901
3902     /* Very simple check to guess if sys$command is a decterm? */
3903     /* First see if the DECW$DISPLAY: device exists */
3904     items[0].len = 4;
3905     items[0].code = DVI$_DEVCHAR;
3906     items[0].bufadr = &devchar;
3907     items[0].retadr = NULL;
3908     items[1].len = 0;
3909     items[1].code = 0;
3910
3911     status = sys$getdviw
3912         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3913
3914     if ($VMS_STATUS_SUCCESS(status)) {
3915         status = dvi_iosb[0];
3916     }
3917
3918     if (!$VMS_STATUS_SUCCESS(status)) {
3919         SETERRNO(EVMSERR, status);
3920         return -1;
3921     }
3922
3923     /* If it does, then for now assume that we are on a workstation */
3924     /* Now verify that SYS$COMMAND is a terminal */
3925     /* for creating the debugger DECTerm */
3926
3927     items[0].len = 4;
3928     items[0].code = DVI$_DEVCLASS;
3929     items[0].bufadr = &devclass;
3930     items[0].retadr = NULL;
3931     items[1].len = 0;
3932     items[1].code = 0;
3933
3934     status = sys$getdviw
3935         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3936
3937     if ($VMS_STATUS_SUCCESS(status)) {
3938         status = dvi_iosb[0];
3939     }
3940
3941     if (!$VMS_STATUS_SUCCESS(status)) {
3942         SETERRNO(EVMSERR, status);
3943         return -1;
3944     }
3945     else {
3946         if (devclass == DC$_TERM) {
3947             return 0;
3948         }
3949     }
3950     return -1;
3951 }
3952
3953 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3954 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3955 {
3956     int status;
3957     int ret_stat;
3958     char * ret_char;
3959     char device_name[65];
3960     unsigned short device_name_len;
3961     struct dsc$descriptor_s customization_dsc;
3962     struct dsc$descriptor_s device_name_dsc;
3963     const char * cptr;
3964     char * tptr;
3965     char customization[200];
3966     char title[40];
3967     pInfo info = NULL;
3968     char mbx1[64];
3969     unsigned short p_chan;
3970     int n;
3971     unsigned short iosb[4];
3972     struct item_list_3 items[2];
3973     const char * cust_str =
3974         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3975     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3976                                           DSC$K_CLASS_S, mbx1};
3977
3978      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3979     /*---------------------------------------*/
3980     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
3981
3982
3983     /* Make sure that this is from the Perl debugger */
3984     ret_char = strstr(cmd," xterm ");
3985     if (ret_char == NULL)
3986         return NULL;
3987     cptr = ret_char + 7;
3988     ret_char = strstr(cmd,"tty");
3989     if (ret_char == NULL)
3990         return NULL;
3991     ret_char = strstr(cmd,"sleep");
3992     if (ret_char == NULL)
3993         return NULL;
3994
3995     if (decw_term_port == 0) {
3996         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3997         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3998         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3999
4000        status = lib$find_image_symbol
4001                                (&filename1_dsc,
4002                                 &decw_term_port_dsc,
4003                                 (void *)&decw_term_port,
4004                                 NULL,
4005                                 0);
4006
4007         /* Try again with the other image name */
4008         if (!$VMS_STATUS_SUCCESS(status)) {
4009
4010            status = lib$find_image_symbol
4011                                (&filename2_dsc,
4012                                 &decw_term_port_dsc,
4013                                 (void *)&decw_term_port,
4014                                 NULL,
4015                                 0);
4016
4017         }
4018
4019     }
4020
4021
4022     /* No decw$term_port, give it up */
4023     if (!$VMS_STATUS_SUCCESS(status))
4024         return NULL;
4025
4026     /* Are we on a workstation? */
4027     /* to do: capture the rows / columns and pass their properties */
4028     ret_stat = vms_is_syscommand_xterm();
4029     if (ret_stat < 0)
4030         return NULL;
4031
4032     /* Make the title: */
4033     ret_char = strstr(cptr,"-title");
4034     if (ret_char != NULL) {
4035         while ((*cptr != 0) && (*cptr != '\"')) {
4036             cptr++;
4037         }
4038         if (*cptr == '\"')
4039             cptr++;
4040         n = 0;
4041         while ((*cptr != 0) && (*cptr != '\"')) {
4042             title[n] = *cptr;
4043             n++;
4044             if (n == 39) {
4045                 title[39] == 0;
4046                 break;
4047             }
4048             cptr++;
4049         }
4050         title[n] = 0;
4051     }
4052     else {
4053             /* Default title */
4054             strcpy(title,"Perl Debug DECTerm");
4055     }
4056     sprintf(customization, cust_str, title);
4057
4058     customization_dsc.dsc$a_pointer = customization;
4059     customization_dsc.dsc$w_length = strlen(customization);
4060     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4061     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
4062
4063     device_name_dsc.dsc$a_pointer = device_name;
4064     device_name_dsc.dsc$w_length = sizeof device_name -1;
4065     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4066     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
4067
4068     device_name_len = 0;
4069
4070     /* Try to create the window */
4071      status = (*decw_term_port)
4072        (NULL,
4073         NULL,
4074         &customization_dsc,
4075         &device_name_dsc,
4076         &device_name_len,
4077         NULL,
4078         NULL,
4079         NULL);
4080     if (!$VMS_STATUS_SUCCESS(status)) {
4081         SETERRNO(EVMSERR, status);
4082         return NULL;
4083     }
4084
4085     device_name[device_name_len] = '\0';
4086
4087     /* Need to set this up to look like a pipe for cleanup */
4088     n = sizeof(Info);
4089     status = lib$get_vm(&n, &info);
4090     if (!$VMS_STATUS_SUCCESS(status)) {
4091         SETERRNO(ENOMEM, status);
4092         return NULL;
4093     }
4094
4095     info->mode = *mode;
4096     info->done = FALSE;
4097     info->completion = 0;
4098     info->closing    = FALSE;
4099     info->in         = 0;
4100     info->out        = 0;
4101     info->err        = 0;
4102     info->fp         = NULL;
4103     info->useFILE    = 0;
4104     info->waiting    = 0;
4105     info->in_done    = TRUE;
4106     info->out_done   = TRUE;
4107     info->err_done   = TRUE;
4108
4109     /* Assign a channel on this so that it will persist, and not login */
4110     /* We stash this channel in the info structure for reference. */
4111     /* The created xterm self destructs when the last channel is removed */
4112     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4113     /* So leave this assigned. */
4114     device_name_dsc.dsc$w_length = device_name_len;
4115     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4116     if (!$VMS_STATUS_SUCCESS(status)) {
4117         SETERRNO(EVMSERR, status);
4118         return NULL;
4119     }
4120     info->xchan_valid = 1;
4121
4122     /* Now create a mailbox to be read by the application */
4123
4124     create_mbx(&p_chan, &d_mbx1);
4125
4126     /* write the name of the created terminal to the mailbox */
4127     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4128             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4129
4130     if (!$VMS_STATUS_SUCCESS(status)) {
4131         SETERRNO(EVMSERR, status);
4132         return NULL;
4133     }
4134
4135     info->fp  = PerlIO_open(mbx1, mode);
4136
4137     /* Done with this channel */
4138     sys$dassgn(p_chan);
4139
4140     /* If any errors, then clean up */
4141     if (!info->fp) {
4142         n = sizeof(Info);
4143         _ckvmssts_noperl(lib$free_vm(&n, &info));
4144         return NULL;
4145         }
4146
4147     /* All done */
4148     return info->fp;
4149 }
4150
4151 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4152
4153 static PerlIO *
4154 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4155 {
4156     static int handler_set_up = FALSE;
4157     PerlIO * ret_fp;
4158     unsigned long int sts, flags = CLI$M_NOWAIT;
4159     /* The use of a GLOBAL table (as was done previously) rendered
4160      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4161      * environment.  Hence we've switched to LOCAL symbol table.
4162      */
4163     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4164     int j, wait = 0, n;
4165     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4166     char *in, *out, *err, mbx[512];
4167     FILE *tpipe = 0;
4168     char tfilebuf[NAM$C_MAXRSS+1];
4169     pInfo info = NULL;
4170     char cmd_sym_name[20];
4171     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4172                                       DSC$K_CLASS_S, symbol};
4173     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4174                                       DSC$K_CLASS_S, 0};
4175     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4176                                       DSC$K_CLASS_S, cmd_sym_name};
4177     struct dsc$descriptor_s *vmscmd;
4178     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4179     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4180     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4181
4182     /* Check here for Xterm create request.  This means looking for
4183      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4184      *  is possible to create an xterm.
4185      */
4186     if (*in_mode == 'r') {
4187         PerlIO * xterm_fd;
4188
4189         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4190         if (xterm_fd != NULL)
4191             return xterm_fd;
4192     }
4193
4194     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4195
4196     /* once-per-program initialization...
4197        note that the SETAST calls and the dual test of pipe_ef
4198        makes sure that only the FIRST thread through here does
4199        the initialization...all other threads wait until it's
4200        done.
4201
4202        Yeah, uglier than a pthread call, it's got all the stuff inline
4203        rather than in a separate routine.
4204     */
4205
4206     if (!pipe_ef) {
4207         _ckvmssts_noperl(sys$setast(0));
4208         if (!pipe_ef) {
4209             unsigned long int pidcode = JPI$_PID;
4210             $DESCRIPTOR(d_delay, RETRY_DELAY);
4211             _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4212             _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4213             _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4214         }
4215         if (!handler_set_up) {
4216           _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4217           handler_set_up = TRUE;
4218         }
4219         _ckvmssts_noperl(sys$setast(1));
4220     }
4221
4222     /* see if we can find a VMSPIPE.COM */
4223
4224     tfilebuf[0] = '@';
4225     vmspipe = find_vmspipe(aTHX);
4226     if (vmspipe) {
4227         strcpy(tfilebuf+1,vmspipe);
4228     } else {        /* uh, oh...we're in tempfile hell */
4229         tpipe = vmspipe_tempfile(aTHX);
4230         if (!tpipe) {       /* a fish popular in Boston */
4231             if (ckWARN(WARN_PIPE)) {
4232                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4233             }
4234         return NULL;
4235         }
4236         fgetname(tpipe,tfilebuf+1,1);
4237     }
4238     vmspipedsc.dsc$a_pointer = tfilebuf;
4239     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4240
4241     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4242     if (!(sts & 1)) {
4243       switch (sts) {
4244         case RMS$_FNF:  case RMS$_DNF:
4245           set_errno(ENOENT); break;
4246         case RMS$_DIR:
4247           set_errno(ENOTDIR); break;
4248         case RMS$_DEV:
4249           set_errno(ENODEV); break;
4250         case RMS$_PRV:
4251           set_errno(EACCES); break;
4252         case RMS$_SYN:
4253           set_errno(EINVAL); break;
4254         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4255           set_errno(E2BIG); break;
4256         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4257           _ckvmssts_noperl(sts); /* fall through */
4258         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4259           set_errno(EVMSERR);
4260       }
4261       set_vaxc_errno(sts);
4262       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4263         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4264       }
4265       *psts = sts;
4266       return NULL;
4267     }
4268     n = sizeof(Info);
4269     _ckvmssts_noperl(lib$get_vm(&n, &info));
4270
4271     strcpy(mode,in_mode);
4272     info->mode = *mode;
4273     info->done = FALSE;
4274     info->completion = 0;
4275     info->closing    = FALSE;
4276     info->in         = 0;
4277     info->out        = 0;
4278     info->err        = 0;
4279     info->fp         = NULL;
4280     info->useFILE    = 0;
4281     info->waiting    = 0;
4282     info->in_done    = TRUE;
4283     info->out_done   = TRUE;
4284     info->err_done   = TRUE;
4285     info->xchan      = 0;
4286     info->xchan_valid = 0;
4287
4288     in = PerlMem_malloc(VMS_MAXRSS);
4289     if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4290     out = PerlMem_malloc(VMS_MAXRSS);
4291     if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4292     err = PerlMem_malloc(VMS_MAXRSS);
4293     if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4294
4295     in[0] = out[0] = err[0] = '\0';
4296
4297     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4298         info->useFILE = 1;
4299         strcpy(p,p+1);
4300     }
4301     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4302         wait = 1;
4303         strcpy(p,p+1);
4304     }
4305
4306     if (*mode == 'r') {             /* piping from subroutine */
4307
4308         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4309         if (info->out) {
4310             info->out->pipe_done = &info->out_done;
4311             info->out_done = FALSE;
4312             info->out->info = info;
4313         }
4314         if (!info->useFILE) {
4315             info->fp  = PerlIO_open(mbx, mode);
4316         } else {
4317             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4318             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4319         }
4320
4321         if (!info->fp && info->out) {
4322             sys$cancel(info->out->chan_out);
4323
4324             while (!info->out_done) {
4325                 int done;
4326                 _ckvmssts_noperl(sys$setast(0));
4327                 done = info->out_done;
4328                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4329                 _ckvmssts_noperl(sys$setast(1));
4330                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4331             }
4332
4333             if (info->out->buf) {
4334                 n = info->out->bufsize * sizeof(char);
4335                 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4336             }
4337             n = sizeof(Pipe);
4338             _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4339             n = sizeof(Info);
4340             _ckvmssts_noperl(lib$free_vm(&n, &info));
4341             *psts = RMS$_FNF;
4342             return NULL;
4343         }
4344
4345         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4346         if (info->err) {
4347             info->err->pipe_done = &info->err_done;
4348             info->err_done = FALSE;
4349             info->err->info = info;
4350         }
4351
4352     } else if (*mode == 'w') {      /* piping to subroutine */
4353
4354         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4355         if (info->out) {
4356             info->out->pipe_done = &info->out_done;
4357             info->out_done = FALSE;
4358             info->out->info = info;
4359         }
4360
4361         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4362         if (info->err) {
4363             info->err->pipe_done = &info->err_done;
4364             info->err_done = FALSE;
4365             info->err->info = info;
4366         }
4367
4368         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4369         if (!info->useFILE) {
4370             info->fp  = PerlIO_open(mbx, mode);
4371         } else {
4372             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4373             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4374         }
4375
4376         if (info->in) {
4377             info->in->pipe_done = &info->in_done;
4378             info->in_done = FALSE;
4379             info->in->info = info;
4380         }
4381
4382         /* error cleanup */
4383         if (!info->fp && info->in) {
4384             info->done = TRUE;
4385             _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4386                                       0, 0, 0, 0, 0, 0, 0, 0));
4387
4388             while (!info->in_done) {
4389                 int done;
4390                 _ckvmssts_noperl(sys$setast(0));
4391                 done = info->in_done;
4392                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4393                 _ckvmssts_noperl(sys$setast(1));
4394                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4395             }
4396
4397             if (info->in->buf) {
4398                 n = info->in->bufsize * sizeof(char);
4399                 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4400             }
4401             n = sizeof(Pipe);
4402             _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4403             n = sizeof(Info);
4404             _ckvmssts_noperl(lib$free_vm(&n, &info));
4405             *psts = RMS$_FNF;
4406             return NULL;
4407         }
4408
4409
4410     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4411         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4412         if (info->out) {
4413             info->out->pipe_done = &info->out_done;
4414             info->out_done = FALSE;
4415             info->out->info = info;
4416         }
4417
4418         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4419         if (info->err) {
4420             info->err->pipe_done = &info->err_done;
4421             info->err_done = FALSE;
4422             info->err->info = info;
4423         }
4424     }
4425
4426     symbol[MAX_DCL_SYMBOL] = '\0';
4427
4428     strncpy(symbol, in, MAX_DCL_SYMBOL);
4429     d_symbol.dsc$w_length = strlen(symbol);
4430     _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4431
4432     strncpy(symbol, err, MAX_DCL_SYMBOL);
4433     d_symbol.dsc$w_length = strlen(symbol);
4434     _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4435
4436     strncpy(symbol, out, MAX_DCL_SYMBOL);
4437     d_symbol.dsc$w_length = strlen(symbol);
4438     _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4439
4440     /* Done with the names for the pipes */
4441     PerlMem_free(err);
4442     PerlMem_free(out);
4443     PerlMem_free(in);
4444
4445     p = vmscmd->dsc$a_pointer;
4446     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4447     if (*p == '$') p++;                         /* remove leading $ */
4448     while (*p == ' ' || *p == '\t') p++;
4449
4450     for (j = 0; j < 4; j++) {
4451         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4452         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4453
4454     strncpy(symbol, p, MAX_DCL_SYMBOL);
4455     d_symbol.dsc$w_length = strlen(symbol);
4456     _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4457
4458         if (strlen(p) > MAX_DCL_SYMBOL) {
4459             p += MAX_DCL_SYMBOL;
4460         } else {
4461             p += strlen(p);
4462         }
4463     }
4464     _ckvmssts_noperl(sys$setast(0));
4465     info->next=open_pipes;  /* prepend to list */
4466     open_pipes=info;
4467     _ckvmssts_noperl(sys$setast(1));
4468     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4469      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4470      * have SYS$COMMAND if we need it.
4471      */
4472     _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4473                       0, &info->pid, &info->completion,
4474                       0, popen_completion_ast,info,0,0,0));
4475
4476     /* if we were using a tempfile, close it now */
4477
4478     if (tpipe) fclose(tpipe);
4479
4480     /* once the subprocess is spawned, it has copied the symbols and
4481        we can get rid of ours */
4482
4483     for (j = 0; j < 4; j++) {
4484         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4485         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4486     _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4487     }
4488     _ckvmssts_noperl(lib$delete_symbol(&d_sym_in,  &table));
4489     _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4490     _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4491     vms_execfree(vmscmd);
4492
4493 #ifdef PERL_IMPLICIT_CONTEXT
4494     if (aTHX)
4495 #endif
4496     PL_forkprocess = info->pid;
4497
4498     ret_fp = info->fp;
4499     if (wait) {
4500          dSAVEDERRNO;
4501          int done = 0;
4502          while (!done) {
4503              _ckvmssts_noperl(sys$setast(0));
4504              done = info->done;
4505              if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4506              _ckvmssts_noperl(sys$setast(1));
4507              if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4508          }
4509         *psts = info->completion;
4510 /* Caller thinks it is open and tries to close it. */
4511 /* This causes some problems, as it changes the error status */
4512 /*        my_pclose(info->fp); */
4513
4514          /* If we did not have a file pointer open, then we have to */
4515          /* clean up here or eventually we will run out of something */
4516          SAVE_ERRNO;
4517          if (info->fp == NULL) {
4518              my_pclose_pinfo(aTHX_ info);
4519          }
4520          RESTORE_ERRNO;
4521
4522     } else {
4523         *psts = info->pid;
4524     }
4525     return ret_fp;
4526 }  /* end of safe_popen */
4527
4528
4529 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4530 PerlIO *
4531 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4532 {
4533     int sts;
4534     TAINT_ENV();
4535     TAINT_PROPER("popen");
4536     PERL_FLUSHALL_FOR_CHILD;
4537     return safe_popen(aTHX_ cmd,mode,&sts);
4538 }
4539
4540 /*}}}*/
4541
4542
4543 /* Routine to close and cleanup a pipe info structure */
4544
4545 static I32 my_pclose_pinfo(pTHX_ pInfo info) {
4546
4547     unsigned long int retsts;
4548     int done, iss, n;
4549     int status;
4550     pInfo next, last;
4551
4552     /* If we were writing to a subprocess, insure that someone reading from
4553      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4554      * produce an EOF record in the mailbox.
4555      *
4556      *  well, at least sometimes it *does*, so we have to watch out for
4557      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4558      */
4559      if (info->fp) {
4560         if (!info->useFILE
4561 #if defined(USE_ITHREADS)
4562           && my_perl
4563 #endif
4564           && PL_perlio_fd_refcnt)
4565             PerlIO_flush(info->fp);
4566         else
4567             fflush((FILE *)info->fp);
4568     }
4569
4570     _ckvmssts(sys$setast(0));
4571      info->closing = TRUE;
4572      done = info->done && info->in_done && info->out_done && info->err_done;
4573      /* hanging on write to Perl's input? cancel it */
4574      if (info->mode == 'r' && info->out && !info->out_done) {
4575         if (info->out->chan_out) {
4576             _ckvmssts(sys$cancel(info->out->chan_out));
4577             if (!info->out->chan_in) {   /* EOF generation, need AST */
4578                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4579             }
4580         }
4581      }
4582      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4583          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4584                            0, 0, 0, 0, 0, 0));
4585     _ckvmssts(sys$setast(1));
4586     if (info->fp) {
4587      if (!info->useFILE
4588 #if defined(USE_ITHREADS)
4589          && my_perl
4590 #endif
4591          && PL_perlio_fd_refcnt)
4592         PerlIO_close(info->fp);
4593      else
4594         fclose((FILE *)info->fp);
4595     }
4596      /*
4597         we have to wait until subprocess completes, but ALSO wait until all
4598         the i/o completes...otherwise we'll be freeing the "info" structure
4599         that the i/o ASTs could still be using...
4600      */
4601
4602      while (!done) {
4603          _ckvmssts(sys$setast(0));
4604          done = info->done && info->in_done && info->out_done && info->err_done;
4605          if (!done) _ckvmssts(sys$clref(pipe_ef));
4606          _ckvmssts(sys$setast(1));
4607          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4608      }
4609      retsts = info->completion;
4610
4611     /* remove from list of open pipes */
4612     _ckvmssts(sys$setast(0));
4613     last = NULL;
4614     for (next = open_pipes; next != NULL; last = next, next = next->next) {
4615         if (next == info)
4616             break;
4617     }
4618
4619     if (last)
4620         last->next = info->next;
4621     else
4622         open_pipes = info->next;
4623     _ckvmssts(sys$setast(1));
4624
4625     /* free buffers and structures */
4626
4627     if (info->in) {
4628         if (info->in->buf) {
4629             n = info->in->bufsize * sizeof(char);
4630             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4631         }
4632         n = sizeof(Pipe);
4633         _ckvmssts(lib$free_vm(&n, &info->in));
4634     }
4635     if (info->out) {
4636         if (info->out->buf) {
4637             n = info->out->bufsize * sizeof(char);
4638             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4639         }
4640         n = sizeof(Pipe);
4641         _ckvmssts(lib$free_vm(&n, &info->out));
4642     }
4643     if (info->err) {
4644         if (info->err->buf) {
4645             n = info->err->bufsize * sizeof(char);
4646             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4647         }
4648         n = sizeof(Pipe);
4649         _ckvmssts(lib$free_vm(&n, &info->err));
4650     }
4651     n = sizeof(Info);
4652     _ckvmssts(lib$free_vm(&n, &info));
4653
4654     return retsts;
4655 }
4656
4657
4658 /*{{{  I32 my_pclose(PerlIO *fp)*/
4659 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4660 {
4661     pInfo info, last = NULL;
4662     I32 ret_status;
4663
4664     /* Fixme - need ast and mutex protection here */
4665     for (info = open_pipes; info != NULL; last = info, info = info->next)
4666         if (info->fp == fp) break;
4667
4668     if (info == NULL) {  /* no such pipe open */
4669       set_errno(ECHILD); /* quoth POSIX */
4670       set_vaxc_errno(SS$_NONEXPR);
4671       return -1;
4672     }
4673
4674     ret_status = my_pclose_pinfo(aTHX_ info);
4675
4676     return ret_status;
4677
4678 }  /* end of my_pclose() */
4679
4680 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4681   /* Roll our own prototype because we want this regardless of whether
4682    * _VMS_WAIT is defined.
4683    */
4684   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4685 #endif
4686 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4687    created with popen(); otherwise partially emulate waitpid() unless
4688    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4689    Also check processes not considered by the CRTL waitpid().
4690  */
4691 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4692 Pid_t
4693 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4694 {
4695     pInfo info;
4696     int done;
4697     int sts;
4698     int j;
4699
4700     if (statusp) *statusp = 0;
4701
4702     for (info = open_pipes; info != NULL; info = info->next)
4703         if (info->pid == pid) break;
4704
4705     if (info != NULL) {  /* we know about this child */
4706       while (!info->done) {
4707           _ckvmssts(sys$setast(0));
4708           done = info->done;
4709           if (!done) _ckvmssts(sys$clref(pipe_ef));
4710           _ckvmssts(sys$setast(1));
4711           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4712       }
4713
4714       if (statusp) *statusp = info->completion;
4715       return pid;
4716     }
4717
4718     /* child that already terminated? */
4719
4720     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4721         if (closed_list[j].pid == pid) {
4722             if (statusp) *statusp = closed_list[j].completion;
4723             return pid;
4724         }
4725     }
4726
4727     /* fall through if this child is not one of our own pipe children */
4728
4729 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4730
4731       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4732        * in 7.2 did we get a version that fills in the VMS completion
4733        * status as Perl has always tried to do.
4734        */
4735
4736       sts = __vms_waitpid( pid, statusp, flags );
4737
4738       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4739          return sts;
4740
4741       /* If the real waitpid tells us the child does not exist, we
4742        * fall through here to implement waiting for a child that
4743        * was created by some means other than exec() (say, spawned
4744        * from DCL) or to wait for a process that is not a subprocess
4745        * of the current process.
4746        */
4747
4748 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4749
4750     {
4751       $DESCRIPTOR(intdsc,"0 00:00:01");
4752       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4753       unsigned long int pidcode = JPI$_PID, mypid;
4754       unsigned long int interval[2];
4755       unsigned int jpi_iosb[2];
4756       struct itmlst_3 jpilist[2] = {
4757           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4758           {                      0,         0,                 0, 0}
4759       };
4760
4761       if (pid <= 0) {
4762         /* Sorry folks, we don't presently implement rooting around for
4763            the first child we can find, and we definitely don't want to
4764            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4765          */
4766         set_errno(ENOTSUP);
4767         return -1;
4768       }
4769
4770       /* Get the owner of the child so I can warn if it's not mine. If the
4771        * process doesn't exist or I don't have the privs to look at it,
4772        * I can go home early.
4773        */
4774       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4775       if (sts & 1) sts = jpi_iosb[0];
4776       if (!(sts & 1)) {
4777         switch (sts) {
4778             case SS$_NONEXPR:
4779                 set_errno(ECHILD);
4780                 break;
4781             case SS$_NOPRIV:
4782                 set_errno(EACCES);
4783                 break;
4784             default:
4785                 _ckvmssts(sts);
4786         }
4787         set_vaxc_errno(sts);
4788         return -1;
4789       }
4790
4791       if (ckWARN(WARN_EXEC)) {
4792         /* remind folks they are asking for non-standard waitpid behavior */
4793         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4794         if (ownerpid != mypid)
4795           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4796                       "waitpid: process %x is not a child of process %x",
4797                       pid,mypid);
4798       }
4799
4800       /* simply check on it once a second until it's not there anymore. */
4801
4802       _ckvmssts(sys$bintim(&intdsc,interval));
4803       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4804             _ckvmssts(sys$schdwk(0,0,interval,0));
4805             _ckvmssts(sys$hiber());
4806       }
4807       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4808
4809       _ckvmssts(sts);
4810       return pid;
4811     }
4812 }  /* end of waitpid() */
4813 /*}}}*/
4814 /*}}}*/
4815 /*}}}*/
4816
4817 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4818 char *
4819 my_gconvert(double val, int ndig, int trail, char *buf)
4820 {
4821   static char __gcvtbuf[DBL_DIG+1];
4822   char *loc;
4823
4824   loc = buf ? buf : __gcvtbuf;
4825
4826 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4827   if (val < 1) {
4828     sprintf(loc,"%.*g",ndig,val);
4829     return loc;
4830   }
4831 #endif
4832
4833   if (val) {
4834     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4835     return gcvt(val,ndig,loc);
4836   }
4837   else {
4838     loc[0] = '0'; loc[1] = '\0';
4839     return loc;
4840   }
4841
4842 }
4843 /*}}}*/
4844
4845 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4846 static int rms_free_search_context(struct FAB * fab)
4847 {
4848 struct NAM * nam;
4849
4850     nam = fab->fab$l_nam;
4851     nam->nam$b_nop |= NAM$M_SYNCHK;
4852     nam->nam$l_rlf = NULL;
4853     fab->fab$b_dns = 0;
4854     return sys$parse(fab, NULL, NULL);
4855 }
4856
4857 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4858 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4859 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4860 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4861 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4862 #define rms_nam_esll(nam) nam.nam$b_esl
4863 #define rms_nam_esl(nam) nam.nam$b_esl
4864 #define rms_nam_name(nam) nam.nam$l_name
4865 #define rms_nam_namel(nam) nam.nam$l_name
4866 #define rms_nam_type(nam) nam.nam$l_type
4867 #define rms_nam_typel(nam) nam.nam$l_type
4868 #define rms_nam_ver(nam) nam.nam$l_ver
4869 #define rms_nam_verl(nam) nam.nam$l_ver
4870 #define rms_nam_rsll(nam) nam.nam$b_rsl
4871 #define rms_nam_rsl(nam) nam.nam$b_rsl
4872 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4873 #define rms_set_fna(fab, nam, name, size) \
4874         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4875 #define rms_get_fna(fab, nam) fab.fab$l_fna
4876 #define rms_set_dna(fab, nam, name, size) \
4877         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4878 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4879 #define rms_set_esa(nam, name, size) \
4880         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4881 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4882         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4883 #define rms_set_rsa(nam, name, size) \
4884         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4885 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4886         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4887 #define rms_nam_name_type_l_size(nam) \
4888         (nam.nam$b_name + nam.nam$b_type)
4889 #else
4890 static int rms_free_search_context(struct FAB * fab)
4891 {
4892 struct NAML * nam;
4893
4894     nam = fab->fab$l_naml;
4895     nam->naml$b_nop |= NAM$M_SYNCHK;
4896     nam->naml$l_rlf = NULL;
4897     nam->naml$l_long_defname_size = 0;
4898
4899     fab->fab$b_dns = 0;
4900     return sys$parse(fab, NULL, NULL);
4901 }
4902
4903 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4904 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4905 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4906 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4907 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4908 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4909 #define rms_nam_esl(nam) nam.naml$b_esl
4910 #define rms_nam_name(nam) nam.naml$l_name
4911 #define rms_nam_namel(nam) nam.naml$l_long_name
4912 #define rms_nam_type(nam) nam.naml$l_type
4913 #define rms_nam_typel(nam) nam.naml$l_long_type
4914 #define rms_nam_ver(nam) nam.naml$l_ver
4915 #define rms_nam_verl(nam) nam.naml$l_long_ver
4916 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4917 #define rms_nam_rsl(nam) nam.naml$b_rsl
4918 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4919 #define rms_set_fna(fab, nam, name, size) \
4920         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4921         nam.naml$l_long_filename_size = size; \
4922         nam.naml$l_long_filename = name;}
4923 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4924 #define rms_set_dna(fab, nam, name, size) \
4925         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4926         nam.naml$l_long_defname_size = size; \
4927         nam.naml$l_long_defname = name; }
4928 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4929 #define rms_set_esa(nam, name, size) \
4930         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4931         nam.naml$l_long_expand_alloc = size; \
4932         nam.naml$l_long_expand = name; }
4933 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4934         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4935         nam.naml$l_long_expand = l_name; \
4936         nam.naml$l_long_expand_alloc = l_size; }
4937 #define rms_set_rsa(nam, name, size) \
4938         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4939         nam.naml$l_long_result = name; \
4940         nam.naml$l_long_result_alloc = size; }
4941 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4942         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4943         nam.naml$l_long_result = l_name; \
4944         nam.naml$l_long_result_alloc = l_size; }
4945 #define rms_nam_name_type_l_size(nam) \
4946         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4947 #endif
4948
4949
4950 /* rms_erase
4951  * The CRTL for 8.3 and later can create symbolic links in any mode,
4952  * however in 8.3 the unlink/remove/delete routines will only properly handle
4953  * them if one of the PCP modes is active.
4954  */
4955 static int rms_erase(const char * vmsname)
4956 {
4957   int status;
4958   struct FAB myfab = cc$rms_fab;
4959   rms_setup_nam(mynam);
4960
4961   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4962   rms_bind_fab_nam(myfab, mynam);
4963
4964   /* Are we removing all versions? */
4965   if (vms_unlink_all_versions == 1) {
4966     const char * defspec = ";*";
4967     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4968   }
4969
4970 #ifdef NAML$M_OPEN_SPECIAL
4971   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4972 #endif
4973
4974   status = sys$erase(&myfab, 0, 0);
4975
4976   return status;
4977 }
4978
4979
4980 static int
4981 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4982                     const struct dsc$descriptor_s * vms_dst_dsc,
4983                     unsigned long flags)
4984 {
4985     /*  VMS and UNIX handle file permissions differently and the
4986      * the same ACL trick may be needed for renaming files,
4987      * especially if they are directories.
4988      */
4989
4990    /* todo: get kill_file and rename to share common code */
4991    /* I can not find online documentation for $change_acl
4992     * it appears to be replaced by $set_security some time ago */
4993
4994 const unsigned int access_mode = 0;
4995 $DESCRIPTOR(obj_file_dsc,"FILE");
4996 char *vmsname;
4997 char *rslt;
4998 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
4999 int aclsts, fndsts, rnsts = -1;
5000 unsigned int ctx = 0;
5001 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5002 struct dsc$descriptor_s * clean_dsc;
5003
5004 struct myacedef {
5005     unsigned char myace$b_length;
5006     unsigned char myace$b_type;
5007     unsigned short int myace$w_flags;
5008     unsigned long int myace$l_access;
5009     unsigned long int myace$l_ident;
5010 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
5011              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
5012              0},
5013              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
5014
5015 struct item_list_3
5016         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
5017                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
5018                       {0,0,0,0}},
5019         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
5020         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
5021                      {0,0,0,0}};
5022
5023
5024     /* Expand the input spec using RMS, since we do not want to put
5025      * ACLs on the target of a symbolic link */
5026     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
5027     if (vmsname == NULL)
5028         return SS$_INSFMEM;
5029
5030     rslt = do_rmsexpand(vms_src_dsc->dsc$a_pointer,
5031                         vmsname,
5032                         0,
5033                         NULL,
5034                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
5035                         NULL,
5036                         NULL);
5037     if (rslt == NULL) {
5038         PerlMem_free(vmsname);
5039         return SS$_INSFMEM;
5040     }
5041
5042     /* So we get our own UIC to use as a rights identifier,
5043      * and the insert an ACE at the head of the ACL which allows us
5044      * to delete the file.
5045      */
5046     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
5047
5048     fildsc.dsc$w_length = strlen(vmsname);
5049     fildsc.dsc$a_pointer = vmsname;
5050     ctx = 0;
5051     newace.myace$l_ident = oldace.myace$l_ident;
5052     rnsts = SS$_ABORT;
5053
5054     /* Grab any existing ACEs with this identifier in case we fail */
5055     clean_dsc = &fildsc;
5056     aclsts = fndsts = sys$get_security(&obj_file_dsc,
5057                                &fildsc,
5058                                NULL,
5059                                OSS$M_WLOCK,
5060                                findlst,
5061                                &ctx,
5062                                &access_mode);
5063
5064     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
5065         /* Add the new ACE . . . */
5066
5067         /* if the sys$get_security succeeded, then ctx is valid, and the
5068          * object/file descriptors will be ignored.  But otherwise they
5069          * are needed
5070          */
5071         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
5072                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
5073         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5074             set_errno(EVMSERR);
5075             set_vaxc_errno(aclsts);
5076             PerlMem_free(vmsname);
5077             return aclsts;
5078         }
5079
5080         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5081                                 NULL, NULL,
5082                                 &flags,
5083                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5084
5085         if ($VMS_STATUS_SUCCESS(rnsts)) {
5086             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5087         }
5088
5089         /* Put things back the way they were. */
5090         ctx = 0;
5091         aclsts = sys$get_security(&obj_file_dsc,
5092                                   clean_dsc,
5093                                   NULL,
5094                                   OSS$M_WLOCK,
5095                                   findlst,
5096                                   &ctx,
5097                                   &access_mode);
5098
5099         if ($VMS_STATUS_SUCCESS(aclsts)) {
5100         int sec_flags;
5101
5102             sec_flags = 0;
5103             if (!$VMS_STATUS_SUCCESS(fndsts))
5104                 sec_flags = OSS$M_RELCTX;
5105
5106             /* Get rid of the new ACE */
5107             aclsts = sys$set_security(NULL, NULL, NULL,
5108                                   sec_flags, dellst, &ctx, &access_mode);
5109
5110             /* If there was an old ACE, put it back */
5111             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5112                 addlst[0].bufadr = &oldace;
5113                 aclsts = sys$set_security(NULL, NULL, NULL,
5114                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
5115                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5116                     set_errno(EVMSERR);
5117                     set_vaxc_errno(aclsts);
5118                     rnsts = aclsts;
5119                 }
5120             } else {
5121             int aclsts2;
5122
5123                 /* Try to clear the lock on the ACL list */
5124                 aclsts2 = sys$set_security(NULL, NULL, NULL,
5125                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
5126
5127                 /* Rename errors are most important */
5128                 if (!$VMS_STATUS_SUCCESS(rnsts))
5129                     aclsts = rnsts;
5130                 set_errno(EVMSERR);
5131                 set_vaxc_errno(aclsts);
5132                 rnsts = aclsts;
5133             }
5134         }
5135         else {
5136             if (aclsts != SS$_ACLEMPTY)
5137                 rnsts = aclsts;
5138         }
5139     }
5140     else
5141         rnsts = fndsts;
5142
5143     PerlMem_free(vmsname);
5144     return rnsts;
5145 }
5146
5147
5148 /*{{{int rename(const char *, const char * */
5149 /* Not exactly what X/Open says to do, but doing it absolutely right
5150  * and efficiently would require a lot more work.  This should be close
5151  * enough to pass all but the most strict X/Open compliance test.
5152  */
5153 int
5154 Perl_rename(pTHX_ const char *src, const char * dst)
5155 {
5156 int retval;
5157 int pre_delete = 0;
5158 int src_sts;
5159 int dst_sts;
5160 Stat_t src_st;
5161 Stat_t dst_st;
5162
5163     /* Validate the source file */
5164     src_sts = flex_lstat(src, &src_st);
5165     if (src_sts != 0) {
5166
5167         /* No source file or other problem */
5168         return src_sts;
5169     }
5170
5171     dst_sts = flex_lstat(dst, &dst_st);
5172     if (dst_sts == 0) {
5173
5174         if (dst_st.st_dev != src_st.st_dev) {
5175             /* Must be on the same device */
5176             errno = EXDEV;
5177             return -1;
5178         }
5179
5180         /* VMS_INO_T_COMPARE is true if the inodes are different
5181          * to match the output of memcmp
5182          */
5183
5184         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5185             /* That was easy, the files are the same! */
5186             return 0;
5187         }
5188
5189         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5190             /* If source is a directory, so must be dest */
5191                 errno = EISDIR;
5192                 return -1;
5193         }
5194
5195     }
5196
5197
5198     if ((dst_sts == 0) &&
5199         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5200
5201         /* We have issues here if vms_unlink_all_versions is set
5202          * If the destination exists, and is not a directory, then
5203          * we must delete in advance.
5204          *
5205          * If the src is a directory, then we must always pre-delete
5206          * the destination.
5207          *
5208          * If we successfully delete the dst in advance, and the rename fails
5209          * X/Open requires that errno be EIO.
5210          *
5211          */
5212
5213         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5214             int d_sts;
5215             d_sts = mp_do_kill_file(aTHX_ dst, S_ISDIR(dst_st.st_mode));
5216             if (d_sts != 0)
5217                 return d_sts;
5218
5219             /* We killed the destination, so only errno now is EIO */
5220             pre_delete = 1;
5221         }
5222     }
5223
5224     /* Originally the idea was to call the CRTL rename() and only
5225      * try the lib$rename_file if it failed.
5226      * It turns out that there are too many variants in what the
5227      * the CRTL rename might do, so only use lib$rename_file
5228      */
5229     retval = -1;
5230
5231     {
5232         /* Is the source and dest both in VMS format */
5233         /* if the source is a directory, then need to fileify */
5234         /*  and dest must be a directory or non-existant. */
5235
5236         char * vms_src;
5237         char * vms_dst;
5238         int sts;
5239         char * ret_str;
5240         unsigned long flags;
5241         struct dsc$descriptor_s old_file_dsc;
5242         struct dsc$descriptor_s new_file_dsc;
5243
5244         /* We need to modify the src and dst depending
5245          * on if one or more of them are directories.
5246          */
5247
5248         vms_src = PerlMem_malloc(VMS_MAXRSS);
5249         if (vms_src == NULL)
5250             _ckvmssts_noperl(SS$_INSFMEM);
5251
5252         /* Source is always a VMS format file */
5253         ret_str = do_tovmsspec(src, vms_src, 0, NULL);
5254         if (ret_str == NULL) {
5255             PerlMem_free(vms_src);
5256             errno = EIO;
5257             return -1;
5258         }
5259
5260         vms_dst = PerlMem_malloc(VMS_MAXRSS);
5261         if (vms_dst == NULL)
5262             _ckvmssts_noperl(SS$_INSFMEM);
5263
5264         if (S_ISDIR(src_st.st_mode)) {
5265         char * ret_str;
5266         char * vms_dir_file;
5267
5268             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5269             if (vms_dir_file == NULL)
5270                 _ckvmssts_noperl(SS$_INSFMEM);
5271
5272             /* The source must be a file specification */
5273             ret_str = do_fileify_dirspec(vms_src, vms_dir_file, 0, NULL);
5274             if (ret_str == NULL) {
5275                 PerlMem_free(vms_src);
5276                 PerlMem_free(vms_dst);
5277                 PerlMem_free(vms_dir_file);
5278                 errno = EIO;
5279                 return -1;
5280             }
5281             PerlMem_free(vms_src);
5282             vms_src = vms_dir_file;
5283
5284             /* If the dest is a directory, we must remove it
5285             if (dst_sts == 0) {
5286                 int d_sts;
5287                 d_sts = mp_do_kill_file(aTHX_ dst, 1);
5288                 if (d_sts != 0) {
5289                     PerlMem_free(vms_src);
5290                     PerlMem_free(vms_dst);
5291                     errno = EIO;
5292                     return sts;
5293                 }
5294
5295                 pre_delete = 1;
5296             }
5297
5298            /* The dest must be a VMS file specification */
5299            ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
5300            if (ret_str == NULL) {
5301                 PerlMem_free(vms_src);
5302                 PerlMem_free(vms_dst);
5303                 errno = EIO;
5304                 return -1;
5305            }
5306
5307             /* The source must be a file specification */
5308             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5309             if (vms_dir_file == NULL)
5310                 _ckvmssts_noperl(SS$_INSFMEM);
5311
5312             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5313             if (ret_str == NULL) {
5314                 PerlMem_free(vms_src);
5315                 PerlMem_free(vms_dst);
5316                 PerlMem_free(vms_dir_file);
5317                 errno = EIO;
5318                 return -1;
5319             }
5320             PerlMem_free(vms_dst);
5321             vms_dst = vms_dir_file;
5322
5323         } else {
5324             /* File to file or file to new dir */
5325
5326             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5327                 /* VMS pathify a dir target */
5328                 ret_str = do_tovmspath(dst, vms_dst, 0, NULL);
5329                 if (ret_str == NULL) {
5330                     PerlMem_free(vms_src);
5331                     PerlMem_free(vms_dst);
5332                     errno = EIO;
5333                     return -1;
5334                 }
5335             } else {
5336
5337                 /* fileify a target VMS file specification */
5338                 ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
5339                 if (ret_str == NULL) {
5340                     PerlMem_free(vms_src);
5341                     PerlMem_free(vms_dst);
5342                     errno = EIO;
5343                     return -1;
5344                 }
5345             }
5346         }
5347
5348         old_file_dsc.dsc$a_pointer = vms_src;
5349         old_file_dsc.dsc$w_length = strlen(vms_src);
5350         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5351         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5352
5353         new_file_dsc.dsc$a_pointer = vms_dst;
5354         new_file_dsc.dsc$w_length = strlen(vms_dst);
5355         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5356         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5357
5358         flags = 0;
5359 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5360         flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5361 #endif
5362
5363         sts = lib$rename_file(&old_file_dsc,
5364                               &new_file_dsc,
5365                               NULL, NULL,
5366                               &flags,
5367                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5368         if (!$VMS_STATUS_SUCCESS(sts)) {
5369
5370            /* We could have failed because VMS style permissions do not
5371             * permit renames that UNIX will allow.  Just like the hack
5372             * in for kill_file.
5373             */
5374            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5375         }
5376
5377         PerlMem_free(vms_src);
5378         PerlMem_free(vms_dst);
5379         if (!$VMS_STATUS_SUCCESS(sts)) {
5380             errno = EIO;
5381             return -1;
5382         }
5383         retval = 0;
5384     }
5385
5386     if (vms_unlink_all_versions) {
5387         /* Now get rid of any previous versions of the source file that
5388          * might still exist
5389          */
5390         int save_errno;
5391         save_errno = errno;
5392         src_sts = mp_do_kill_file(aTHX_ src, S_ISDIR(src_st.st_mode));
5393         errno = save_errno;
5394     }
5395
5396     /* We deleted the destination, so must force the error to be EIO */
5397     if ((retval != 0) && (pre_delete != 0))
5398         errno = EIO;
5399
5400     return retval;
5401 }
5402 /*}}}*/
5403
5404
5405 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5406 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5407  * to expand file specification.  Allows for a single default file
5408  * specification and a simple mask of options.  If outbuf is non-NULL,
5409  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5410  * the resultant file specification is placed.  If outbuf is NULL, the
5411  * resultant file specification is placed into a static buffer.
5412  * The third argument, if non-NULL, is taken to be a default file
5413  * specification string.  The fourth argument is unused at present.
5414  * rmesexpand() returns the address of the resultant string if
5415  * successful, and NULL on error.
5416  *
5417  * New functionality for previously unused opts value:
5418  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5419  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5420  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5421  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5422  */
5423 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5424
5425 static char *
5426 mp_do_rmsexpand
5427    (pTHX_ const char *filespec,
5428     char *outbuf,
5429     int ts,
5430     const char *defspec,
5431     unsigned opts,
5432     int * fs_utf8,
5433     int * dfs_utf8)
5434 {
5435   static char __rmsexpand_retbuf[VMS_MAXRSS];
5436   char * vmsfspec, *tmpfspec;
5437   char * esa, *cp, *out = NULL;
5438   char * tbuf;
5439   char * esal = NULL;
5440   char * outbufl;
5441   struct FAB myfab = cc$rms_fab;
5442   rms_setup_nam(mynam);
5443   STRLEN speclen;
5444   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5445   int sts;
5446
5447   /* temp hack until UTF8 is actually implemented */
5448   if (fs_utf8 != NULL)
5449     *fs_utf8 = 0;
5450
5451   if (!filespec || !*filespec) {
5452     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5453     return NULL;
5454   }
5455   if (!outbuf) {
5456     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
5457     else    outbuf = __rmsexpand_retbuf;
5458   }
5459
5460   vmsfspec = NULL;
5461   tmpfspec = NULL;
5462   outbufl = NULL;
5463
5464   isunix = 0;
5465   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5466     isunix = is_unix_filespec(filespec);
5467     if (isunix) {
5468       vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5469       if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5470       if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
5471         PerlMem_free(vmsfspec);
5472         if (out)
5473            Safefree(out);
5474         return NULL;
5475       }
5476       filespec = vmsfspec;
5477
5478       /* Unless we are forcing to VMS format, a UNIX input means
5479        * UNIX output, and that requires long names to be used
5480        */
5481 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5482       if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5483         opts |= PERL_RMSEXPAND_M_LONG;
5484       else
5485 #endif
5486         isunix = 0;
5487       }
5488     }
5489
5490   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
5491   rms_bind_fab_nam(myfab, mynam);
5492
5493   if (defspec && *defspec) {
5494     int t_isunix;
5495     t_isunix = is_unix_filespec(defspec);
5496     if (t_isunix) {
5497       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5498       if (tmpfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5499       if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
5500         PerlMem_free(tmpfspec);
5501         if (vmsfspec != NULL)
5502             PerlMem_free(vmsfspec);
5503         if (out)
5504            Safefree(out);
5505         return NULL;
5506       }
5507       defspec = tmpfspec;
5508     }
5509     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
5510   }
5511
5512   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5513   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5514 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5515   esal = PerlMem_malloc(VMS_MAXRSS);
5516   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5517 #endif
5518   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5519
5520   /* If a NAML block is used RMS always writes to the long and short
5521    * addresses unless you suppress the short name.
5522    */
5523 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5524   outbufl = PerlMem_malloc(VMS_MAXRSS);
5525   if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5526 #endif
5527    rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5528
5529 #ifdef NAM$M_NO_SHORT_UPCASE
5530   if (decc_efs_case_preserve)
5531     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5532 #endif
5533
5534    /* We may not want to follow symbolic links */
5535 #ifdef NAML$M_OPEN_SPECIAL
5536   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5537     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5538 #endif
5539
5540   /* First attempt to parse as an existing file */
5541   retsts = sys$parse(&myfab,0,0);
5542   if (!(retsts & STS$K_SUCCESS)) {
5543
5544     /* Could not find the file, try as syntax only if error is not fatal */
5545     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5546     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
5547       retsts = sys$parse(&myfab,0,0);
5548       if (retsts & STS$K_SUCCESS) goto expanded;
5549     }
5550
5551      /* Still could not parse the file specification */
5552     /*----------------------------------------------*/
5553     sts = rms_free_search_context(&myfab); /* Free search context */
5554     if (out) Safefree(out);
5555     if (tmpfspec != NULL)
5556         PerlMem_free(tmpfspec);
5557     if (vmsfspec != NULL)
5558         PerlMem_free(vmsfspec);
5559     if (outbufl != NULL)
5560         PerlMem_free(outbufl);
5561     PerlMem_free(esa);
5562     if (esal != NULL)
5563         PerlMem_free(esal);
5564     set_vaxc_errno(retsts);
5565     if      (retsts == RMS$_PRV) set_errno(EACCES);
5566     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5567     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5568     else                         set_errno(EVMSERR);
5569     return NULL;
5570   }
5571   retsts = sys$search(&myfab,0,0);
5572   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5573     sts = rms_free_search_context(&myfab); /* Free search context */
5574     if (out) Safefree(out);
5575     if (tmpfspec != NULL)
5576         PerlMem_free(tmpfspec);
5577     if (vmsfspec != NULL)
5578         PerlMem_free(vmsfspec);
5579     if (outbufl != NULL)
5580         PerlMem_free(outbufl);
5581     PerlMem_free(esa);
5582     if (esal != NULL)
5583         PerlMem_free(esal);
5584     set_vaxc_errno(retsts);
5585     if      (retsts == RMS$_PRV) set_errno(EACCES);
5586     else                         set_errno(EVMSERR);
5587     return NULL;
5588   }
5589
5590   /* If the input filespec contained any lowercase characters,
5591    * downcase the result for compatibility with Unix-minded code. */
5592   expanded:
5593   if (!decc_efs_case_preserve) {
5594     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5595       if (islower(*tbuf)) { haslower = 1; break; }
5596   }
5597
5598    /* Is a long or a short name expected */
5599   /*------------------------------------*/
5600   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5601     if (rms_nam_rsll(mynam)) {
5602         tbuf = outbufl;
5603         speclen = rms_nam_rsll(mynam);
5604     }
5605     else {
5606         tbuf = esal; /* Not esa */
5607         speclen = rms_nam_esll(mynam);
5608     }
5609   }
5610   else {
5611     if (rms_nam_rsl(mynam)) {
5612         tbuf = outbuf;
5613         speclen = rms_nam_rsl(mynam);
5614     }
5615     else {
5616         tbuf = esa; /* Not esal */
5617         speclen = rms_nam_esl(mynam);
5618     }
5619   }
5620   tbuf[speclen] = '\0';
5621
5622   /* Trim off null fields added by $PARSE
5623    * If type > 1 char, must have been specified in original or default spec
5624    * (not true for version; $SEARCH may have added version of existing file).
5625    */
5626   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5627   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5628     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5629              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5630   }
5631   else {
5632     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5633              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5634   }
5635   if (trimver || trimtype) {
5636     if (defspec && *defspec) {
5637       char *defesal = NULL;
5638       char *defesa = NULL;
5639       defesa = PerlMem_malloc(VMS_MAXRSS + 1);
5640       if (defesa != NULL) {
5641 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5642         defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5643         if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5644 #endif
5645         struct FAB deffab = cc$rms_fab;
5646         rms_setup_nam(defnam);
5647
5648         rms_bind_fab_nam(deffab, defnam);
5649
5650         /* Cast ok */
5651         rms_set_fna
5652             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5653
5654         /* RMS needs the esa/esal as a work area if wildcards are involved */
5655         rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5656
5657         rms_clear_nam_nop(defnam);
5658         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5659 #ifdef NAM$M_NO_SHORT_UPCASE
5660         if (decc_efs_case_preserve)
5661           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5662 #endif
5663 #ifdef NAML$M_OPEN_SPECIAL
5664         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5665           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5666 #endif
5667         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5668           if (trimver) {
5669              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5670           }
5671           if (trimtype) {
5672             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5673           }
5674         }
5675         if (defesal != NULL)
5676             PerlMem_free(defesal);
5677         PerlMem_free(defesa);
5678       }
5679     }
5680     if (trimver) {
5681       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5682         if (*(rms_nam_verl(mynam)) != '\"')
5683           speclen = rms_nam_verl(mynam) - tbuf;
5684       }
5685       else {
5686         if (*(rms_nam_ver(mynam)) != '\"')
5687           speclen = rms_nam_ver(mynam) - tbuf;
5688       }
5689     }
5690     if (trimtype) {
5691       /* If we didn't already trim version, copy down */
5692       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5693         if (speclen > rms_nam_verl(mynam) - tbuf)
5694           memmove
5695            (rms_nam_typel(mynam),
5696             rms_nam_verl(mynam),
5697             speclen - (rms_nam_verl(mynam) - tbuf));
5698           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5699       }
5700       else {
5701         if (speclen > rms_nam_ver(mynam) - tbuf)
5702           memmove
5703            (rms_nam_type(mynam),
5704             rms_nam_ver(mynam),
5705             speclen - (rms_nam_ver(mynam) - tbuf));
5706           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5707       }
5708     }
5709   }
5710
5711    /* Done with these copies of the input files */
5712   /*-------------------------------------------*/
5713   if (vmsfspec != NULL)
5714         PerlMem_free(vmsfspec);
5715   if (tmpfspec != NULL)
5716         PerlMem_free(tmpfspec);
5717
5718   /* If we just had a directory spec on input, $PARSE "helpfully"
5719    * adds an empty name and type for us */
5720 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5721   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5722     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5723         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5724         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5725       speclen = rms_nam_namel(mynam) - tbuf;
5726   }
5727   else
5728 #endif
5729   {
5730     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5731         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5732         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5733       speclen = rms_nam_name(mynam) - tbuf;
5734   }
5735
5736   /* Posix format specifications must have matching quotes */
5737   if (speclen < (VMS_MAXRSS - 1)) {
5738     if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
5739       if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
5740         tbuf[speclen] = '\"';
5741         speclen++;
5742       }
5743     }
5744   }
5745   tbuf[speclen] = '\0';
5746   if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
5747
5748   /* Have we been working with an expanded, but not resultant, spec? */
5749   /* Also, convert back to Unix syntax if necessary. */
5750   {
5751   int rsl;
5752
5753 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5754     if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5755       rsl = rms_nam_rsll(mynam);
5756     } else
5757 #endif
5758     {
5759       rsl = rms_nam_rsl(mynam);
5760     }
5761     if (!rsl) {
5762       if (isunix) {
5763         if (do_tounixspec(tbuf, outbuf ,0 , fs_utf8) == NULL) {
5764           if (out) Safefree(out);
5765           if (esal != NULL)
5766             PerlMem_free(esal);
5767           PerlMem_free(esa);
5768           if (outbufl != NULL)
5769             PerlMem_free(outbufl);
5770           return NULL;
5771         }
5772       }
5773       else strcpy(outbuf, tbuf);
5774     }
5775     else if (isunix) {
5776       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5777       if (tmpfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5778       if (do_tounixspec(tbuf,tmpfspec,0,fs_utf8) == NULL) {
5779         if (out) Safefree(out);
5780         PerlMem_free(esa);
5781         if (esal != NULL)
5782             PerlMem_free(esal);
5783         PerlMem_free(tmpfspec);
5784         if (outbufl != NULL)
5785             PerlMem_free(outbufl);
5786         return NULL;
5787       }
5788       strcpy(outbuf,tmpfspec);
5789       PerlMem_free(tmpfspec);
5790     }
5791   }
5792   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5793   sts = rms_free_search_context(&myfab); /* Free search context */
5794   PerlMem_free(esa);
5795   if (esal != NULL)
5796      PerlMem_free(esal);
5797   if (outbufl != NULL)
5798      PerlMem_free(outbufl);
5799   return outbuf;
5800 }
5801 /*}}}*/
5802 /* External entry points */
5803 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5804 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5805 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5806 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5807 char *Perl_rmsexpand_utf8
5808   (pTHX_ const char *spec, char *buf, const char *def,
5809    unsigned opt, int * fs_utf8, int * dfs_utf8)
5810 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5811 char *Perl_rmsexpand_utf8_ts
5812   (pTHX_ const char *spec, char *buf, const char *def,
5813    unsigned opt, int * fs_utf8, int * dfs_utf8)
5814 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5815
5816
5817 /*
5818 ** The following routines are provided to make life easier when
5819 ** converting among VMS-style and Unix-style directory specifications.
5820 ** All will take input specifications in either VMS or Unix syntax. On
5821 ** failure, all return NULL.  If successful, the routines listed below
5822 ** return a pointer to a buffer containing the appropriately
5823 ** reformatted spec (and, therefore, subsequent calls to that routine
5824 ** will clobber the result), while the routines of the same names with
5825 ** a _ts suffix appended will return a pointer to a mallocd string
5826 ** containing the appropriately reformatted spec.
5827 ** In all cases, only explicit syntax is altered; no check is made that
5828 ** the resulting string is valid or that the directory in question
5829 ** actually exists.
5830 **
5831 **   fileify_dirspec() - convert a directory spec into the name of the
5832 **     directory file (i.e. what you can stat() to see if it's a dir).
5833 **     The style (VMS or Unix) of the result is the same as the style
5834 **     of the parameter passed in.
5835 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5836 **     what you prepend to a filename to indicate what directory it's in).
5837 **     The style (VMS or Unix) of the result is the same as the style
5838 **     of the parameter passed in.
5839 **   tounixpath() - convert a directory spec into a Unix-style path.
5840 **   tovmspath() - convert a directory spec into a VMS-style path.
5841 **   tounixspec() - convert any file spec into a Unix-style file spec.
5842 **   tovmsspec() - convert any file spec into a VMS-style spec.
5843 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5844 **
5845 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5846 ** Permission is given to distribute this code as part of the Perl
5847 ** standard distribution under the terms of the GNU General Public
5848 ** License or the Perl Artistic License.  Copies of each may be
5849 ** found in the Perl standard distribution.
5850  */
5851
5852 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5853 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
5854 {
5855     static char __fileify_retbuf[VMS_MAXRSS];
5856     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5857     char *retspec, *cp1, *cp2, *lastdir;
5858     char *trndir, *vmsdir;
5859     unsigned short int trnlnm_iter_count;
5860     int sts;
5861     if (utf8_fl != NULL)
5862         *utf8_fl = 0;
5863
5864     if (!dir || !*dir) {
5865       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5866     }
5867     dirlen = strlen(dir);
5868     while (dirlen && dir[dirlen-1] == '/') --dirlen;
5869     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5870       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5871         dir = "/sys$disk";
5872         dirlen = 9;
5873       }
5874       else
5875         dirlen = 1;
5876     }
5877     if (dirlen > (VMS_MAXRSS - 1)) {
5878       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5879       return NULL;
5880     }
5881     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
5882     if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5883     if (!strpbrk(dir+1,"/]>:")  &&
5884         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5885       strcpy(trndir,*dir == '/' ? dir + 1: dir);
5886       trnlnm_iter_count = 0;
5887       while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
5888         trnlnm_iter_count++;
5889         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5890       }
5891       dirlen = strlen(trndir);
5892     }
5893     else {
5894       strncpy(trndir,dir,dirlen);
5895       trndir[dirlen] = '\0';
5896     }
5897
5898     /* At this point we are done with *dir and use *trndir which is a
5899      * copy that can be modified.  *dir must not be modified.
5900      */
5901
5902     /* If we were handed a rooted logical name or spec, treat it like a
5903      * simple directory, so that
5904      *    $ Define myroot dev:[dir.]
5905      *    ... do_fileify_dirspec("myroot",buf,1) ...
5906      * does something useful.
5907      */
5908     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5909       trndir[--dirlen] = '\0';
5910       trndir[dirlen-1] = ']';
5911     }
5912     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5913       trndir[--dirlen] = '\0';
5914       trndir[dirlen-1] = '>';
5915     }
5916
5917     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5918       /* If we've got an explicit filename, we can just shuffle the string. */
5919       if (*(cp1+1)) hasfilename = 1;
5920       /* Similarly, we can just back up a level if we've got multiple levels
5921          of explicit directories in a VMS spec which ends with directories. */
5922       else {
5923         for (cp2 = cp1; cp2 > trndir; cp2--) {
5924           if (*cp2 == '.') {
5925             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5926 /* fix-me, can not scan EFS file specs backward like this */
5927               *cp2 = *cp1; *cp1 = '\0';
5928               hasfilename = 1;
5929               break;
5930             }
5931           }
5932           if (*cp2 == '[' || *cp2 == '<') break;
5933         }
5934       }
5935     }
5936
5937     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
5938     if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5939     cp1 = strpbrk(trndir,"]:>");
5940     if (hasfilename || !cp1) { /* Unix-style path or filename */
5941       if (trndir[0] == '.') {
5942         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5943           PerlMem_free(trndir);
5944           PerlMem_free(vmsdir);
5945           return do_fileify_dirspec("[]",buf,ts,NULL);
5946         }
5947         else if (trndir[1] == '.' &&
5948                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5949           PerlMem_free(trndir);
5950           PerlMem_free(vmsdir);
5951           return do_fileify_dirspec("[-]",buf,ts,NULL);
5952         }
5953       }
5954       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
5955         dirlen -= 1;                 /* to last element */
5956         lastdir = strrchr(trndir,'/');
5957       }
5958       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
5959         /* If we have "/." or "/..", VMSify it and let the VMS code
5960          * below expand it, rather than repeating the code to handle
5961          * relative components of a filespec here */
5962         do {
5963           if (*(cp1+2) == '.') cp1++;
5964           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
5965             char * ret_chr;
5966             if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5967                 PerlMem_free(trndir);
5968                 PerlMem_free(vmsdir);
5969                 return NULL;
5970             }
5971             if (strchr(vmsdir,'/') != NULL) {
5972               /* If do_tovmsspec() returned it, it must have VMS syntax
5973                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
5974                * the time to check this here only so we avoid a recursion
5975                * loop; otherwise, gigo.
5976                */
5977               PerlMem_free(trndir);
5978               PerlMem_free(vmsdir);
5979               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
5980               return NULL;
5981             }
5982             if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5983                 PerlMem_free(trndir);
5984                 PerlMem_free(vmsdir);
5985                 return NULL;
5986             }
5987             ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5988             PerlMem_free(trndir);
5989             PerlMem_free(vmsdir);
5990             return ret_chr;
5991           }
5992           cp1++;
5993         } while ((cp1 = strstr(cp1,"/.")) != NULL);
5994         lastdir = strrchr(trndir,'/');
5995       }
5996       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5997         char * ret_chr;
5998         /* Ditto for specs that end in an MFD -- let the VMS code
5999          * figure out whether it's a real device or a rooted logical. */
6000
6001         /* This should not happen any more.  Allowing the fake /000000
6002          * in a UNIX pathname causes all sorts of problems when trying
6003          * to run in UNIX emulation.  So the VMS to UNIX conversions
6004          * now remove the fake /000000 directories.
6005          */
6006
6007         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6008         if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
6009             PerlMem_free(trndir);
6010             PerlMem_free(vmsdir);
6011             return NULL;
6012         }
6013         if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
6014             PerlMem_free(trndir);
6015             PerlMem_free(vmsdir);
6016             return NULL;
6017         }
6018         ret_chr = do_tounixspec(trndir,buf,ts,NULL);
6019         PerlMem_free(trndir);
6020         PerlMem_free(vmsdir);
6021         return ret_chr;
6022       }
6023       else {
6024
6025         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6026              !(lastdir = cp1 = strrchr(trndir,']')) &&
6027              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6028         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
6029           int ver; char *cp3;
6030
6031           /* For EFS or ODS-5 look for the last dot */
6032           if (decc_efs_charset) {
6033               cp2 = strrchr(cp1,'.');
6034           }
6035           if (vms_process_case_tolerant) {
6036               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
6037                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
6038                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6039                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6040                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6041                             (ver || *cp3)))))) {
6042                   PerlMem_free(trndir);
6043                   PerlMem_free(vmsdir);
6044                   set_errno(ENOTDIR);
6045                   set_vaxc_errno(RMS$_DIR);
6046                   return NULL;
6047               }
6048           }
6049           else {
6050               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
6051                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
6052                   !*(cp2+3) || *(cp2+3) != 'R' ||
6053                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6054                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6055                             (ver || *cp3)))))) {
6056                  PerlMem_free(trndir);
6057                  PerlMem_free(vmsdir);
6058                  set_errno(ENOTDIR);
6059                  set_vaxc_errno(RMS$_DIR);
6060                  return NULL;
6061               }
6062           }
6063           dirlen = cp2 - trndir;
6064         }
6065       }
6066
6067       retlen = dirlen + 6;
6068       if (buf) retspec = buf;
6069       else if (ts) Newx(retspec,retlen+1,char);
6070       else retspec = __fileify_retbuf;
6071       memcpy(retspec,trndir,dirlen);
6072       retspec[dirlen] = '\0';
6073
6074       /* We've picked up everything up to the directory file name.
6075          Now just add the type and version, and we're set. */
6076       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
6077         strcat(retspec,".dir;1");
6078       else
6079         strcat(retspec,".DIR;1");
6080       PerlMem_free(trndir);
6081       PerlMem_free(vmsdir);
6082       return retspec;
6083     }
6084     else {  /* VMS-style directory spec */
6085
6086       char *esa, *esal, term, *cp;
6087       char *my_esa;
6088       int my_esa_len;
6089       unsigned long int sts, cmplen, haslower = 0;
6090       unsigned int nam_fnb;
6091       char * nam_type;
6092       struct FAB dirfab = cc$rms_fab;
6093       rms_setup_nam(savnam);
6094       rms_setup_nam(dirnam);
6095
6096       esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6097       if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6098       esal = NULL;
6099 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6100       esal = PerlMem_malloc(VMS_MAXRSS);
6101       if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6102 #endif
6103       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6104       rms_bind_fab_nam(dirfab, dirnam);
6105       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6106       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6107 #ifdef NAM$M_NO_SHORT_UPCASE
6108       if (decc_efs_case_preserve)
6109         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6110 #endif
6111
6112       for (cp = trndir; *cp; cp++)
6113         if (islower(*cp)) { haslower = 1; break; }
6114       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6115         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
6116           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6117           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
6118         }
6119         if (!sts) {
6120           PerlMem_free(esa);
6121           if (esal != NULL)
6122               PerlMem_free(esal);
6123           PerlMem_free(trndir);
6124           PerlMem_free(vmsdir);
6125           set_errno(EVMSERR);
6126           set_vaxc_errno(dirfab.fab$l_sts);
6127           return NULL;
6128         }
6129       }
6130       else {
6131         savnam = dirnam;
6132         /* Does the file really exist? */
6133         if (sys$search(&dirfab)& STS$K_SUCCESS) {
6134           /* Yes; fake the fnb bits so we'll check type below */
6135         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6136         }
6137         else { /* No; just work with potential name */
6138           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6139           else {
6140             int fab_sts;
6141             fab_sts = dirfab.fab$l_sts;
6142             sts = rms_free_search_context(&dirfab);
6143             PerlMem_free(esa);
6144             if (esal != NULL)
6145                 PerlMem_free(esal);
6146             PerlMem_free(trndir);
6147             PerlMem_free(vmsdir);
6148             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
6149             return NULL;
6150           }
6151         }
6152       }
6153
6154       /* Make sure we are using the right buffer */
6155       if (esal != NULL) {
6156         my_esa = esal;
6157         my_esa_len = rms_nam_esll(dirnam);
6158       } else {
6159         my_esa = esa;
6160         my_esa_len = rms_nam_esl(dirnam);
6161       }
6162       my_esa[my_esa_len] = '\0';
6163       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6164         cp1 = strchr(my_esa,']');
6165         if (!cp1) cp1 = strchr(my_esa,'>');
6166         if (cp1) {  /* Should always be true */
6167           my_esa_len -= cp1 - my_esa - 1;
6168           memmove(my_esa, cp1 + 1, my_esa_len);
6169         }
6170       }
6171       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6172         /* Yep; check version while we're at it, if it's there. */
6173         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6174         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6175           /* Something other than .DIR[;1].  Bzzt. */
6176           sts = rms_free_search_context(&dirfab);
6177           PerlMem_free(esa);
6178           if (esal != NULL)
6179              PerlMem_free(esal);
6180           PerlMem_free(trndir);
6181           PerlMem_free(vmsdir);
6182           set_errno(ENOTDIR);
6183           set_vaxc_errno(RMS$_DIR);
6184           return NULL;
6185         }
6186       }
6187
6188       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6189         /* They provided at least the name; we added the type, if necessary, */
6190         if (buf) retspec = buf;                            /* in sys$parse() */
6191         else if (ts) Newx(retspec, my_esa_len + 1, char);
6192         else retspec = __fileify_retbuf;
6193         strcpy(retspec,my_esa);
6194         sts = rms_free_search_context(&dirfab);
6195         PerlMem_free(trndir);
6196         PerlMem_free(esa);
6197         if (esal != NULL)
6198             PerlMem_free(esal);
6199         PerlMem_free(vmsdir);
6200         return retspec;
6201       }
6202       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6203         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6204         *cp1 = '\0';
6205         my_esa_len -= 9;
6206       }
6207       if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6208       if (cp1 == NULL) { /* should never happen */
6209         sts = rms_free_search_context(&dirfab);
6210         PerlMem_free(trndir);
6211         PerlMem_free(esa);
6212         if (esal != NULL)
6213             PerlMem_free(esal);
6214         PerlMem_free(vmsdir);
6215         return NULL;
6216       }
6217       term = *cp1;
6218       *cp1 = '\0';
6219       retlen = strlen(my_esa);
6220       cp1 = strrchr(my_esa,'.');
6221       /* ODS-5 directory specifications can have extra "." in them. */
6222       /* Fix-me, can not scan EFS file specifications backwards */
6223       while (cp1 != NULL) {
6224         if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6225           break;
6226         else {
6227            cp1--;
6228            while ((cp1 > my_esa) && (*cp1 != '.'))
6229              cp1--;
6230         }
6231         if (cp1 == my_esa)
6232           cp1 = NULL;
6233       }
6234
6235       if ((cp1) != NULL) {
6236         /* There's more than one directory in the path.  Just roll back. */
6237         *cp1 = term;
6238         if (buf) retspec = buf;
6239         else if (ts) Newx(retspec,retlen+7,char);
6240         else retspec = __fileify_retbuf;
6241         strcpy(retspec,my_esa);
6242       }
6243       else {
6244         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6245           /* Go back and expand rooted logical name */
6246           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6247 #ifdef NAM$M_NO_SHORT_UPCASE
6248           if (decc_efs_case_preserve)
6249             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6250 #endif
6251           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6252             sts = rms_free_search_context(&dirfab);
6253             PerlMem_free(esa);
6254             if (esal != NULL)
6255                 PerlMem_free(esal);
6256             PerlMem_free(trndir);
6257             PerlMem_free(vmsdir);
6258             set_errno(EVMSERR);
6259             set_vaxc_errno(dirfab.fab$l_sts);
6260             return NULL;
6261           }
6262
6263           /* This changes the length of the string of course */
6264           if (esal != NULL) {
6265               my_esa_len = rms_nam_esll(dirnam);
6266           } else {
6267               my_esa_len = rms_nam_esl(dirnam);
6268           }
6269
6270           retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6271           if (buf) retspec = buf;
6272           else if (ts) Newx(retspec,retlen+16,char);
6273           else retspec = __fileify_retbuf;
6274           cp1 = strstr(my_esa,"][");
6275           if (!cp1) cp1 = strstr(my_esa,"]<");
6276           dirlen = cp1 - my_esa;
6277           memcpy(retspec,my_esa,dirlen);
6278           if (!strncmp(cp1+2,"000000]",7)) {
6279             retspec[dirlen-1] = '\0';
6280             /* fix-me Not full ODS-5, just extra dots in directories for now */
6281             cp1 = retspec + dirlen - 1;
6282             while (cp1 > retspec)
6283             {
6284               if (*cp1 == '[')
6285                 break;
6286               if (*cp1 == '.') {
6287                 if (*(cp1-1) != '^')
6288                   break;
6289               }
6290               cp1--;
6291             }
6292             if (*cp1 == '.') *cp1 = ']';
6293             else {
6294               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6295               memmove(cp1+1,"000000]",7);
6296             }
6297           }
6298           else {
6299             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
6300             retspec[retlen] = '\0';
6301             /* Convert last '.' to ']' */
6302             cp1 = retspec+retlen-1;
6303             while (*cp != '[') {
6304               cp1--;
6305               if (*cp1 == '.') {
6306                 /* Do not trip on extra dots in ODS-5 directories */
6307                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
6308                 break;
6309               }
6310             }
6311             if (*cp1 == '.') *cp1 = ']';
6312             else {
6313               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6314               memmove(cp1+1,"000000]",7);
6315             }
6316           }
6317         }
6318         else {  /* This is a top-level dir.  Add the MFD to the path. */
6319           if (buf) retspec = buf;
6320           else if (ts) Newx(retspec,retlen+16,char);
6321           else retspec = __fileify_retbuf;
6322           cp1 = my_esa;
6323           cp2 = retspec;
6324           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6325           strcpy(cp2,":[000000]");
6326           cp1 += 2;
6327           strcpy(cp2+9,cp1);
6328         }
6329       }
6330       sts = rms_free_search_context(&dirfab);
6331       /* We've set up the string up through the filename.  Add the
6332          type and version, and we're done. */
6333       strcat(retspec,".DIR;1");
6334
6335       /* $PARSE may have upcased filespec, so convert output to lower
6336        * case if input contained any lowercase characters. */
6337       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
6338       PerlMem_free(trndir);
6339       PerlMem_free(esa);
6340       if (esal != NULL)
6341         PerlMem_free(esal);
6342       PerlMem_free(vmsdir);
6343       return retspec;
6344     }
6345 }  /* end of do_fileify_dirspec() */
6346 /*}}}*/
6347 /* External entry points */
6348 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6349 { return do_fileify_dirspec(dir,buf,0,NULL); }
6350 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6351 { return do_fileify_dirspec(dir,buf,1,NULL); }
6352 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6353 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6354 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6355 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6356
6357 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6358 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6359 {
6360     static char __pathify_retbuf[VMS_MAXRSS];
6361     unsigned long int retlen;
6362     char *retpath, *cp1, *cp2, *trndir;
6363     unsigned short int trnlnm_iter_count;
6364     STRLEN trnlen;
6365     int sts;
6366     if (utf8_fl != NULL)
6367         *utf8_fl = 0;
6368
6369     if (!dir || !*dir) {
6370       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6371     }
6372
6373     trndir = PerlMem_malloc(VMS_MAXRSS);
6374     if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6375     if (*dir) strcpy(trndir,dir);
6376     else getcwd(trndir,VMS_MAXRSS - 1);
6377
6378     trnlnm_iter_count = 0;
6379     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6380            && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
6381       trnlnm_iter_count++;
6382       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6383       trnlen = strlen(trndir);
6384
6385       /* Trap simple rooted lnms, and return lnm:[000000] */
6386       if (!strcmp(trndir+trnlen-2,".]")) {
6387         if (buf) retpath = buf;
6388         else if (ts) Newx(retpath,strlen(dir)+10,char);
6389         else retpath = __pathify_retbuf;
6390         strcpy(retpath,dir);
6391         strcat(retpath,":[000000]");
6392         PerlMem_free(trndir);
6393         return retpath;
6394       }
6395     }
6396
6397     /* At this point we do not work with *dir, but the copy in
6398      * *trndir that is modifiable.
6399      */
6400
6401     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
6402       if (*trndir == '.' && (*(trndir+1) == '\0' ||
6403                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
6404         retlen = 2 + (*(trndir+1) != '\0');
6405       else {
6406         if ( !(cp1 = strrchr(trndir,'/')) &&
6407              !(cp1 = strrchr(trndir,']')) &&
6408              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
6409         if ((cp2 = strchr(cp1,'.')) != NULL &&
6410             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
6411              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
6412               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
6413               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
6414           int ver; char *cp3;
6415
6416           /* For EFS or ODS-5 look for the last dot */
6417           if (decc_efs_charset) {
6418             cp2 = strrchr(cp1,'.');
6419           }
6420           if (vms_process_case_tolerant) {
6421               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
6422                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
6423                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6424                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6425                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6426                             (ver || *cp3)))))) {
6427                 PerlMem_free(trndir);
6428                 set_errno(ENOTDIR);
6429                 set_vaxc_errno(RMS$_DIR);
6430                 return NULL;
6431               }
6432           }
6433           else {
6434               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
6435                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
6436                   !*(cp2+3) || *(cp2+3) != 'R' ||
6437                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6438                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6439                             (ver || *cp3)))))) {
6440                 PerlMem_free(trndir);
6441                 set_errno(ENOTDIR);
6442                 set_vaxc_errno(RMS$_DIR);
6443                 return NULL;
6444               }
6445           }
6446           retlen = cp2 - trndir + 1;
6447         }
6448         else {  /* No file type present.  Treat the filename as a directory. */
6449           retlen = strlen(trndir) + 1;
6450         }
6451       }
6452       if (buf) retpath = buf;
6453       else if (ts) Newx(retpath,retlen+1,char);
6454       else retpath = __pathify_retbuf;
6455       strncpy(retpath, trndir, retlen-1);
6456       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
6457         retpath[retlen-1] = '/';      /* with '/', add it. */
6458         retpath[retlen] = '\0';
6459       }
6460       else retpath[retlen-1] = '\0';
6461     }
6462     else {  /* VMS-style directory spec */
6463       char *esa, *esal, *cp;
6464       char *my_esa;
6465       int my_esa_len;
6466       unsigned long int sts, cmplen, haslower;
6467       struct FAB dirfab = cc$rms_fab;
6468       int dirlen;
6469       rms_setup_nam(savnam);
6470       rms_setup_nam(dirnam);
6471
6472       /* If we've got an explicit filename, we can just shuffle the string. */
6473       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
6474              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
6475         if ((cp2 = strchr(cp1,'.')) != NULL) {
6476           int ver; char *cp3;
6477           if (vms_process_case_tolerant) {
6478               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
6479                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
6480                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6481                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6482                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6483                             (ver || *cp3)))))) {
6484                PerlMem_free(trndir);
6485                set_errno(ENOTDIR);
6486                set_vaxc_errno(RMS$_DIR);
6487                return NULL;
6488              }
6489           }
6490           else {
6491               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
6492                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
6493                   !*(cp2+3) || *(cp2+3) != 'R' ||
6494                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6495                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6496                             (ver || *cp3)))))) {
6497                PerlMem_free(trndir);
6498                set_errno(ENOTDIR);
6499                set_vaxc_errno(RMS$_DIR);
6500                return NULL;
6501              }
6502           }
6503         }
6504         else {  /* No file type, so just draw name into directory part */
6505           for (cp2 = cp1; *cp2; cp2++) ;
6506         }
6507         *cp2 = *cp1;
6508         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
6509         *cp1 = '.';
6510         /* We've now got a VMS 'path'; fall through */
6511       }
6512
6513       dirlen = strlen(trndir);
6514       if (trndir[dirlen-1] == ']' ||
6515           trndir[dirlen-1] == '>' ||
6516           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
6517         if (buf) retpath = buf;
6518         else if (ts) Newx(retpath,strlen(trndir)+1,char);
6519         else retpath = __pathify_retbuf;
6520         strcpy(retpath,trndir);
6521         PerlMem_free(trndir);
6522         return retpath;
6523       }
6524       rms_set_fna(dirfab, dirnam, trndir, dirlen);
6525       esa = PerlMem_malloc(VMS_MAXRSS);
6526       if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6527       esal = NULL;
6528 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6529       esal = PerlMem_malloc(VMS_MAXRSS);
6530       if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6531 #endif
6532       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6533       rms_bind_fab_nam(dirfab, dirnam);
6534       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
6535 #ifdef NAM$M_NO_SHORT_UPCASE
6536       if (decc_efs_case_preserve)
6537           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6538 #endif
6539
6540       for (cp = trndir; *cp; cp++)
6541         if (islower(*cp)) { haslower = 1; break; }
6542
6543       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
6544         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
6545           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6546           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
6547         }
6548         if (!sts) {
6549           PerlMem_free(trndir);
6550           PerlMem_free(esa);
6551           if (esal != NULL)
6552             PerlMem_free(esal);
6553           set_errno(EVMSERR);
6554           set_vaxc_errno(dirfab.fab$l_sts);
6555           return NULL;
6556         }
6557       }
6558       else {
6559         savnam = dirnam;
6560         /* Does the file really exist? */
6561         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
6562           if (dirfab.fab$l_sts != RMS$_FNF) {
6563             int sts1;
6564             sts1 = rms_free_search_context(&dirfab);
6565             PerlMem_free(trndir);
6566             PerlMem_free(esa);
6567             if (esal != NULL)
6568                 PerlMem_free(esal);
6569             set_errno(EVMSERR);
6570             set_vaxc_errno(dirfab.fab$l_sts);
6571             return NULL;
6572           }
6573           dirnam = savnam; /* No; just work with potential name */
6574         }
6575       }
6576       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6577         /* Yep; check version while we're at it, if it's there. */
6578         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6579         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
6580           int sts2;
6581           /* Something other than .DIR[;1].  Bzzt. */
6582           sts2 = rms_free_search_context(&dirfab);
6583           PerlMem_free(trndir);
6584           PerlMem_free(esa);
6585           if (esal != NULL)
6586              PerlMem_free(esal);
6587           set_errno(ENOTDIR);
6588           set_vaxc_errno(RMS$_DIR);
6589           return NULL;
6590         }
6591       }
6592       /* Make sure we are using the right buffer */
6593       if (esal != NULL) {
6594         /* We only need one, clean up the other */
6595         my_esa = esal;
6596         my_esa_len = rms_nam_esll(dirnam);
6597       } else {
6598         my_esa = esa;
6599         my_esa_len = rms_nam_esl(dirnam);
6600       }
6601
6602       /* Null terminate the buffer */
6603       my_esa[my_esa_len] = '\0';
6604
6605       /* OK, the type was fine.  Now pull any file name into the
6606          directory path. */
6607       if ((cp1 = strrchr(my_esa,']'))) *(rms_nam_typel(dirnam)) = ']';
6608       else {
6609         cp1 = strrchr(my_esa,'>');
6610         *(rms_nam_typel(dirnam)) = '>';
6611       }
6612       *cp1 = '.';
6613       *(rms_nam_typel(dirnam) + 1) = '\0';
6614       retlen = (rms_nam_typel(dirnam)) - my_esa + 2;
6615       if (buf) retpath = buf;
6616       else if (ts) Newx(retpath,retlen,char);
6617       else retpath = __pathify_retbuf;
6618       strcpy(retpath,my_esa);
6619       PerlMem_free(esa);
6620       if (esal != NULL)
6621           PerlMem_free(esal);
6622       sts = rms_free_search_context(&dirfab);
6623       /* $PARSE may have upcased filespec, so convert output to lower
6624        * case if input contained any lowercase characters. */
6625       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
6626     }
6627
6628     PerlMem_free(trndir);
6629     return retpath;
6630 }  /* end of do_pathify_dirspec() */
6631 /*}}}*/
6632 /* External entry points */
6633 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6634 { return do_pathify_dirspec(dir,buf,0,NULL); }
6635 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6636 { return do_pathify_dirspec(dir,buf,1,NULL); }
6637 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6638 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6639 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6640 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
6641
6642 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
6643 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
6644 {
6645   static char __tounixspec_retbuf[VMS_MAXRSS];
6646   char *dirend, *rslt, *cp1, *cp3, *tmp;
6647   const char *cp2;
6648   int devlen, dirlen, retlen = VMS_MAXRSS;
6649   int expand = 1; /* guarantee room for leading and trailing slashes */
6650   unsigned short int trnlnm_iter_count;
6651   int cmp_rslt;
6652   if (utf8_fl != NULL)
6653     *utf8_fl = 0;
6654
6655   if (spec == NULL) return NULL;
6656   if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
6657   if (buf) rslt = buf;
6658   else if (ts) {
6659     Newx(rslt, VMS_MAXRSS, char);
6660   }
6661   else rslt = __tounixspec_retbuf;
6662
6663   /* New VMS specific format needs translation
6664    * glob passes filenames with trailing '\n' and expects this preserved.
6665    */
6666   if (decc_posix_compliant_pathnames) {
6667     if (strncmp(spec, "\"^UP^", 5) == 0) {
6668       char * uspec;
6669       char *tunix;
6670       int tunix_len;
6671       int nl_flag;
6672
6673       tunix = PerlMem_malloc(VMS_MAXRSS);
6674       if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6675       strcpy(tunix, spec);
6676       tunix_len = strlen(tunix);
6677       nl_flag = 0;
6678       if (tunix[tunix_len - 1] == '\n') {
6679         tunix[tunix_len - 1] = '\"';
6680         tunix[tunix_len] = '\0';
6681         tunix_len--;
6682         nl_flag = 1;
6683       }
6684       uspec = decc$translate_vms(tunix);
6685       PerlMem_free(tunix);
6686       if ((int)uspec > 0) {
6687         strcpy(rslt,uspec);
6688         if (nl_flag) {
6689           strcat(rslt,"\n");
6690         }
6691         else {
6692           /* If we can not translate it, makemaker wants as-is */
6693           strcpy(rslt, spec);
6694         }
6695         return rslt;
6696       }
6697     }
6698   }
6699
6700   cmp_rslt = 0; /* Presume VMS */
6701   cp1 = strchr(spec, '/');
6702   if (cp1 == NULL)
6703     cmp_rslt = 0;
6704
6705     /* Look for EFS ^/ */
6706     if (decc_efs_charset) {
6707       while (cp1 != NULL) {
6708         cp2 = cp1 - 1;
6709         if (*cp2 != '^') {
6710           /* Found illegal VMS, assume UNIX */
6711           cmp_rslt = 1;
6712           break;
6713         }
6714       cp1++;
6715       cp1 = strchr(cp1, '/');
6716     }
6717   }
6718
6719   /* Look for "." and ".." */
6720   if (decc_filename_unix_report) {
6721     if (spec[0] == '.') {
6722       if ((spec[1] == '\0') || (spec[1] == '\n')) {
6723         cmp_rslt = 1;
6724       }
6725       else {
6726         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
6727           cmp_rslt = 1;
6728         }
6729       }
6730     }
6731   }
6732   /* This is already UNIX or at least nothing VMS understands */
6733   if (cmp_rslt) {
6734     strcpy(rslt,spec);
6735     return rslt;
6736   }
6737
6738   cp1 = rslt;
6739   cp2 = spec;
6740   dirend = strrchr(spec,']');
6741   if (dirend == NULL) dirend = strrchr(spec,'>');
6742   if (dirend == NULL) dirend = strchr(spec,':');
6743   if (dirend == NULL) {
6744     strcpy(rslt,spec);
6745     return rslt;
6746   }
6747
6748   /* Special case 1 - sys$posix_root = / */
6749 #if __CRTL_VER >= 70000000
6750   if (!decc_disable_posix_root) {
6751     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6752       *cp1 = '/';
6753       cp1++;
6754       cp2 = cp2 + 15;
6755       }
6756   }
6757 #endif
6758
6759   /* Special case 2 - Convert NLA0: to /dev/null */
6760 #if __CRTL_VER < 70000000
6761   cmp_rslt = strncmp(spec,"NLA0:", 5);
6762   if (cmp_rslt != 0)
6763      cmp_rslt = strncmp(spec,"nla0:", 5);
6764 #else
6765   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6766 #endif
6767   if (cmp_rslt == 0) {
6768     strcpy(rslt, "/dev/null");
6769     cp1 = cp1 + 9;
6770     cp2 = cp2 + 5;
6771     if (spec[6] != '\0') {
6772       cp1[9] == '/';
6773       cp1++;
6774       cp2++;
6775     }
6776   }
6777
6778    /* Also handle special case "SYS$SCRATCH:" */
6779 #if __CRTL_VER < 70000000
6780   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
6781   if (cmp_rslt != 0)
6782      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
6783 #else
6784   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6785 #endif
6786   tmp = PerlMem_malloc(VMS_MAXRSS);
6787   if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6788   if (cmp_rslt == 0) {
6789   int islnm;
6790
6791     islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
6792     if (!islnm) {
6793       strcpy(rslt, "/tmp");
6794       cp1 = cp1 + 4;
6795       cp2 = cp2 + 12;
6796       if (spec[12] != '\0') {
6797         cp1[4] == '/';
6798         cp1++;
6799         cp2++;
6800       }
6801     }
6802   }
6803
6804   if (*cp2 != '[' && *cp2 != '<') {
6805     *(cp1++) = '/';
6806   }
6807   else {  /* the VMS spec begins with directories */
6808     cp2++;
6809     if (*cp2 == ']' || *cp2 == '>') {
6810       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
6811       PerlMem_free(tmp);
6812       return rslt;
6813     }
6814     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
6815       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
6816         if (ts) Safefree(rslt);
6817         PerlMem_free(tmp);
6818         return NULL;
6819       }
6820       trnlnm_iter_count = 0;
6821       do {
6822         cp3 = tmp;
6823         while (*cp3 != ':' && *cp3) cp3++;
6824         *(cp3++) = '\0';
6825         if (strchr(cp3,']') != NULL) break;
6826         trnlnm_iter_count++;
6827         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
6828       } while (vmstrnenv(tmp,tmp,0,fildev,0));
6829       if (ts && !buf &&
6830           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
6831         retlen = devlen + dirlen;
6832         Renew(rslt,retlen+1+2*expand,char);
6833         cp1 = rslt;
6834       }
6835       cp3 = tmp;
6836       *(cp1++) = '/';
6837       while (*cp3) {
6838         *(cp1++) = *(cp3++);
6839         if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
6840             PerlMem_free(tmp);
6841             return NULL; /* No room */
6842         }
6843       }
6844       *(cp1++) = '/';
6845     }
6846     if ((*cp2 == '^')) {
6847         /* EFS file escape, pass the next character as is */
6848         /* Fix me: HEX encoding for Unicode not implemented */
6849         cp2++;
6850     }
6851     else if ( *cp2 == '.') {
6852       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
6853         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6854         cp2 += 3;
6855       }
6856       else cp2++;
6857     }
6858   }
6859   PerlMem_free(tmp);
6860   for (; cp2 <= dirend; cp2++) {
6861     if ((*cp2 == '^')) {
6862         /* EFS file escape, pass the next character as is */
6863         /* Fix me: HEX encoding for Unicode not implemented */
6864         *(cp1++) = *(++cp2);
6865         /* An escaped dot stays as is -- don't convert to slash */
6866         if (*cp2 == '.') cp2++;
6867     }
6868     if (*cp2 == ':') {
6869       *(cp1++) = '/';
6870       if (*(cp2+1) == '[') cp2++;
6871     }
6872     else if (*cp2 == ']' || *cp2 == '>') {
6873       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6874     }
6875     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
6876       *(cp1++) = '/';
6877       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6878         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6879                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6880         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6881             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6882       }
6883       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6884         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6885         cp2 += 2;
6886       }
6887     }
6888     else if (*cp2 == '-') {
6889       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6890         while (*cp2 == '-') {
6891           cp2++;
6892           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6893         }
6894         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
6895           if (ts) Safefree(rslt);                        /* filespecs like */
6896           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
6897           return NULL;
6898         }
6899       }
6900       else *(cp1++) = *cp2;
6901     }
6902     else *(cp1++) = *cp2;
6903   }
6904   while (*cp2) {
6905     if ((*cp2 == '^') && (*(cp2+1) == '.')) cp2++;  /* '^.' --> '.' */
6906     *(cp1++) = *(cp2++);
6907   }
6908   *cp1 = '\0';
6909
6910   /* This still leaves /000000/ when working with a
6911    * VMS device root or concealed root.
6912    */
6913   {
6914   int ulen;
6915   char * zeros;
6916
6917       ulen = strlen(rslt);
6918
6919       /* Get rid of "000000/ in rooted filespecs */
6920       if (ulen > 7) {
6921         zeros = strstr(rslt, "/000000/");
6922         if (zeros != NULL) {
6923           int mlen;
6924           mlen = ulen - (zeros - rslt) - 7;
6925           memmove(zeros, &zeros[7], mlen);
6926           ulen = ulen - 7;
6927           rslt[ulen] = '\0';
6928         }
6929       }
6930   }
6931
6932   return rslt;
6933
6934 }  /* end of do_tounixspec() */
6935 /*}}}*/
6936 /* External entry points */
6937 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
6938   { return do_tounixspec(spec,buf,0, NULL); }
6939 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
6940   { return do_tounixspec(spec,buf,1, NULL); }
6941 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
6942   { return do_tounixspec(spec,buf,0, utf8_fl); }
6943 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
6944   { return do_tounixspec(spec,buf,1, utf8_fl); }
6945
6946 #if __CRTL_VER >= 70200000 && !defined(__VAX)
6947
6948 /*
6949  This procedure is used to identify if a path is based in either
6950  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
6951  it returns the OpenVMS format directory for it.
6952
6953  It is expecting specifications of only '/' or '/xxxx/'
6954
6955  If a posix root does not exist, or 'xxxx' is not a directory
6956  in the posix root, it returns a failure.
6957
6958  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
6959
6960  It is used only internally by posix_to_vmsspec_hardway().
6961  */
6962
6963 static int posix_root_to_vms
6964   (char *vmspath, int vmspath_len,
6965    const char *unixpath,
6966    const int * utf8_fl)
6967 {
6968 int sts;
6969 struct FAB myfab = cc$rms_fab;
6970 rms_setup_nam(mynam);
6971 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6972 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6973 char * esa, * esal, * rsa, * rsal;
6974 char *vms_delim;
6975 int dir_flag;
6976 int unixlen;
6977
6978     dir_flag = 0;
6979     vmspath[0] = '\0';
6980     unixlen = strlen(unixpath);
6981     if (unixlen == 0) {
6982       return RMS$_FNF;
6983     }
6984
6985 #if __CRTL_VER >= 80200000
6986   /* If not a posix spec already, convert it */
6987   if (decc_posix_compliant_pathnames) {
6988     if (strncmp(unixpath,"\"^UP^",5) != 0) {
6989       sprintf(vmspath,"\"^UP^%s\"",unixpath);
6990     }
6991     else {
6992       /* This is already a VMS specification, no conversion */
6993       unixlen--;
6994       strncpy(vmspath,unixpath, vmspath_len);
6995     }
6996   }
6997   else
6998 #endif
6999   {
7000   int path_len;
7001   int i,j;
7002
7003      /* Check to see if this is under the POSIX root */
7004      if (decc_disable_posix_root) {
7005         return RMS$_FNF;
7006      }
7007
7008      /* Skip leading / */
7009      if (unixpath[0] == '/') {
7010         unixpath++;
7011         unixlen--;
7012      }
7013
7014
7015      strcpy(vmspath,"SYS$POSIX_ROOT:");
7016
7017      /* If this is only the / , or blank, then... */
7018      if (unixpath[0] == '\0') {
7019         /* by definition, this is the answer */
7020         return SS$_NORMAL;
7021      }
7022
7023      /* Need to look up a directory */
7024      vmspath[15] = '[';
7025      vmspath[16] = '\0';
7026
7027      /* Copy and add '^' escape characters as needed */
7028      j = 16;
7029      i = 0;
7030      while (unixpath[i] != 0) {
7031      int k;
7032
7033         j += copy_expand_unix_filename_escape
7034             (&vmspath[j], &unixpath[i], &k, utf8_fl);
7035         i += k;
7036      }
7037
7038      path_len = strlen(vmspath);
7039      if (vmspath[path_len - 1] == '/')
7040         path_len--;
7041      vmspath[path_len] = ']';
7042      path_len++;
7043      vmspath[path_len] = '\0';
7044
7045   }
7046   vmspath[vmspath_len] = 0;
7047   if (unixpath[unixlen - 1] == '/')
7048   dir_flag = 1;
7049   esal = PerlMem_malloc(VMS_MAXRSS);
7050   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7051   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7052   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7053   rsal = PerlMem_malloc(VMS_MAXRSS);
7054   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7055   rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7056   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7057   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7058   rms_bind_fab_nam(myfab, mynam);
7059   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7060   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7061   if (decc_efs_case_preserve)
7062     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7063 #ifdef NAML$M_OPEN_SPECIAL
7064   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7065 #endif
7066
7067   /* Set up the remaining naml fields */
7068   sts = sys$parse(&myfab);
7069
7070   /* It failed! Try again as a UNIX filespec */
7071   if (!(sts & 1)) {
7072     PerlMem_free(esal);
7073     PerlMem_free(esa);
7074     PerlMem_free(rsal);
7075     PerlMem_free(rsa);
7076     return sts;
7077   }
7078
7079    /* get the Device ID and the FID */
7080    sts = sys$search(&myfab);
7081
7082    /* These are no longer needed */
7083    PerlMem_free(esa);
7084    PerlMem_free(rsal);
7085    PerlMem_free(rsa);
7086
7087    /* on any failure, returned the POSIX ^UP^ filespec */
7088    if (!(sts & 1)) {
7089       PerlMem_free(esal);
7090       return sts;
7091    }
7092    specdsc.dsc$a_pointer = vmspath;
7093    specdsc.dsc$w_length = vmspath_len;
7094
7095    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7096    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7097    sts = lib$fid_to_name
7098       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7099
7100   /* on any failure, returned the POSIX ^UP^ filespec */
7101   if (!(sts & 1)) {
7102      /* This can happen if user does not have permission to read directories */
7103      if (strncmp(unixpath,"\"^UP^",5) != 0)
7104        sprintf(vmspath,"\"^UP^%s\"",unixpath);
7105      else
7106        strcpy(vmspath, unixpath);
7107   }
7108   else {
7109     vmspath[specdsc.dsc$w_length] = 0;
7110
7111     /* Are we expecting a directory? */
7112     if (dir_flag != 0) {
7113     int i;
7114     char *eptr;
7115
7116       eptr = NULL;
7117
7118       i = specdsc.dsc$w_length - 1;
7119       while (i > 0) {
7120       int zercnt;
7121         zercnt = 0;
7122         /* Version must be '1' */
7123         if (vmspath[i--] != '1')
7124           break;
7125         /* Version delimiter is one of ".;" */
7126         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7127           break;
7128         i--;
7129         if (vmspath[i--] != 'R')
7130           break;
7131         if (vmspath[i--] != 'I')
7132           break;
7133         if (vmspath[i--] != 'D')
7134           break;
7135         if (vmspath[i--] != '.')
7136           break;
7137         eptr = &vmspath[i+1];
7138         while (i > 0) {
7139           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7140             if (vmspath[i-1] != '^') {
7141               if (zercnt != 6) {
7142                 *eptr = vmspath[i];
7143                 eptr[1] = '\0';
7144                 vmspath[i] = '.';
7145                 break;
7146               }
7147               else {
7148                 /* Get rid of 6 imaginary zero directory filename */
7149                 vmspath[i+1] = '\0';
7150               }
7151             }
7152           }
7153           if (vmspath[i] == '0')
7154             zercnt++;
7155           else
7156             zercnt = 10;
7157           i--;
7158         }
7159         break;
7160       }
7161     }
7162   }
7163   PerlMem_free(esal);
7164   return sts;
7165 }
7166
7167 /* /dev/mumble needs to be handled special.
7168    /dev/null becomes NLA0:, And there is the potential for other stuff
7169    like /dev/tty which may need to be mapped to something.
7170 */
7171
7172 static int
7173 slash_dev_special_to_vms
7174    (const char * unixptr,
7175     char * vmspath,
7176     int vmspath_len)
7177 {
7178 char * nextslash;
7179 int len;
7180 int cmp;
7181 int islnm;
7182
7183     unixptr += 4;
7184     nextslash = strchr(unixptr, '/');
7185     len = strlen(unixptr);
7186     if (nextslash != NULL)
7187         len = nextslash - unixptr;
7188     cmp = strncmp("null", unixptr, 5);
7189     if (cmp == 0) {
7190         if (vmspath_len >= 6) {
7191             strcpy(vmspath, "_NLA0:");
7192             return SS$_NORMAL;
7193         }
7194     }
7195 }
7196
7197
7198 /* The built in routines do not understand perl's special needs, so
7199     doing a manual conversion from UNIX to VMS
7200
7201     If the utf8_fl is not null and points to a non-zero value, then
7202     treat 8 bit characters as UTF-8.
7203
7204     The sequence starting with '$(' and ending with ')' will be passed
7205     through with out interpretation instead of being escaped.
7206
7207   */
7208 static int posix_to_vmsspec_hardway
7209   (char *vmspath, int vmspath_len,
7210    const char *unixpath,
7211    int dir_flag,
7212    int * utf8_fl) {
7213
7214 char *esa;
7215 const char *unixptr;
7216 const char *unixend;
7217 char *vmsptr;
7218 const char *lastslash;
7219 const char *lastdot;
7220 int unixlen;
7221 int vmslen;
7222 int dir_start;
7223 int dir_dot;
7224 int quoted;
7225 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7226 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7227
7228   if (utf8_fl != NULL)
7229     *utf8_fl = 0;
7230
7231   unixptr = unixpath;
7232   dir_dot = 0;
7233
7234   /* Ignore leading "/" characters */
7235   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7236     unixptr++;
7237   }
7238   unixlen = strlen(unixptr);
7239
7240   /* Do nothing with blank paths */
7241   if (unixlen == 0) {
7242     vmspath[0] = '\0';
7243     return SS$_NORMAL;
7244   }
7245
7246   quoted = 0;
7247   /* This could have a "^UP^ on the front */
7248   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7249     quoted = 1;
7250     unixptr+= 5;
7251     unixlen-= 5;
7252   }
7253
7254   lastslash = strrchr(unixptr,'/');
7255   lastdot = strrchr(unixptr,'.');
7256   unixend = strrchr(unixptr,'\"');
7257   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7258     unixend = unixptr + unixlen;
7259   }
7260
7261   /* last dot is last dot or past end of string */
7262   if (lastdot == NULL)
7263     lastdot = unixptr + unixlen;
7264
7265   /* if no directories, set last slash to beginning of string */
7266   if (lastslash == NULL) {
7267     lastslash = unixptr;
7268   }
7269   else {
7270     /* Watch out for trailing "." after last slash, still a directory */
7271     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7272       lastslash = unixptr + unixlen;
7273     }
7274
7275     /* Watch out for traiing ".." after last slash, still a directory */
7276     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7277       lastslash = unixptr + unixlen;
7278     }
7279
7280     /* dots in directories are aways escaped */
7281     if (lastdot < lastslash)
7282       lastdot = unixptr + unixlen;
7283   }
7284
7285   /* if (unixptr < lastslash) then we are in a directory */
7286
7287   dir_start = 0;
7288
7289   vmsptr = vmspath;
7290   vmslen = 0;
7291
7292   /* Start with the UNIX path */
7293   if (*unixptr != '/') {
7294     /* relative paths */
7295
7296     /* If allowing logical names on relative pathnames, then handle here */
7297     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7298         !decc_posix_compliant_pathnames) {
7299     char * nextslash;
7300     int seg_len;
7301     char * trn;
7302     int islnm;
7303
7304         /* Find the next slash */
7305         nextslash = strchr(unixptr,'/');
7306
7307         esa = PerlMem_malloc(vmspath_len);
7308         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7309
7310         trn = PerlMem_malloc(VMS_MAXRSS);
7311         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7312
7313         if (nextslash != NULL) {
7314
7315             seg_len = nextslash - unixptr;
7316             strncpy(esa, unixptr, seg_len);
7317             esa[seg_len] = 0;
7318         }
7319         else {
7320             strcpy(esa, unixptr);
7321             seg_len = strlen(unixptr);
7322         }
7323         /* trnlnm(section) */
7324         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7325
7326         if (islnm) {
7327             /* Now fix up the directory */
7328
7329             /* Split up the path to find the components */
7330             sts = vms_split_path
7331                   (trn,
7332                    &v_spec,
7333                    &v_len,
7334                    &r_spec,
7335                    &r_len,
7336                    &d_spec,
7337                    &d_len,
7338                    &n_spec,
7339                    &n_len,
7340                    &e_spec,
7341                    &e_len,
7342                    &vs_spec,
7343                    &vs_len);
7344
7345             while (sts == 0) {
7346             char * strt;
7347             int cmp;
7348
7349                 /* A logical name must be a directory  or the full
7350                    specification.  It is only a full specification if
7351                    it is the only component */
7352                 if ((unixptr[seg_len] == '\0') ||
7353                     (unixptr[seg_len+1] == '\0')) {
7354
7355                     /* Is a directory being required? */
7356                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7357                         /* Not a logical name */
7358                         break;
7359                     }
7360
7361
7362                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7363                         /* This must be a directory */
7364                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7365                             strcpy(vmsptr, esa);
7366                             vmslen=strlen(vmsptr);
7367                             vmsptr[vmslen] = ':';
7368                             vmslen++;
7369                             vmsptr[vmslen] = '\0';
7370                             return SS$_NORMAL;
7371                         }
7372                     }
7373
7374                 }
7375
7376
7377                 /* must be dev/directory - ignore version */
7378                 if ((n_len + e_len) != 0)
7379                     break;
7380
7381                 /* transfer the volume */
7382                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7383                     strncpy(vmsptr, v_spec, v_len);
7384                     vmsptr += v_len;
7385                     vmsptr[0] = '\0';
7386                     vmslen += v_len;
7387                 }
7388
7389                 /* unroot the rooted directory */
7390                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7391                     r_spec[0] = '[';
7392                     r_spec[r_len - 1] = ']';
7393
7394                     /* This should not be there, but nothing is perfect */
7395                     if (r_len > 9) {
7396                         cmp = strcmp(&r_spec[1], "000000.");
7397                         if (cmp == 0) {
7398                             r_spec += 7;
7399                             r_spec[7] = '[';
7400                             r_len -= 7;
7401                             if (r_len == 2)
7402                                 r_len = 0;
7403                         }
7404                     }
7405                     if (r_len > 0) {
7406                         strncpy(vmsptr, r_spec, r_len);
7407                         vmsptr += r_len;
7408                         vmslen += r_len;
7409                         vmsptr[0] = '\0';
7410                     }
7411                 }
7412                 /* Bring over the directory. */
7413                 if ((d_len > 0) &&
7414                     ((d_len + vmslen) < vmspath_len)) {
7415                     d_spec[0] = '[';
7416                     d_spec[d_len - 1] = ']';
7417                     if (d_len > 9) {
7418                         cmp = strcmp(&d_spec[1], "000000.");
7419                         if (cmp == 0) {
7420                             d_spec += 7;
7421                             d_spec[7] = '[';
7422                             d_len -= 7;
7423                             if (d_len == 2)
7424                                 d_len = 0;
7425                         }
7426                     }
7427
7428                     if (r_len > 0) {
7429                         /* Remove the redundant root */
7430                         if (r_len > 0) {
7431                             /* remove the ][ */
7432                             vmsptr--;
7433                             vmslen--;
7434                             d_spec++;
7435                             d_len--;
7436                         }
7437                         strncpy(vmsptr, d_spec, d_len);
7438                             vmsptr += d_len;
7439                             vmslen += d_len;
7440                             vmsptr[0] = '\0';
7441                     }
7442                 }
7443                 break;
7444             }
7445         }
7446
7447         PerlMem_free(esa);
7448         PerlMem_free(trn);
7449     }
7450
7451     if (lastslash > unixptr) {
7452     int dotdir_seen;
7453
7454       /* skip leading ./ */
7455       dotdir_seen = 0;
7456       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7457         dotdir_seen = 1;
7458         unixptr++;
7459         unixptr++;
7460       }
7461
7462       /* Are we still in a directory? */
7463       if (unixptr <= lastslash) {
7464         *vmsptr++ = '[';
7465         vmslen = 1;
7466         dir_start = 1;
7467
7468         /* if not backing up, then it is relative forward. */
7469         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7470               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7471           *vmsptr++ = '.';
7472           vmslen++;
7473           dir_dot = 1;
7474           }
7475        }
7476        else {
7477          if (dotdir_seen) {
7478            /* Perl wants an empty directory here to tell the difference
7479             * between a DCL commmand and a filename
7480             */
7481           *vmsptr++ = '[';
7482           *vmsptr++ = ']';
7483           vmslen = 2;
7484         }
7485       }
7486     }
7487     else {
7488       /* Handle two special files . and .. */
7489       if (unixptr[0] == '.') {
7490         if (&unixptr[1] == unixend) {
7491           *vmsptr++ = '[';
7492           *vmsptr++ = ']';
7493           vmslen += 2;
7494           *vmsptr++ = '\0';
7495           return SS$_NORMAL;
7496         }
7497         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7498           *vmsptr++ = '[';
7499           *vmsptr++ = '-';
7500           *vmsptr++ = ']';
7501           vmslen += 3;
7502           *vmsptr++ = '\0';
7503           return SS$_NORMAL;
7504         }
7505       }
7506     }
7507   }
7508   else {        /* Absolute PATH handling */
7509   int sts;
7510   char * nextslash;
7511   int seg_len;
7512     /* Need to find out where root is */
7513
7514     /* In theory, this procedure should never get an absolute POSIX pathname
7515      * that can not be found on the POSIX root.
7516      * In practice, that can not be relied on, and things will show up
7517      * here that are a VMS device name or concealed logical name instead.
7518      * So to make things work, this procedure must be tolerant.
7519      */
7520     esa = PerlMem_malloc(vmspath_len);
7521     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7522
7523     sts = SS$_NORMAL;
7524     nextslash = strchr(&unixptr[1],'/');
7525     seg_len = 0;
7526     if (nextslash != NULL) {
7527     int cmp;
7528       seg_len = nextslash - &unixptr[1];
7529       strncpy(vmspath, unixptr, seg_len + 1);
7530       vmspath[seg_len+1] = 0;
7531       cmp = 1;
7532       if (seg_len == 3) {
7533         cmp = strncmp(vmspath, "dev", 4);
7534         if (cmp == 0) {
7535             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7536             if (sts = SS$_NORMAL)
7537                 return SS$_NORMAL;
7538         }
7539       }
7540       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
7541     }
7542
7543     if ($VMS_STATUS_SUCCESS(sts)) {
7544       /* This is verified to be a real path */
7545
7546       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7547       if ($VMS_STATUS_SUCCESS(sts)) {
7548         strcpy(vmspath, esa);
7549         vmslen = strlen(vmspath);
7550         vmsptr = vmspath + vmslen;
7551         unixptr++;
7552         if (unixptr < lastslash) {
7553         char * rptr;
7554           vmsptr--;
7555           *vmsptr++ = '.';
7556           dir_start = 1;
7557           dir_dot = 1;
7558           if (vmslen > 7) {
7559           int cmp;
7560             rptr = vmsptr - 7;
7561             cmp = strcmp(rptr,"000000.");
7562             if (cmp == 0) {
7563               vmslen -= 7;
7564               vmsptr -= 7;
7565               vmsptr[1] = '\0';
7566             } /* removing 6 zeros */
7567           } /* vmslen < 7, no 6 zeros possible */
7568         } /* Not in a directory */
7569       } /* Posix root found */
7570       else {
7571         /* No posix root, fall back to default directory */
7572         strcpy(vmspath, "SYS$DISK:[");
7573         vmsptr = &vmspath[10];
7574         vmslen = 10;
7575         if (unixptr > lastslash) {
7576            *vmsptr = ']';
7577            vmsptr++;
7578            vmslen++;
7579         }
7580         else {
7581            dir_start = 1;
7582         }
7583       }
7584     } /* end of verified real path handling */
7585     else {
7586     int add_6zero;
7587     int islnm;
7588
7589       /* Ok, we have a device or a concealed root that is not in POSIX
7590        * or we have garbage.  Make the best of it.
7591        */
7592
7593       /* Posix to VMS destroyed this, so copy it again */
7594       strncpy(vmspath, &unixptr[1], seg_len);
7595       vmspath[seg_len] = 0;
7596       vmslen = seg_len;
7597       vmsptr = &vmsptr[vmslen];
7598       islnm = 0;
7599
7600       /* Now do we need to add the fake 6 zero directory to it? */
7601       add_6zero = 1;
7602       if ((*lastslash == '/') && (nextslash < lastslash)) {
7603         /* No there is another directory */
7604         add_6zero = 0;
7605       }
7606       else {
7607       int trnend;
7608       int cmp;
7609
7610         /* now we have foo:bar or foo:[000000]bar to decide from */
7611         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
7612
7613         if (!islnm && !decc_posix_compliant_pathnames) {
7614
7615             cmp = strncmp("bin", vmspath, 4);
7616             if (cmp == 0) {
7617                 /* bin => SYS$SYSTEM: */
7618                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7619             }
7620             else {
7621                 /* tmp => SYS$SCRATCH: */
7622                 cmp = strncmp("tmp", vmspath, 4);
7623                 if (cmp == 0) {
7624                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
7625                 }
7626             }
7627         }
7628
7629         trnend = islnm ? islnm - 1 : 0;
7630
7631         /* if this was a logical name, ']' or '>' must be present */
7632         /* if not a logical name, then assume a device and hope. */
7633         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
7634
7635         /* if log name and trailing '.' then rooted - treat as device */
7636         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
7637
7638         /* Fix me, if not a logical name, a device lookup should be
7639          * done to see if the device is file structured.  If the device
7640          * is not file structured, the 6 zeros should not be put on.
7641          *
7642          * As it is, perl is occasionally looking for dev:[000000]tty.
7643          * which looks a little strange.
7644          *
7645          * Not that easy to detect as "/dev" may be file structured with
7646          * special device files.
7647          */
7648
7649         if ((add_6zero == 0) && (*nextslash == '/') &&
7650             (&nextslash[1] == unixend)) {
7651           /* No real directory present */
7652           add_6zero = 1;
7653         }
7654       }
7655
7656       /* Put the device delimiter on */
7657       *vmsptr++ = ':';
7658       vmslen++;
7659       unixptr = nextslash;
7660       unixptr++;
7661
7662       /* Start directory if needed */
7663       if (!islnm || add_6zero) {
7664         *vmsptr++ = '[';
7665         vmslen++;
7666         dir_start = 1;
7667       }
7668
7669       /* add fake 000000] if needed */
7670       if (add_6zero) {
7671         *vmsptr++ = '0';
7672         *vmsptr++ = '0';
7673         *vmsptr++ = '0';
7674         *vmsptr++ = '0';
7675         *vmsptr++ = '0';
7676         *vmsptr++ = '0';
7677         *vmsptr++ = ']';
7678         vmslen += 7;
7679         dir_start = 0;
7680       }
7681
7682     } /* non-POSIX translation */
7683     PerlMem_free(esa);
7684   } /* End of relative/absolute path handling */
7685
7686   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
7687   int dash_flag;
7688   int in_cnt;
7689   int out_cnt;
7690
7691     dash_flag = 0;
7692
7693     if (dir_start != 0) {
7694
7695       /* First characters in a directory are handled special */
7696       while ((*unixptr == '/') ||
7697              ((*unixptr == '.') &&
7698               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
7699                 (&unixptr[1]==unixend)))) {
7700       int loop_flag;
7701
7702         loop_flag = 0;
7703
7704         /* Skip redundant / in specification */
7705         while ((*unixptr == '/') && (dir_start != 0)) {
7706           loop_flag = 1;
7707           unixptr++;
7708           if (unixptr == lastslash)
7709             break;
7710         }
7711         if (unixptr == lastslash)
7712           break;
7713
7714         /* Skip redundant ./ characters */
7715         while ((*unixptr == '.') &&
7716                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
7717           loop_flag = 1;
7718           unixptr++;
7719           if (unixptr == lastslash)
7720             break;
7721           if (*unixptr == '/')
7722             unixptr++;
7723         }
7724         if (unixptr == lastslash)
7725           break;
7726
7727         /* Skip redundant ../ characters */
7728         while ((*unixptr == '.') && (unixptr[1] == '.') &&
7729              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
7730           /* Set the backing up flag */
7731           loop_flag = 1;
7732           dir_dot = 0;
7733           dash_flag = 1;
7734           *vmsptr++ = '-';
7735           vmslen++;
7736           unixptr++; /* first . */
7737           unixptr++; /* second . */
7738           if (unixptr == lastslash)
7739             break;
7740           if (*unixptr == '/') /* The slash */
7741             unixptr++;
7742         }
7743         if (unixptr == lastslash)
7744           break;
7745
7746         /* To do: Perl expects /.../ to be translated to [...] on VMS */
7747         /* Not needed when VMS is pretending to be UNIX. */
7748
7749         /* Is this loop stuck because of too many dots? */
7750         if (loop_flag == 0) {
7751           /* Exit the loop and pass the rest through */
7752           break;
7753         }
7754       }
7755
7756       /* Are we done with directories yet? */
7757       if (unixptr >= lastslash) {
7758
7759         /* Watch out for trailing dots */
7760         if (dir_dot != 0) {
7761             vmslen --;
7762             vmsptr--;
7763         }
7764         *vmsptr++ = ']';
7765         vmslen++;
7766         dash_flag = 0;
7767         dir_start = 0;
7768         if (*unixptr == '/')
7769           unixptr++;
7770       }
7771       else {
7772         /* Have we stopped backing up? */
7773         if (dash_flag) {
7774           *vmsptr++ = '.';
7775           vmslen++;
7776           dash_flag = 0;
7777           /* dir_start continues to be = 1 */
7778         }
7779         if (*unixptr == '-') {
7780           *vmsptr++ = '^';
7781           *vmsptr++ = *unixptr++;
7782           vmslen += 2;
7783           dir_start = 0;
7784
7785           /* Now are we done with directories yet? */
7786           if (unixptr >= lastslash) {
7787
7788             /* Watch out for trailing dots */
7789             if (dir_dot != 0) {
7790               vmslen --;
7791               vmsptr--;
7792             }
7793
7794             *vmsptr++ = ']';
7795             vmslen++;
7796             dash_flag = 0;
7797             dir_start = 0;
7798           }
7799         }
7800       }
7801     }
7802
7803     /* All done? */
7804     if (unixptr >= unixend)
7805       break;
7806
7807     /* Normal characters - More EFS work probably needed */
7808     dir_start = 0;
7809     dir_dot = 0;
7810
7811     switch(*unixptr) {
7812     case '/':
7813         /* remove multiple / */
7814         while (unixptr[1] == '/') {
7815            unixptr++;
7816         }
7817         if (unixptr == lastslash) {
7818           /* Watch out for trailing dots */
7819           if (dir_dot != 0) {
7820             vmslen --;
7821             vmsptr--;
7822           }
7823           *vmsptr++ = ']';
7824         }
7825         else {
7826           dir_start = 1;
7827           *vmsptr++ = '.';
7828           dir_dot = 1;
7829
7830           /* To do: Perl expects /.../ to be translated to [...] on VMS */
7831           /* Not needed when VMS is pretending to be UNIX. */
7832
7833         }
7834         dash_flag = 0;
7835         if (unixptr != unixend)
7836           unixptr++;
7837         vmslen++;
7838         break;
7839     case '.':
7840         if ((unixptr < lastdot) || (unixptr < lastslash) ||
7841             (&unixptr[1] == unixend)) {
7842           *vmsptr++ = '^';
7843           *vmsptr++ = '.';
7844           vmslen += 2;
7845           unixptr++;
7846
7847           /* trailing dot ==> '^..' on VMS */
7848           if (unixptr == unixend) {
7849             *vmsptr++ = '.';
7850             vmslen++;
7851             unixptr++;
7852           }
7853           break;
7854         }
7855
7856         *vmsptr++ = *unixptr++;
7857         vmslen ++;
7858         break;
7859     case '"':
7860         if (quoted && (&unixptr[1] == unixend)) {
7861             unixptr++;
7862             break;
7863         }
7864         in_cnt = copy_expand_unix_filename_escape
7865                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7866         vmsptr += out_cnt;
7867         unixptr += in_cnt;
7868         break;
7869     case '~':
7870     case ';':
7871     case '\\':
7872     case '?':
7873     case ' ':
7874     default:
7875         in_cnt = copy_expand_unix_filename_escape
7876                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7877         vmsptr += out_cnt;
7878         unixptr += in_cnt;
7879         break;
7880     }
7881   }
7882
7883   /* Make sure directory is closed */
7884   if (unixptr == lastslash) {
7885     char *vmsptr2;
7886     vmsptr2 = vmsptr - 1;
7887
7888     if (*vmsptr2 != ']') {
7889       *vmsptr2--;
7890
7891       /* directories do not end in a dot bracket */
7892       if (*vmsptr2 == '.') {
7893         vmsptr2--;
7894
7895         /* ^. is allowed */
7896         if (*vmsptr2 != '^') {
7897           vmsptr--; /* back up over the dot */
7898         }
7899       }
7900       *vmsptr++ = ']';
7901     }
7902   }
7903   else {
7904     char *vmsptr2;
7905     /* Add a trailing dot if a file with no extension */
7906     vmsptr2 = vmsptr - 1;
7907     if ((vmslen > 1) &&
7908         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
7909         (*vmsptr2 != ')') && (*lastdot != '.')) {
7910         *vmsptr++ = '.';
7911         vmslen++;
7912     }
7913   }
7914
7915   *vmsptr = '\0';
7916   return SS$_NORMAL;
7917 }
7918 #endif
7919
7920  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
7921 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
7922 {
7923 char * result;
7924 int utf8_flag;
7925
7926    /* If a UTF8 flag is being passed, honor it */
7927    utf8_flag = 0;
7928    if (utf8_fl != NULL) {
7929      utf8_flag = *utf8_fl;
7930     *utf8_fl = 0;
7931    }
7932
7933    if (utf8_flag) {
7934      /* If there is a possibility of UTF8, then if any UTF8 characters
7935         are present, then they must be converted to VTF-7
7936       */
7937      result = strcpy(rslt, path); /* FIX-ME */
7938    }
7939    else
7940      result = strcpy(rslt, path);
7941
7942    return result;
7943 }
7944
7945
7946 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
7947 static char *mp_do_tovmsspec
7948    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
7949   static char __tovmsspec_retbuf[VMS_MAXRSS];
7950   char *rslt, *dirend;
7951   char *lastdot;
7952   char *vms_delim;
7953   register char *cp1;
7954   const char *cp2;
7955   unsigned long int infront = 0, hasdir = 1;
7956   int rslt_len;
7957   int no_type_seen;
7958   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7959   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7960
7961   if (path == NULL) return NULL;
7962   rslt_len = VMS_MAXRSS-1;
7963   if (buf) rslt = buf;
7964   else if (ts) Newx(rslt, VMS_MAXRSS, char);
7965   else rslt = __tovmsspec_retbuf;
7966
7967   /* '.' and '..' are "[]" and "[-]" for a quick check */
7968   if (path[0] == '.') {
7969     if (path[1] == '\0') {
7970       strcpy(rslt,"[]");
7971       if (utf8_flag != NULL)
7972         *utf8_flag = 0;
7973       return rslt;
7974     }
7975     else {
7976       if (path[1] == '.' && path[2] == '\0') {
7977         strcpy(rslt,"[-]");
7978         if (utf8_flag != NULL)
7979            *utf8_flag = 0;
7980         return rslt;
7981       }
7982     }
7983   }
7984
7985    /* Posix specifications are now a native VMS format */
7986   /*--------------------------------------------------*/
7987 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7988   if (decc_posix_compliant_pathnames) {
7989     if (strncmp(path,"\"^UP^",5) == 0) {
7990       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7991       return rslt;
7992     }
7993   }
7994 #endif
7995
7996   /* This is really the only way to see if this is already in VMS format */
7997   sts = vms_split_path
7998        (path,
7999         &v_spec,
8000         &v_len,
8001         &r_spec,
8002         &r_len,
8003         &d_spec,
8004         &d_len,
8005         &n_spec,
8006         &n_len,
8007         &e_spec,
8008         &e_len,
8009         &vs_spec,
8010         &vs_len);
8011   if (sts == 0) {
8012     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8013        replacement, because the above parse just took care of most of
8014        what is needed to do vmspath when the specification is already
8015        in VMS format.
8016
8017        And if it is not already, it is easier to do the conversion as
8018        part of this routine than to call this routine and then work on
8019        the result.
8020      */
8021
8022     /* If VMS punctuation was found, it is already VMS format */
8023     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8024       if (utf8_flag != NULL)
8025         *utf8_flag = 0;
8026       strcpy(rslt, path);
8027       return rslt;
8028     }
8029     /* Now, what to do with trailing "." cases where there is no
8030        extension?  If this is a UNIX specification, and EFS characters
8031        are enabled, then the trailing "." should be converted to a "^.".
8032        But if this was already a VMS specification, then it should be
8033        left alone.
8034
8035        So in the case of ambiguity, leave the specification alone.
8036      */
8037
8038
8039     /* If there is a possibility of UTF8, then if any UTF8 characters
8040         are present, then they must be converted to VTF-7
8041      */
8042     if (utf8_flag != NULL)
8043       *utf8_flag = 0;
8044     strcpy(rslt, path);
8045     return rslt;
8046   }
8047
8048   dirend = strrchr(path,'/');
8049
8050   if (dirend == NULL) {
8051      /* If we get here with no UNIX directory delimiters, then this is
8052         not a complete file specification, either garbage a UNIX glob
8053         specification that can not be converted to a VMS wildcard, or
8054         it a UNIX shell macro.  MakeMaker wants these passed through AS-IS,
8055         so apparently other programs expect this also.
8056
8057         utf8 flag setting needs to be preserved.
8058       */
8059       strcpy(rslt, path);
8060       return rslt;
8061   }
8062
8063 /* If POSIX mode active, handle the conversion */
8064 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8065   if (decc_efs_charset) {
8066     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8067     return rslt;
8068   }
8069 #endif
8070
8071   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
8072     if (!*(dirend+2)) dirend +=2;
8073     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8074     if (decc_efs_charset == 0) {
8075       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8076     }
8077   }
8078
8079   cp1 = rslt;
8080   cp2 = path;
8081   lastdot = strrchr(cp2,'.');
8082   if (*cp2 == '/') {
8083     char *trndev;
8084     int islnm, rooted;
8085     STRLEN trnend;
8086
8087     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8088     if (!*(cp2+1)) {
8089       if (decc_disable_posix_root) {
8090         strcpy(rslt,"sys$disk:[000000]");
8091       }
8092       else {
8093         strcpy(rslt,"sys$posix_root:[000000]");
8094       }
8095       if (utf8_flag != NULL)
8096         *utf8_flag = 0;
8097       return rslt;
8098     }
8099     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8100     *cp1 = '\0';
8101     trndev = PerlMem_malloc(VMS_MAXRSS);
8102     if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8103     islnm =  simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8104
8105      /* DECC special handling */
8106     if (!islnm) {
8107       if (strcmp(rslt,"bin") == 0) {
8108         strcpy(rslt,"sys$system");
8109         cp1 = rslt + 10;
8110         *cp1 = 0;
8111         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8112       }
8113       else if (strcmp(rslt,"tmp") == 0) {
8114         strcpy(rslt,"sys$scratch");
8115         cp1 = rslt + 11;
8116         *cp1 = 0;
8117         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8118       }
8119       else if (!decc_disable_posix_root) {
8120         strcpy(rslt, "sys$posix_root");
8121         cp1 = rslt + 14;
8122         *cp1 = 0;
8123         cp2 = path;
8124         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8125         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8126       }
8127       else if (strcmp(rslt,"dev") == 0) {
8128         if (strncmp(cp2,"/null", 5) == 0) {
8129           if ((cp2[5] == 0) || (cp2[5] == '/')) {
8130             strcpy(rslt,"NLA0");
8131             cp1 = rslt + 4;
8132             *cp1 = 0;
8133             cp2 = cp2 + 5;
8134             islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8135           }
8136         }
8137       }
8138     }
8139
8140     trnend = islnm ? strlen(trndev) - 1 : 0;
8141     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8142     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8143     /* If the first element of the path is a logical name, determine
8144      * whether it has to be translated so we can add more directories. */
8145     if (!islnm || rooted) {
8146       *(cp1++) = ':';
8147       *(cp1++) = '[';
8148       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8149       else cp2++;
8150     }
8151     else {
8152       if (cp2 != dirend) {
8153         strcpy(rslt,trndev);
8154         cp1 = rslt + trnend;
8155         if (*cp2 != 0) {
8156           *(cp1++) = '.';
8157           cp2++;
8158         }
8159       }
8160       else {
8161         if (decc_disable_posix_root) {
8162           *(cp1++) = ':';
8163           hasdir = 0;
8164         }
8165       }
8166     }
8167     PerlMem_free(trndev);
8168   }
8169   else {
8170     *(cp1++) = '[';
8171     if (*cp2 == '.') {
8172       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8173         cp2 += 2;         /* skip over "./" - it's redundant */
8174         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8175       }
8176       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8177         *(cp1++) = '-';                                 /* "../" --> "-" */
8178         cp2 += 3;
8179       }
8180       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8181                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8182         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8183         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8184         cp2 += 4;
8185       }
8186       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8187         /* Escape the extra dots in EFS file specifications */
8188         *(cp1++) = '^';
8189       }
8190       if (cp2 > dirend) cp2 = dirend;
8191     }
8192     else *(cp1++) = '.';
8193   }
8194   for (; cp2 < dirend; cp2++) {
8195     if (*cp2 == '/') {
8196       if (*(cp2-1) == '/') continue;
8197       if (*(cp1-1) != '.') *(cp1++) = '.';
8198       infront = 0;
8199     }
8200     else if (!infront && *cp2 == '.') {
8201       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8202       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8203       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8204         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8205         else if (*(cp1-2) == '[') *(cp1-1) = '-';
8206         else {  /* back up over previous directory name */
8207           cp1--;
8208           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
8209           if (*(cp1-1) == '[') {
8210             memcpy(cp1,"000000.",7);
8211             cp1 += 7;
8212           }
8213         }
8214         cp2 += 2;
8215         if (cp2 == dirend) break;
8216       }
8217       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8218                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8219         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8220         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8221         if (!*(cp2+3)) {
8222           *(cp1++) = '.';  /* Simulate trailing '/' */
8223           cp2 += 2;  /* for loop will incr this to == dirend */
8224         }
8225         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8226       }
8227       else {
8228         if (decc_efs_charset == 0)
8229           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8230         else {
8231           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
8232           *(cp1++) = '.';
8233         }
8234       }
8235     }
8236     else {
8237       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
8238       if (*cp2 == '.') {
8239         if (decc_efs_charset == 0)
8240           *(cp1++) = '_';
8241         else {
8242           *(cp1++) = '^';
8243           *(cp1++) = '.';
8244         }
8245       }
8246       else                  *(cp1++) =  *cp2;
8247       infront = 1;
8248     }
8249   }
8250   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8251   if (hasdir) *(cp1++) = ']';
8252   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
8253   /* fixme for ODS5 */
8254   no_type_seen = 0;
8255   if (cp2 > lastdot)
8256     no_type_seen = 1;
8257   while (*cp2) {
8258     switch(*cp2) {
8259     case '?':
8260         if (decc_efs_charset == 0)
8261           *(cp1++) = '%';
8262         else
8263           *(cp1++) = '?';
8264         cp2++;
8265     case ' ':
8266         *(cp1)++ = '^';
8267         *(cp1)++ = '_';
8268         cp2++;
8269         break;
8270     case '.':
8271         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8272             decc_readdir_dropdotnotype) {
8273           *(cp1)++ = '^';
8274           *(cp1)++ = '.';
8275           cp2++;
8276
8277           /* trailing dot ==> '^..' on VMS */
8278           if (*cp2 == '\0') {
8279             *(cp1++) = '.';
8280             no_type_seen = 0;
8281           }
8282         }
8283         else {
8284           *(cp1++) = *(cp2++);
8285           no_type_seen = 0;
8286         }
8287         break;
8288     case '$':
8289          /* This could be a macro to be passed through */
8290         *(cp1++) = *(cp2++);
8291         if (*cp2 == '(') {
8292         const char * save_cp2;
8293         char * save_cp1;
8294         int is_macro;
8295
8296             /* paranoid check */
8297             save_cp2 = cp2;
8298             save_cp1 = cp1;
8299             is_macro = 0;
8300
8301             /* Test through */
8302             *(cp1++) = *(cp2++);
8303             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8304                 *(cp1++) = *(cp2++);
8305                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8306                     *(cp1++) = *(cp2++);
8307                 }
8308                 if (*cp2 == ')') {
8309                     *(cp1++) = *(cp2++);
8310                     is_macro = 1;
8311                 }
8312             }
8313             if (is_macro == 0) {
8314                 /* Not really a macro - never mind */
8315                 cp2 = save_cp2;
8316                 cp1 = save_cp1;
8317             }
8318         }
8319         break;
8320     case '\"':
8321     case '~':
8322     case '`':
8323     case '!':
8324     case '#':
8325     case '%':
8326     case '^':
8327         /* Don't escape again if following character is
8328          * already something we escape.
8329          */
8330         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8331             *(cp1++) = *(cp2++);
8332             break;
8333         }
8334         /* But otherwise fall through and escape it. */
8335     case '&':
8336     case '(':
8337     case ')':
8338     case '=':
8339     case '+':
8340     case '\'':
8341     case '@':
8342     case '[':
8343     case ']':
8344     case '{':
8345     case '}':
8346     case ':':
8347     case '\\':
8348     case '|':
8349     case '<':
8350     case '>':
8351         *(cp1++) = '^';
8352         *(cp1++) = *(cp2++);
8353         break;
8354     case ';':
8355         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8356          * which is wrong.  UNIX notation should be ".dir." unless
8357          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8358          * changing this behavior could break more things at this time.
8359          * efs character set effectively does not allow "." to be a version
8360          * delimiter as a further complication about changing this.
8361          */
8362         if (decc_filename_unix_report != 0) {
8363           *(cp1++) = '^';
8364         }
8365         *(cp1++) = *(cp2++);
8366         break;
8367     default:
8368         *(cp1++) = *(cp2++);
8369     }
8370   }
8371   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8372   char *lcp1;
8373     lcp1 = cp1;
8374     lcp1--;
8375      /* Fix me for "^]", but that requires making sure that you do
8376       * not back up past the start of the filename
8377       */
8378     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8379       *cp1++ = '.';
8380   }
8381   *cp1 = '\0';
8382
8383   if (utf8_flag != NULL)
8384     *utf8_flag = 0;
8385   return rslt;
8386
8387 }  /* end of do_tovmsspec() */
8388 /*}}}*/
8389 /* External entry points */
8390 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8391   { return do_tovmsspec(path,buf,0,NULL); }
8392 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8393   { return do_tovmsspec(path,buf,1,NULL); }
8394 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8395   { return do_tovmsspec(path,buf,0,utf8_fl); }
8396 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8397   { return do_tovmsspec(path,buf,1,utf8_fl); }
8398
8399 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8400 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8401   static char __tovmspath_retbuf[VMS_MAXRSS];
8402   int vmslen;
8403   char *pathified, *vmsified, *cp;
8404
8405   if (path == NULL) return NULL;
8406   pathified = PerlMem_malloc(VMS_MAXRSS);
8407   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8408   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
8409     PerlMem_free(pathified);
8410     return NULL;
8411   }
8412
8413   vmsified = NULL;
8414   if (buf == NULL)
8415      Newx(vmsified, VMS_MAXRSS, char);
8416   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8417     PerlMem_free(pathified);
8418     if (vmsified) Safefree(vmsified);
8419     return NULL;
8420   }
8421   PerlMem_free(pathified);
8422   if (buf) {
8423     return buf;
8424   }
8425   else if (ts) {
8426     vmslen = strlen(vmsified);
8427     Newx(cp,vmslen+1,char);
8428     memcpy(cp,vmsified,vmslen);
8429     cp[vmslen] = '\0';
8430     Safefree(vmsified);
8431     return cp;
8432   }
8433   else {
8434     strcpy(__tovmspath_retbuf,vmsified);
8435     Safefree(vmsified);
8436     return __tovmspath_retbuf;
8437   }
8438
8439 }  /* end of do_tovmspath() */
8440 /*}}}*/
8441 /* External entry points */
8442 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8443   { return do_tovmspath(path,buf,0, NULL); }
8444 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8445   { return do_tovmspath(path,buf,1, NULL); }
8446 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8447   { return do_tovmspath(path,buf,0,utf8_fl); }
8448 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8449   { return do_tovmspath(path,buf,1,utf8_fl); }
8450
8451
8452 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8453 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8454   static char __tounixpath_retbuf[VMS_MAXRSS];
8455   int unixlen;
8456   char *pathified, *unixified, *cp;
8457
8458   if (path == NULL) return NULL;
8459   pathified = PerlMem_malloc(VMS_MAXRSS);
8460   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8461   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
8462     PerlMem_free(pathified);
8463     return NULL;
8464   }
8465
8466   unixified = NULL;
8467   if (buf == NULL) {
8468       Newx(unixified, VMS_MAXRSS, char);
8469   }
8470   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
8471     PerlMem_free(pathified);
8472     if (unixified) Safefree(unixified);
8473     return NULL;
8474   }
8475   PerlMem_free(pathified);
8476   if (buf) {
8477     return buf;
8478   }
8479   else if (ts) {
8480     unixlen = strlen(unixified);
8481     Newx(cp,unixlen+1,char);
8482     memcpy(cp,unixified,unixlen);
8483     cp[unixlen] = '\0';
8484     Safefree(unixified);
8485     return cp;
8486   }
8487   else {
8488     strcpy(__tounixpath_retbuf,unixified);
8489     Safefree(unixified);
8490     return __tounixpath_retbuf;
8491   }
8492
8493 }  /* end of do_tounixpath() */
8494 /*}}}*/
8495 /* External entry points */
8496 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8497   { return do_tounixpath(path,buf,0,NULL); }
8498 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8499   { return do_tounixpath(path,buf,1,NULL); }
8500 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8501   { return do_tounixpath(path,buf,0,utf8_fl); }
8502 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8503   { return do_tounixpath(path,buf,1,utf8_fl); }
8504
8505 /*
8506  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
8507  *
8508  *****************************************************************************
8509  *                                                                           *
8510  *  Copyright (C) 1989-1994, 2007 by                                         *
8511  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
8512  *                                                                           *
8513  *  Permission is hereby granted for the reproduction of this software       *
8514  *  on condition that this copyright notice is included in source            *
8515  *  distributions of the software.  The code may be modified and             *
8516  *  distributed under the same terms as Perl itself.                         *
8517  *                                                                           *
8518  *  27-Aug-1994 Modified for inclusion in perl5                              *
8519  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
8520  *****************************************************************************
8521  */
8522
8523 /*
8524  * getredirection() is intended to aid in porting C programs
8525  * to VMS (Vax-11 C).  The native VMS environment does not support
8526  * '>' and '<' I/O redirection, or command line wild card expansion,
8527  * or a command line pipe mechanism using the '|' AND background
8528  * command execution '&'.  All of these capabilities are provided to any
8529  * C program which calls this procedure as the first thing in the
8530  * main program.
8531  * The piping mechanism will probably work with almost any 'filter' type
8532  * of program.  With suitable modification, it may useful for other
8533  * portability problems as well.
8534  *
8535  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
8536  */
8537 struct list_item
8538     {
8539     struct list_item *next;
8540     char *value;
8541     };
8542
8543 static void add_item(struct list_item **head,
8544                      struct list_item **tail,
8545                      char *value,
8546                      int *count);
8547
8548 static void mp_expand_wild_cards(pTHX_ char *item,
8549                                 struct list_item **head,
8550                                 struct list_item **tail,
8551                                 int *count);
8552
8553 static int background_process(pTHX_ int argc, char **argv);
8554
8555 static void pipe_and_fork(pTHX_ char **cmargv);
8556
8557 /*{{{ void getredirection(int *ac, char ***av)*/
8558 static void
8559 mp_getredirection(pTHX_ int *ac, char ***av)
8560 /*
8561  * Process vms redirection arg's.  Exit if any error is seen.
8562  * If getredirection() processes an argument, it is erased
8563  * from the vector.  getredirection() returns a new argc and argv value.
8564  * In the event that a background command is requested (by a trailing "&"),
8565  * this routine creates a background subprocess, and simply exits the program.
8566  *
8567  * Warning: do not try to simplify the code for vms.  The code
8568  * presupposes that getredirection() is called before any data is
8569  * read from stdin or written to stdout.
8570  *
8571  * Normal usage is as follows:
8572  *
8573  *      main(argc, argv)
8574  *      int             argc;
8575  *      char            *argv[];
8576  *      {
8577  *              getredirection(&argc, &argv);
8578  *      }
8579  */
8580 {
8581     int                 argc = *ac;     /* Argument Count         */
8582     char                **argv = *av;   /* Argument Vector        */
8583     char                *ap;            /* Argument pointer       */
8584     int                 j;              /* argv[] index           */
8585     int                 item_count = 0; /* Count of Items in List */
8586     struct list_item    *list_head = 0; /* First Item in List       */
8587     struct list_item    *list_tail;     /* Last Item in List        */
8588     char                *in = NULL;     /* Input File Name          */
8589     char                *out = NULL;    /* Output File Name         */
8590     char                *outmode = "w"; /* Mode to Open Output File */
8591     char                *err = NULL;    /* Error File Name          */
8592     char                *errmode = "w"; /* Mode to Open Error File  */
8593     int                 cmargc = 0;     /* Piped Command Arg Count  */
8594     char                **cmargv = NULL;/* Piped Command Arg Vector */
8595
8596     /*
8597      * First handle the case where the last thing on the line ends with
8598      * a '&'.  This indicates the desire for the command to be run in a
8599      * subprocess, so we satisfy that desire.
8600      */
8601     ap = argv[argc-1];
8602     if (0 == strcmp("&", ap))
8603        exit(background_process(aTHX_ --argc, argv));
8604     if (*ap && '&' == ap[strlen(ap)-1])
8605         {
8606         ap[strlen(ap)-1] = '\0';
8607        exit(background_process(aTHX_ argc, argv));
8608         }
8609     /*
8610      * Now we handle the general redirection cases that involve '>', '>>',
8611      * '<', and pipes '|'.
8612      */
8613     for (j = 0; j < argc; ++j)
8614         {
8615         if (0 == strcmp("<", argv[j]))
8616             {
8617             if (j+1 >= argc)
8618                 {
8619                 fprintf(stderr,"No input file after < on command line");
8620                 exit(LIB$_WRONUMARG);
8621                 }
8622             in = argv[++j];
8623             continue;
8624             }
8625         if ('<' == *(ap = argv[j]))
8626             {
8627             in = 1 + ap;
8628             continue;
8629             }
8630         if (0 == strcmp(">", ap))
8631             {
8632             if (j+1 >= argc)
8633                 {
8634                 fprintf(stderr,"No output file after > on command line");
8635                 exit(LIB$_WRONUMARG);
8636                 }
8637             out = argv[++j];
8638             continue;
8639             }
8640         if ('>' == *ap)
8641             {
8642             if ('>' == ap[1])
8643                 {
8644                 outmode = "a";
8645                 if ('\0' == ap[2])
8646                     out = argv[++j];
8647                 else
8648                     out = 2 + ap;
8649                 }
8650             else
8651                 out = 1 + ap;
8652             if (j >= argc)
8653                 {
8654                 fprintf(stderr,"No output file after > or >> on command line");
8655                 exit(LIB$_WRONUMARG);
8656                 }
8657             continue;
8658             }
8659         if (('2' == *ap) && ('>' == ap[1]))
8660             {
8661             if ('>' == ap[2])
8662                 {
8663                 errmode = "a";
8664                 if ('\0' == ap[3])
8665                     err = argv[++j];
8666                 else
8667                     err = 3 + ap;
8668                 }
8669             else
8670                 if ('\0' == ap[2])
8671                     err = argv[++j];
8672                 else
8673                     err = 2 + ap;
8674             if (j >= argc)
8675                 {
8676                 fprintf(stderr,"No output file after 2> or 2>> on command line");
8677                 exit(LIB$_WRONUMARG);
8678                 }
8679             continue;
8680             }
8681         if (0 == strcmp("|", argv[j]))
8682             {
8683             if (j+1 >= argc)
8684                 {
8685                 fprintf(stderr,"No command into which to pipe on command line");
8686                 exit(LIB$_WRONUMARG);
8687                 }
8688             cmargc = argc-(j+1);
8689             cmargv = &argv[j+1];
8690             argc = j;
8691             continue;
8692             }
8693         if ('|' == *(ap = argv[j]))
8694             {
8695             ++argv[j];
8696             cmargc = argc-j;
8697             cmargv = &argv[j];
8698             argc = j;
8699             continue;
8700             }
8701         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
8702         }
8703     /*
8704      * Allocate and fill in the new argument vector, Some Unix's terminate
8705      * the list with an extra null pointer.
8706      */
8707     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
8708     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8709     *av = argv;
8710     for (j = 0; j < item_count; ++j, list_head = list_head->next)
8711         argv[j] = list_head->value;
8712     *ac = item_count;
8713     if (cmargv != NULL)
8714         {
8715         if (out != NULL)
8716             {
8717             fprintf(stderr,"'|' and '>' may not both be specified on command line");
8718             exit(LIB$_INVARGORD);
8719             }
8720         pipe_and_fork(aTHX_ cmargv);
8721         }
8722
8723     /* Check for input from a pipe (mailbox) */
8724
8725     if (in == NULL && 1 == isapipe(0))
8726         {
8727         char mbxname[L_tmpnam];
8728         long int bufsize;
8729         long int dvi_item = DVI$_DEVBUFSIZ;
8730         $DESCRIPTOR(mbxnam, "");
8731         $DESCRIPTOR(mbxdevnam, "");
8732
8733         /* Input from a pipe, reopen it in binary mode to disable       */
8734         /* carriage control processing.                                 */
8735
8736         fgetname(stdin, mbxname);
8737         mbxnam.dsc$a_pointer = mbxname;
8738         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
8739         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
8740         mbxdevnam.dsc$a_pointer = mbxname;
8741         mbxdevnam.dsc$w_length = sizeof(mbxname);
8742         dvi_item = DVI$_DEVNAM;
8743         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
8744         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
8745         set_errno(0);
8746         set_vaxc_errno(1);
8747         freopen(mbxname, "rb", stdin);
8748         if (errno != 0)
8749             {
8750             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
8751             exit(vaxc$errno);
8752             }
8753         }
8754     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
8755         {
8756         fprintf(stderr,"Can't open input file %s as stdin",in);
8757         exit(vaxc$errno);
8758         }
8759     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
8760         {
8761         fprintf(stderr,"Can't open output file %s as stdout",out);
8762         exit(vaxc$errno);
8763         }
8764         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
8765
8766     if (err != NULL) {
8767         if (strcmp(err,"&1") == 0) {
8768             dup2(fileno(stdout), fileno(stderr));
8769             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
8770         } else {
8771         FILE *tmperr;
8772         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
8773             {
8774             fprintf(stderr,"Can't open error file %s as stderr",err);
8775             exit(vaxc$errno);
8776             }
8777             fclose(tmperr);
8778            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
8779                 {
8780                 exit(vaxc$errno);
8781                 }
8782             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
8783         }
8784         }
8785 #ifdef ARGPROC_DEBUG
8786     PerlIO_printf(Perl_debug_log, "Arglist:\n");
8787     for (j = 0; j < *ac;  ++j)
8788         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
8789 #endif
8790    /* Clear errors we may have hit expanding wildcards, so they don't
8791       show up in Perl's $! later */
8792    set_errno(0); set_vaxc_errno(1);
8793 }  /* end of getredirection() */
8794 /*}}}*/
8795
8796 static void add_item(struct list_item **head,
8797                      struct list_item **tail,
8798                      char *value,
8799                      int *count)
8800 {
8801     if (*head == 0)
8802         {
8803         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8804         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8805         *tail = *head;
8806         }
8807     else {
8808         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8809         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8810         *tail = (*tail)->next;
8811         }
8812     (*tail)->value = value;
8813     ++(*count);
8814 }
8815
8816 static void mp_expand_wild_cards(pTHX_ char *item,
8817                               struct list_item **head,
8818                               struct list_item **tail,
8819                               int *count)
8820 {
8821 int expcount = 0;
8822 unsigned long int context = 0;
8823 int isunix = 0;
8824 int item_len = 0;
8825 char *had_version;
8826 char *had_device;
8827 int had_directory;
8828 char *devdir,*cp;
8829 char *vmsspec;
8830 $DESCRIPTOR(filespec, "");
8831 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
8832 $DESCRIPTOR(resultspec, "");
8833 unsigned long int lff_flags = 0;
8834 int sts;
8835 int rms_sts;
8836
8837 #ifdef VMS_LONGNAME_SUPPORT
8838     lff_flags = LIB$M_FIL_LONG_NAMES;
8839 #endif
8840
8841     for (cp = item; *cp; cp++) {
8842         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
8843         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
8844     }
8845     if (!*cp || isspace(*cp))
8846         {
8847         add_item(head, tail, item, count);
8848         return;
8849         }
8850     else
8851         {
8852      /* "double quoted" wild card expressions pass as is */
8853      /* From DCL that means using e.g.:                  */
8854      /* perl program """perl.*"""                        */
8855      item_len = strlen(item);
8856      if ( '"' == *item && '"' == item[item_len-1] )
8857        {
8858        item++;
8859        item[item_len-2] = '\0';
8860        add_item(head, tail, item, count);
8861        return;
8862        }
8863      }
8864     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
8865     resultspec.dsc$b_class = DSC$K_CLASS_D;
8866     resultspec.dsc$a_pointer = NULL;
8867     vmsspec = PerlMem_malloc(VMS_MAXRSS);
8868     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8869     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
8870       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
8871     if (!isunix || !filespec.dsc$a_pointer)
8872       filespec.dsc$a_pointer = item;
8873     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
8874     /*
8875      * Only return version specs, if the caller specified a version
8876      */
8877     had_version = strchr(item, ';');
8878     /*
8879      * Only return device and directory specs, if the caller specifed either.
8880      */
8881     had_device = strchr(item, ':');
8882     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
8883
8884     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
8885                                  (&filespec, &resultspec, &context,
8886                                   &defaultspec, 0, &rms_sts, &lff_flags)))
8887         {
8888         char *string;
8889         char *c;
8890
8891         string = PerlMem_malloc(resultspec.dsc$w_length+1);
8892         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8893         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
8894         string[resultspec.dsc$w_length] = '\0';
8895         if (NULL == had_version)
8896             *(strrchr(string, ';')) = '\0';
8897         if ((!had_directory) && (had_device == NULL))
8898             {
8899             if (NULL == (devdir = strrchr(string, ']')))
8900                 devdir = strrchr(string, '>');
8901             strcpy(string, devdir + 1);
8902             }
8903         /*
8904          * Be consistent with what the C RTL has already done to the rest of
8905          * the argv items and lowercase all of these names.
8906          */
8907         if (!decc_efs_case_preserve) {
8908             for (c = string; *c; ++c)
8909             if (isupper(*c))
8910                 *c = tolower(*c);
8911         }
8912         if (isunix) trim_unixpath(string,item,1);
8913         add_item(head, tail, string, count);
8914         ++expcount;
8915     }
8916     PerlMem_free(vmsspec);
8917     if (sts != RMS$_NMF)
8918         {
8919         set_vaxc_errno(sts);
8920         switch (sts)
8921             {
8922             case RMS$_FNF: case RMS$_DNF:
8923                 set_errno(ENOENT); break;
8924             case RMS$_DIR:
8925                 set_errno(ENOTDIR); break;
8926             case RMS$_DEV:
8927                 set_errno(ENODEV); break;
8928             case RMS$_FNM: case RMS$_SYN:
8929                 set_errno(EINVAL); break;
8930             case RMS$_PRV:
8931                 set_errno(EACCES); break;
8932             default:
8933                 _ckvmssts_noperl(sts);
8934             }
8935         }
8936     if (expcount == 0)
8937         add_item(head, tail, item, count);
8938     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
8939     _ckvmssts_noperl(lib$find_file_end(&context));
8940 }
8941
8942 static int child_st[2];/* Event Flag set when child process completes   */
8943
8944 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
8945
8946 static unsigned long int exit_handler(int *status)
8947 {
8948 short iosb[4];
8949
8950     if (0 == child_st[0])
8951         {
8952 #ifdef ARGPROC_DEBUG
8953         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
8954 #endif
8955         fflush(stdout);     /* Have to flush pipe for binary data to    */
8956                             /* terminate properly -- <tp@mccall.com>    */
8957         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
8958         sys$dassgn(child_chan);
8959         fclose(stdout);
8960         sys$synch(0, child_st);
8961         }
8962     return(1);
8963 }
8964
8965 static void sig_child(int chan)
8966 {
8967 #ifdef ARGPROC_DEBUG
8968     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
8969 #endif
8970     if (child_st[0] == 0)
8971         child_st[0] = 1;
8972 }
8973
8974 static struct exit_control_block exit_block =
8975     {
8976     0,
8977     exit_handler,
8978     1,
8979     &exit_block.exit_status,
8980     0
8981     };
8982
8983 static void
8984 pipe_and_fork(pTHX_ char **cmargv)
8985 {
8986     PerlIO *fp;
8987     struct dsc$descriptor_s *vmscmd;
8988     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
8989     int sts, j, l, ismcr, quote, tquote = 0;
8990
8991     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
8992     vms_execfree(vmscmd);
8993
8994     j = l = 0;
8995     p = subcmd;
8996     q = cmargv[0];
8997     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
8998               && toupper(*(q+2)) == 'R' && !*(q+3);
8999
9000     while (q && l < MAX_DCL_LINE_LENGTH) {
9001         if (!*q) {
9002             if (j > 0 && quote) {
9003                 *p++ = '"';
9004                 l++;
9005             }
9006             q = cmargv[++j];
9007             if (q) {
9008                 if (ismcr && j > 1) quote = 1;
9009                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
9010                 *p++ = ' ';
9011                 l++;
9012                 if (quote || tquote) {
9013                     *p++ = '"';
9014                     l++;
9015                 }
9016             }
9017         } else {
9018             if ((quote||tquote) && *q == '"') {
9019                 *p++ = '"';
9020                 l++;
9021             }
9022             *p++ = *q++;
9023             l++;
9024         }
9025     }
9026     *p = '\0';
9027
9028     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9029     if (fp == NULL) {
9030         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9031     }
9032 }
9033
9034 static int background_process(pTHX_ int argc, char **argv)
9035 {
9036 char command[MAX_DCL_SYMBOL + 1] = "$";
9037 $DESCRIPTOR(value, "");
9038 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9039 static $DESCRIPTOR(null, "NLA0:");
9040 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9041 char pidstring[80];
9042 $DESCRIPTOR(pidstr, "");
9043 int pid;
9044 unsigned long int flags = 17, one = 1, retsts;
9045 int len;
9046
9047     strcat(command, argv[0]);
9048     len = strlen(command);
9049     while (--argc && (len < MAX_DCL_SYMBOL))
9050         {
9051         strcat(command, " \"");
9052         strcat(command, *(++argv));
9053         strcat(command, "\"");
9054         len = strlen(command);
9055         }
9056     value.dsc$a_pointer = command;
9057     value.dsc$w_length = strlen(value.dsc$a_pointer);
9058     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9059     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9060     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9061         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9062     }
9063     else {
9064         _ckvmssts_noperl(retsts);
9065     }
9066 #ifdef ARGPROC_DEBUG
9067     PerlIO_printf(Perl_debug_log, "%s\n", command);
9068 #endif
9069     sprintf(pidstring, "%08X", pid);
9070     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9071     pidstr.dsc$a_pointer = pidstring;
9072     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9073     lib$set_symbol(&pidsymbol, &pidstr);
9074     return(SS$_NORMAL);
9075 }
9076 /*}}}*/
9077 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9078
9079
9080 /* OS-specific initialization at image activation (not thread startup) */
9081 /* Older VAXC header files lack these constants */
9082 #ifndef JPI$_RIGHTS_SIZE
9083 #  define JPI$_RIGHTS_SIZE 817
9084 #endif
9085 #ifndef KGB$M_SUBSYSTEM
9086 #  define KGB$M_SUBSYSTEM 0x8
9087 #endif
9088
9089 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9090
9091 /*{{{void vms_image_init(int *, char ***)*/
9092 void
9093 vms_image_init(int *argcp, char ***argvp)
9094 {
9095   int status;
9096   char val_str[10];
9097   char eqv[LNM$C_NAMLENGTH+1] = "";
9098   unsigned int len, tabct = 8, tabidx = 0;
9099   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9100   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9101   unsigned short int dummy, rlen;
9102   struct dsc$descriptor_s **tabvec;
9103 #if defined(PERL_IMPLICIT_CONTEXT)
9104   pTHX = NULL;
9105 #endif
9106   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
9107                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
9108                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9109                                  {          0,                0,    0,      0} };
9110
9111 #ifdef KILL_BY_SIGPRC
9112     Perl_csighandler_init();
9113 #endif
9114
9115     /* This was moved from the pre-image init handler because on threaded */
9116     /* Perl it was always returning 0 for the default value. */
9117     status = simple_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
9118     if (status > 0) {
9119         int s;
9120         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9121         if (s > 0) {
9122             int initial;
9123             initial = decc$feature_get_value(s, 4);
9124             if (initial >= 0) {
9125                 /* initial is -1 if nothing has set the feature */
9126                 /* initial is 1 if the logical name is present */
9127                 decc_disable_posix_root = decc$feature_get_value(s, 1);
9128
9129                 /* If the value is not valid, force the feature off */
9130                 if (decc_disable_posix_root < 0) {
9131                     decc$feature_set_value(s, 1, 1);
9132                     decc_disable_posix_root = 1;
9133                 }
9134             }
9135             else {
9136                 /* Traditionally Perl assumes this is off */
9137                 decc_disable_posix_root = 1;
9138                 decc$feature_set_value(s, 1, 1);
9139             }
9140         }
9141     }
9142
9143
9144   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9145   _ckvmssts_noperl(iosb[0]);
9146   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9147     if (iprv[i]) {           /* Running image installed with privs? */
9148       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
9149       will_taint = TRUE;
9150       break;
9151     }
9152   }
9153   /* Rights identifiers might trigger tainting as well. */
9154   if (!will_taint && (rlen || rsz)) {
9155     while (rlen < rsz) {
9156       /* We didn't get all the identifiers on the first pass.  Allocate a
9157        * buffer much larger than $GETJPI wants (rsz is size in bytes that
9158        * were needed to hold all identifiers at time of last call; we'll
9159        * allocate that many unsigned long ints), and go back and get 'em.
9160        * If it gave us less than it wanted to despite ample buffer space,
9161        * something's broken.  Is your system missing a system identifier?
9162        */
9163       if (rsz <= jpilist[1].buflen) {
9164          /* Perl_croak accvios when used this early in startup. */
9165          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9166                          rsz, (unsigned long) jpilist[1].buflen,
9167                          "Check your rights database for corruption.\n");
9168          exit(SS$_ABORT);
9169       }
9170       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9171       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9172       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9173       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9174       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9175       _ckvmssts_noperl(iosb[0]);
9176     }
9177     mask = jpilist[1].bufadr;
9178     /* Check attribute flags for each identifier (2nd longword); protected
9179      * subsystem identifiers trigger tainting.
9180      */
9181     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9182       if (mask[i] & KGB$M_SUBSYSTEM) {
9183         will_taint = TRUE;
9184         break;
9185       }
9186     }
9187     if (mask != rlst) PerlMem_free(mask);
9188   }
9189
9190   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9191    * logical, some versions of the CRTL will add a phanthom /000000/
9192    * directory.  This needs to be removed.
9193    */
9194   if (decc_filename_unix_report) {
9195   char * zeros;
9196   int ulen;
9197     ulen = strlen(argvp[0][0]);
9198     if (ulen > 7) {
9199       zeros = strstr(argvp[0][0], "/000000/");
9200       if (zeros != NULL) {
9201         int mlen;
9202         mlen = ulen - (zeros - argvp[0][0]) - 7;
9203         memmove(zeros, &zeros[7], mlen);
9204         ulen = ulen - 7;
9205         argvp[0][0][ulen] = '\0';
9206       }
9207     }
9208     /* It also may have a trailing dot that needs to be removed otherwise
9209      * it will be converted to VMS mode incorrectly.
9210      */
9211     ulen--;
9212     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9213       argvp[0][0][ulen] = '\0';
9214   }
9215
9216   /* We need to use this hack to tell Perl it should run with tainting,
9217    * since its tainting flag may be part of the PL_curinterp struct, which
9218    * hasn't been allocated when vms_image_init() is called.
9219    */
9220   if (will_taint) {
9221     char **newargv, **oldargv;
9222     oldargv = *argvp;
9223     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9224     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9225     newargv[0] = oldargv[0];
9226     newargv[1] = PerlMem_malloc(3 * sizeof(char));
9227     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9228     strcpy(newargv[1], "-T");
9229     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9230     (*argcp)++;
9231     newargv[*argcp] = NULL;
9232     /* We orphan the old argv, since we don't know where it's come from,
9233      * so we don't know how to free it.
9234      */
9235     *argvp = newargv;
9236   }
9237   else {  /* Did user explicitly request tainting? */
9238     int i;
9239     char *cp, **av = *argvp;
9240     for (i = 1; i < *argcp; i++) {
9241       if (*av[i] != '-') break;
9242       for (cp = av[i]+1; *cp; cp++) {
9243         if (*cp == 'T') { will_taint = 1; break; }
9244         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9245                   strchr("DFIiMmx",*cp)) break;
9246       }
9247       if (will_taint) break;
9248     }
9249   }
9250
9251   for (tabidx = 0;
9252        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9253        tabidx++) {
9254     if (!tabidx) {
9255       tabvec = (struct dsc$descriptor_s **)
9256             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9257       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9258     }
9259     else if (tabidx >= tabct) {
9260       tabct += 8;
9261       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9262       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9263     }
9264     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9265     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9266     tabvec[tabidx]->dsc$w_length  = 0;
9267     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9268     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
9269     tabvec[tabidx]->dsc$a_pointer = NULL;
9270     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9271   }
9272   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9273
9274   getredirection(argcp,argvp);
9275 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9276   {
9277 # include <reentrancy.h>
9278   decc$set_reentrancy(C$C_MULTITHREAD);
9279   }
9280 #endif
9281   return;
9282 }
9283 /*}}}*/
9284
9285
9286 /* trim_unixpath()
9287  * Trim Unix-style prefix off filespec, so it looks like what a shell
9288  * glob expansion would return (i.e. from specified prefix on, not
9289  * full path).  Note that returned filespec is Unix-style, regardless
9290  * of whether input filespec was VMS-style or Unix-style.
9291  *
9292  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9293  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9294  * vector of options; at present, only bit 0 is used, and if set tells
9295  * trim unixpath to try the current default directory as a prefix when
9296  * presented with a possibly ambiguous ... wildcard.
9297  *
9298  * Returns !=0 on success, with trimmed filespec replacing contents of
9299  * fspec, and 0 on failure, with contents of fpsec unchanged.
9300  */
9301 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9302 int
9303 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9304 {
9305   char *unixified, *unixwild,
9306        *template, *base, *end, *cp1, *cp2;
9307   register int tmplen, reslen = 0, dirs = 0;
9308
9309   if (!wildspec || !fspec) return 0;
9310
9311   unixwild = PerlMem_malloc(VMS_MAXRSS);
9312   if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9313   template = unixwild;
9314   if (strpbrk(wildspec,"]>:") != NULL) {
9315     if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
9316         PerlMem_free(unixwild);
9317         return 0;
9318     }
9319   }
9320   else {
9321     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
9322     unixwild[VMS_MAXRSS-1] = 0;
9323   }
9324   unixified = PerlMem_malloc(VMS_MAXRSS);
9325   if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9326   if (strpbrk(fspec,"]>:") != NULL) {
9327     if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
9328         PerlMem_free(unixwild);
9329         PerlMem_free(unixified);
9330         return 0;
9331     }
9332     else base = unixified;
9333     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9334      * check to see that final result fits into (isn't longer than) fspec */
9335     reslen = strlen(fspec);
9336   }
9337   else base = fspec;
9338
9339   /* No prefix or absolute path on wildcard, so nothing to remove */
9340   if (!*template || *template == '/') {
9341     PerlMem_free(unixwild);
9342     if (base == fspec) {
9343         PerlMem_free(unixified);
9344         return 1;
9345     }
9346     tmplen = strlen(unixified);
9347     if (tmplen > reslen) {
9348         PerlMem_free(unixified);
9349         return 0;  /* not enough space */
9350     }
9351     /* Copy unixified resultant, including trailing NUL */
9352     memmove(fspec,unixified,tmplen+1);
9353     PerlMem_free(unixified);
9354     return 1;
9355   }
9356
9357   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
9358   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
9359     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
9360     for (cp1 = end ;cp1 >= base; cp1--)
9361       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9362         { cp1++; break; }
9363     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9364     PerlMem_free(unixified);
9365     PerlMem_free(unixwild);
9366     return 1;
9367   }
9368   else {
9369     char *tpl, *lcres;
9370     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9371     int ells = 1, totells, segdirs, match;
9372     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9373                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9374
9375     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9376     totells = ells;
9377     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9378     tpl = PerlMem_malloc(VMS_MAXRSS);
9379     if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9380     if (ellipsis == template && opts & 1) {
9381       /* Template begins with an ellipsis.  Since we can't tell how many
9382        * directory names at the front of the resultant to keep for an
9383        * arbitrary starting point, we arbitrarily choose the current
9384        * default directory as a starting point.  If it's there as a prefix,
9385        * clip it off.  If not, fall through and act as if the leading
9386        * ellipsis weren't there (i.e. return shortest possible path that
9387        * could match template).
9388        */
9389       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9390           PerlMem_free(tpl);
9391           PerlMem_free(unixified);
9392           PerlMem_free(unixwild);
9393           return 0;
9394       }
9395       if (!decc_efs_case_preserve) {
9396         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9397           if (_tolower(*cp1) != _tolower(*cp2)) break;
9398       }
9399       segdirs = dirs - totells;  /* Min # of dirs we must have left */
9400       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9401       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9402         memmove(fspec,cp2+1,end - cp2);
9403         PerlMem_free(tpl);
9404         PerlMem_free(unixified);
9405         PerlMem_free(unixwild);
9406         return 1;
9407       }
9408     }
9409     /* First off, back up over constant elements at end of path */
9410     if (dirs) {
9411       for (front = end ; front >= base; front--)
9412          if (*front == '/' && !dirs--) { front++; break; }
9413     }
9414     lcres = PerlMem_malloc(VMS_MAXRSS);
9415     if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9416     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9417          cp1++,cp2++) {
9418             if (!decc_efs_case_preserve) {
9419                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
9420             }
9421             else {
9422                 *cp2 = *cp1;
9423             }
9424     }
9425     if (cp1 != '\0') {
9426         PerlMem_free(tpl);
9427         PerlMem_free(unixified);
9428         PerlMem_free(unixwild);
9429         PerlMem_free(lcres);
9430         return 0;  /* Path too long. */
9431     }
9432     lcend = cp2;
9433     *cp2 = '\0';  /* Pick up with memcpy later */
9434     lcfront = lcres + (front - base);
9435     /* Now skip over each ellipsis and try to match the path in front of it. */
9436     while (ells--) {
9437       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
9438         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
9439             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
9440       if (cp1 < template) break; /* template started with an ellipsis */
9441       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9442         ellipsis = cp1; continue;
9443       }
9444       wilddsc.dsc$a_pointer = tpl;
9445       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9446       nextell = cp1;
9447       for (segdirs = 0, cp2 = tpl;
9448            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9449            cp1++, cp2++) {
9450          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9451          else {
9452             if (!decc_efs_case_preserve) {
9453               *cp2 = _tolower(*cp1);  /* else lowercase for match */
9454             }
9455             else {
9456               *cp2 = *cp1;  /* else preserve case for match */
9457             }
9458          }
9459          if (*cp2 == '/') segdirs++;
9460       }
9461       if (cp1 != ellipsis - 1) {
9462           PerlMem_free(tpl);
9463           PerlMem_free(unixified);
9464           PerlMem_free(unixwild);
9465           PerlMem_free(lcres);
9466           return 0; /* Path too long */
9467       }
9468       /* Back up at least as many dirs as in template before matching */
9469       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9470         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9471       for (match = 0; cp1 > lcres;) {
9472         resdsc.dsc$a_pointer = cp1;
9473         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9474           match++;
9475           if (match == 1) lcfront = cp1;
9476         }
9477         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9478       }
9479       if (!match) {
9480         PerlMem_free(tpl);
9481         PerlMem_free(unixified);
9482         PerlMem_free(unixwild);
9483         PerlMem_free(lcres);
9484         return 0;  /* Can't find prefix ??? */
9485       }
9486       if (match > 1 && opts & 1) {
9487         /* This ... wildcard could cover more than one set of dirs (i.e.
9488          * a set of similar dir names is repeated).  If the template
9489          * contains more than 1 ..., upstream elements could resolve the
9490          * ambiguity, but it's not worth a full backtracking setup here.
9491          * As a quick heuristic, clip off the current default directory
9492          * if it's present to find the trimmed spec, else use the
9493          * shortest string that this ... could cover.
9494          */
9495         char def[NAM$C_MAXRSS+1], *st;
9496
9497         if (getcwd(def, sizeof def,0) == NULL) {
9498             PerlMem_free(unixified);
9499             PerlMem_free(unixwild);
9500             PerlMem_free(lcres);
9501             PerlMem_free(tpl);
9502             return 0;
9503         }
9504         if (!decc_efs_case_preserve) {
9505           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9506             if (_tolower(*cp1) != _tolower(*cp2)) break;
9507         }
9508         segdirs = dirs - totells;  /* Min # of dirs we must have left */
9509         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9510         if (*cp1 == '\0' && *cp2 == '/') {
9511           memmove(fspec,cp2+1,end - cp2);
9512           PerlMem_free(tpl);
9513           PerlMem_free(unixified);
9514           PerlMem_free(unixwild);
9515           PerlMem_free(lcres);
9516           return 1;
9517         }
9518         /* Nope -- stick with lcfront from above and keep going. */
9519       }
9520     }
9521     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
9522     PerlMem_free(tpl);
9523     PerlMem_free(unixified);
9524     PerlMem_free(unixwild);
9525     PerlMem_free(lcres);
9526     return 1;
9527     ellipsis = nextell;
9528   }
9529
9530 }  /* end of trim_unixpath() */
9531 /*}}}*/
9532
9533
9534 /*
9535  *  VMS readdir() routines.
9536  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
9537  *
9538  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
9539  *  Minor modifications to original routines.
9540  */
9541
9542 /* readdir may have been redefined by reentr.h, so make sure we get
9543  * the local version for what we do here.
9544  */
9545 #ifdef readdir
9546 # undef readdir
9547 #endif
9548 #if !defined(PERL_IMPLICIT_CONTEXT)
9549 # define readdir Perl_readdir
9550 #else
9551 # define readdir(a) Perl_readdir(aTHX_ a)
9552 #endif
9553
9554     /* Number of elements in vms_versions array */
9555 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
9556
9557 /*
9558  *  Open a directory, return a handle for later use.
9559  */
9560 /*{{{ DIR *opendir(char*name) */
9561 DIR *
9562 Perl_opendir(pTHX_ const char *name)
9563 {
9564     DIR *dd;
9565     char *dir;
9566     Stat_t sb;
9567
9568     Newx(dir, VMS_MAXRSS, char);
9569     if (do_tovmspath(name,dir,0,NULL) == NULL) {
9570       Safefree(dir);
9571       return NULL;
9572     }
9573     /* Check access before stat; otherwise stat does not
9574      * accurately report whether it's a directory.
9575      */
9576     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
9577       /* cando_by_name has already set errno */
9578       Safefree(dir);
9579       return NULL;
9580     }
9581     if (flex_stat(dir,&sb) == -1) return NULL;
9582     if (!S_ISDIR(sb.st_mode)) {
9583       Safefree(dir);
9584       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
9585       return NULL;
9586     }
9587     /* Get memory for the handle, and the pattern. */
9588     Newx(dd,1,DIR);
9589     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
9590
9591     /* Fill in the fields; mainly playing with the descriptor. */
9592     sprintf(dd->pattern, "%s*.*",dir);
9593     Safefree(dir);
9594     dd->context = 0;
9595     dd->count = 0;
9596     dd->flags = 0;
9597     /* By saying we always want the result of readdir() in unix format, we
9598      * are really saying we want all the escapes removed.  Otherwise the caller,
9599      * having no way to know whether it's already in VMS format, might send it
9600      * through tovmsspec again, thus double escaping.
9601      */
9602     dd->flags = PERL_VMSDIR_M_UNIXSPECS;
9603     dd->pat.dsc$a_pointer = dd->pattern;
9604     dd->pat.dsc$w_length = strlen(dd->pattern);
9605     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
9606     dd->pat.dsc$b_class = DSC$K_CLASS_S;
9607 #if defined(USE_ITHREADS)
9608     Newx(dd->mutex,1,perl_mutex);
9609     MUTEX_INIT( (perl_mutex *) dd->mutex );
9610 #else
9611     dd->mutex = NULL;
9612 #endif
9613
9614     return dd;
9615 }  /* end of opendir() */
9616 /*}}}*/
9617
9618 /*
9619  *  Set the flag to indicate we want versions or not.
9620  */
9621 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
9622 void
9623 vmsreaddirversions(DIR *dd, int flag)
9624 {
9625     if (flag)
9626         dd->flags |= PERL_VMSDIR_M_VERSIONS;
9627     else
9628         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9629 }
9630 /*}}}*/
9631
9632 /*
9633  *  Free up an opened directory.
9634  */
9635 /*{{{ void closedir(DIR *dd)*/
9636 void
9637 Perl_closedir(DIR *dd)
9638 {
9639     int sts;
9640
9641     sts = lib$find_file_end(&dd->context);
9642     Safefree(dd->pattern);
9643 #if defined(USE_ITHREADS)
9644     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
9645     Safefree(dd->mutex);
9646 #endif
9647     Safefree(dd);
9648 }
9649 /*}}}*/
9650
9651 /*
9652  *  Collect all the version numbers for the current file.
9653  */
9654 static void
9655 collectversions(pTHX_ DIR *dd)
9656 {
9657     struct dsc$descriptor_s     pat;
9658     struct dsc$descriptor_s     res;
9659     struct dirent *e;
9660     char *p, *text, *buff;
9661     int i;
9662     unsigned long context, tmpsts;
9663
9664     /* Convenient shorthand. */
9665     e = &dd->entry;
9666
9667     /* Add the version wildcard, ignoring the "*.*" put on before */
9668     i = strlen(dd->pattern);
9669     Newx(text,i + e->d_namlen + 3,char);
9670     strcpy(text, dd->pattern);
9671     sprintf(&text[i - 3], "%s;*", e->d_name);
9672
9673     /* Set up the pattern descriptor. */
9674     pat.dsc$a_pointer = text;
9675     pat.dsc$w_length = i + e->d_namlen - 1;
9676     pat.dsc$b_dtype = DSC$K_DTYPE_T;
9677     pat.dsc$b_class = DSC$K_CLASS_S;
9678
9679     /* Set up result descriptor. */
9680     Newx(buff, VMS_MAXRSS, char);
9681     res.dsc$a_pointer = buff;
9682     res.dsc$w_length = VMS_MAXRSS - 1;
9683     res.dsc$b_dtype = DSC$K_DTYPE_T;
9684     res.dsc$b_class = DSC$K_CLASS_S;
9685
9686     /* Read files, collecting versions. */
9687     for (context = 0, e->vms_verscount = 0;
9688          e->vms_verscount < VERSIZE(e);
9689          e->vms_verscount++) {
9690         unsigned long rsts;
9691         unsigned long flags = 0;
9692
9693 #ifdef VMS_LONGNAME_SUPPORT
9694         flags = LIB$M_FIL_LONG_NAMES;
9695 #endif
9696         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
9697         if (tmpsts == RMS$_NMF || context == 0) break;
9698         _ckvmssts(tmpsts);
9699         buff[VMS_MAXRSS - 1] = '\0';
9700         if ((p = strchr(buff, ';')))
9701             e->vms_versions[e->vms_verscount] = atoi(p + 1);
9702         else
9703             e->vms_versions[e->vms_verscount] = -1;
9704     }
9705
9706     _ckvmssts(lib$find_file_end(&context));
9707     Safefree(text);
9708     Safefree(buff);
9709
9710 }  /* end of collectversions() */
9711
9712 /*
9713  *  Read the next entry from the directory.
9714  */
9715 /*{{{ struct dirent *readdir(DIR *dd)*/
9716 struct dirent *
9717 Perl_readdir(pTHX_ DIR *dd)
9718 {
9719     struct dsc$descriptor_s     res;
9720     char *p, *buff;
9721     unsigned long int tmpsts;
9722     unsigned long rsts;
9723     unsigned long flags = 0;
9724     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
9725     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
9726
9727     /* Set up result descriptor, and get next file. */
9728     Newx(buff, VMS_MAXRSS, char);
9729     res.dsc$a_pointer = buff;
9730     res.dsc$w_length = VMS_MAXRSS - 1;
9731     res.dsc$b_dtype = DSC$K_DTYPE_T;
9732     res.dsc$b_class = DSC$K_CLASS_S;
9733
9734 #ifdef VMS_LONGNAME_SUPPORT
9735     flags = LIB$M_FIL_LONG_NAMES;
9736 #endif
9737
9738     tmpsts = lib$find_file
9739         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
9740     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
9741     if (!(tmpsts & 1)) {
9742       set_vaxc_errno(tmpsts);
9743       switch (tmpsts) {
9744         case RMS$_PRV:
9745           set_errno(EACCES); break;
9746         case RMS$_DEV:
9747           set_errno(ENODEV); break;
9748         case RMS$_DIR:
9749           set_errno(ENOTDIR); break;
9750         case RMS$_FNF: case RMS$_DNF:
9751           set_errno(ENOENT); break;
9752         default:
9753           set_errno(EVMSERR);
9754       }
9755       Safefree(buff);
9756       return NULL;
9757     }
9758     dd->count++;
9759     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
9760     buff[res.dsc$w_length] = '\0';
9761     p = buff + res.dsc$w_length;
9762     while (--p >= buff) if (!isspace(*p)) break;
9763     *p = '\0';
9764     if (!decc_efs_case_preserve) {
9765       for (p = buff; *p; p++) *p = _tolower(*p);
9766     }
9767
9768     /* Skip any directory component and just copy the name. */
9769     sts = vms_split_path
9770        (buff,
9771         &v_spec,
9772         &v_len,
9773         &r_spec,
9774         &r_len,
9775         &d_spec,
9776         &d_len,
9777         &n_spec,
9778         &n_len,
9779         &e_spec,
9780         &e_len,
9781         &vs_spec,
9782         &vs_len);
9783
9784     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
9785
9786         /* In Unix report mode, remove the ".dir;1" from the name */
9787         /* if it is a real directory. */
9788         if (decc_filename_unix_report || decc_efs_charset) {
9789             if ((e_len == 4) && (vs_len == 2) && (vs_spec[1] == '1')) {
9790                 if ((toupper(e_spec[1]) == 'D') &&
9791                     (toupper(e_spec[2]) == 'I') &&
9792                     (toupper(e_spec[3]) == 'R')) {
9793                     Stat_t statbuf;
9794                     int ret_sts;
9795
9796                     ret_sts = stat(buff, (stat_t *)&statbuf);
9797                     if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
9798                         e_len = 0;
9799                         e_spec[0] = 0;
9800                     }
9801                 }
9802             }
9803         }
9804
9805         /* Drop NULL extensions on UNIX file specification */
9806         if ((e_len == 1) && decc_readdir_dropdotnotype) {
9807             e_len = 0;
9808             e_spec[0] = '\0';
9809         }
9810     }
9811
9812     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
9813     dd->entry.d_name[n_len + e_len] = '\0';
9814     dd->entry.d_namlen = strlen(dd->entry.d_name);
9815
9816     /* Convert the filename to UNIX format if needed */
9817     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
9818
9819         /* Translate the encoded characters. */
9820         /* Fixme: Unicode handling could result in embedded 0 characters */
9821         if (strchr(dd->entry.d_name, '^') != NULL) {
9822             char new_name[256];
9823             char * q;
9824             p = dd->entry.d_name;
9825             q = new_name;
9826             while (*p != 0) {
9827                 int inchars_read, outchars_added;
9828                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
9829                 p += inchars_read;
9830                 q += outchars_added;
9831                 /* fix-me */
9832                 /* if outchars_added > 1, then this is a wide file specification */
9833                 /* Wide file specifications need to be passed in Perl */
9834                 /* counted strings apparently with a Unicode flag */
9835             }
9836             *q = 0;
9837             strcpy(dd->entry.d_name, new_name);
9838             dd->entry.d_namlen = strlen(dd->entry.d_name);
9839         }
9840     }
9841
9842     dd->entry.vms_verscount = 0;
9843     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
9844     Safefree(buff);
9845     return &dd->entry;
9846
9847 }  /* end of readdir() */
9848 /*}}}*/
9849
9850 /*
9851  *  Read the next entry from the directory -- thread-safe version.
9852  */
9853 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
9854 int
9855 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
9856 {
9857     int retval;
9858
9859     MUTEX_LOCK( (perl_mutex *) dd->mutex );
9860
9861     entry = readdir(dd);
9862     *result = entry;
9863     retval = ( *result == NULL ? errno : 0 );
9864
9865     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
9866
9867     return retval;
9868
9869 }  /* end of readdir_r() */
9870 /*}}}*/
9871
9872 /*
9873  *  Return something that can be used in a seekdir later.
9874  */
9875 /*{{{ long telldir(DIR *dd)*/
9876 long
9877 Perl_telldir(DIR *dd)
9878 {
9879     return dd->count;
9880 }
9881 /*}}}*/
9882
9883 /*
9884  *  Return to a spot where we used to be.  Brute force.
9885  */
9886 /*{{{ void seekdir(DIR *dd,long count)*/
9887 void
9888 Perl_seekdir(pTHX_ DIR *dd, long count)
9889 {
9890     int old_flags;
9891
9892     /* If we haven't done anything yet... */
9893     if (dd->count == 0)
9894         return;
9895
9896     /* Remember some state, and clear it. */
9897     old_flags = dd->flags;
9898     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9899     _ckvmssts(lib$find_file_end(&dd->context));
9900     dd->context = 0;
9901
9902     /* The increment is in readdir(). */
9903     for (dd->count = 0; dd->count < count; )
9904         readdir(dd);
9905
9906     dd->flags = old_flags;
9907
9908 }  /* end of seekdir() */
9909 /*}}}*/
9910
9911 /* VMS subprocess management
9912  *
9913  * my_vfork() - just a vfork(), after setting a flag to record that
9914  * the current script is trying a Unix-style fork/exec.
9915  *
9916  * vms_do_aexec() and vms_do_exec() are called in response to the
9917  * perl 'exec' function.  If this follows a vfork call, then they
9918  * call out the regular perl routines in doio.c which do an
9919  * execvp (for those who really want to try this under VMS).
9920  * Otherwise, they do exactly what the perl docs say exec should
9921  * do - terminate the current script and invoke a new command
9922  * (See below for notes on command syntax.)
9923  *
9924  * do_aspawn() and do_spawn() implement the VMS side of the perl
9925  * 'system' function.
9926  *
9927  * Note on command arguments to perl 'exec' and 'system': When handled
9928  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
9929  * are concatenated to form a DCL command string.  If the first non-numeric
9930  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
9931  * the command string is handed off to DCL directly.  Otherwise,
9932  * the first token of the command is taken as the filespec of an image
9933  * to run.  The filespec is expanded using a default type of '.EXE' and
9934  * the process defaults for device, directory, etc., and if found, the resultant
9935  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
9936  * the command string as parameters.  This is perhaps a bit complicated,
9937  * but I hope it will form a happy medium between what VMS folks expect
9938  * from lib$spawn and what Unix folks expect from exec.
9939  */
9940
9941 static int vfork_called;
9942
9943 /*{{{int my_vfork()*/
9944 int
9945 my_vfork()
9946 {
9947   vfork_called++;
9948   return vfork();
9949 }
9950 /*}}}*/
9951
9952
9953 static void
9954 vms_execfree(struct dsc$descriptor_s *vmscmd)
9955 {
9956   if (vmscmd) {
9957       if (vmscmd->dsc$a_pointer) {
9958           PerlMem_free(vmscmd->dsc$a_pointer);
9959       }
9960       PerlMem_free(vmscmd);
9961   }
9962 }
9963
9964 static char *
9965 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
9966 {
9967   char *junk, *tmps = NULL;
9968   register size_t cmdlen = 0;
9969   size_t rlen;
9970   register SV **idx;
9971   STRLEN n_a;
9972
9973   idx = mark;
9974   if (really) {
9975     tmps = SvPV(really,rlen);
9976     if (*tmps) {
9977       cmdlen += rlen + 1;
9978       idx++;
9979     }
9980   }
9981
9982   for (idx++; idx <= sp; idx++) {
9983     if (*idx) {
9984       junk = SvPVx(*idx,rlen);
9985       cmdlen += rlen ? rlen + 1 : 0;
9986     }
9987   }
9988   Newx(PL_Cmd, cmdlen+1, char);
9989
9990   if (tmps && *tmps) {
9991     strcpy(PL_Cmd,tmps);
9992     mark++;
9993   }
9994   else *PL_Cmd = '\0';
9995   while (++mark <= sp) {
9996     if (*mark) {
9997       char *s = SvPVx(*mark,n_a);
9998       if (!*s) continue;
9999       if (*PL_Cmd) strcat(PL_Cmd," ");
10000       strcat(PL_Cmd,s);
10001     }
10002   }
10003   return PL_Cmd;
10004
10005 }  /* end of setup_argstr() */
10006
10007
10008 static unsigned long int
10009 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10010                    struct dsc$descriptor_s **pvmscmd)
10011 {
10012   char * vmsspec;
10013   char * resspec;
10014   char image_name[NAM$C_MAXRSS+1];
10015   char image_argv[NAM$C_MAXRSS+1];
10016   $DESCRIPTOR(defdsc,".EXE");
10017   $DESCRIPTOR(defdsc2,".");
10018   struct dsc$descriptor_s resdsc;
10019   struct dsc$descriptor_s *vmscmd;
10020   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10021   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10022   register char *s, *rest, *cp, *wordbreak;
10023   char * cmd;
10024   int cmdlen;
10025   register int isdcl;
10026
10027   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10028   if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10029
10030   /* vmsspec is a DCL command buffer, not just a filename */
10031   vmsspec = PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10032   if (vmsspec == NULL)
10033       _ckvmssts_noperl(SS$_INSFMEM);
10034
10035   resspec = PerlMem_malloc(VMS_MAXRSS);
10036   if (resspec == NULL)
10037       _ckvmssts_noperl(SS$_INSFMEM);
10038
10039   /* Make a copy for modification */
10040   cmdlen = strlen(incmd);
10041   cmd = PerlMem_malloc(cmdlen+1);
10042   if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10043   strncpy(cmd, incmd, cmdlen);
10044   cmd[cmdlen] = 0;
10045   image_name[0] = 0;
10046   image_argv[0] = 0;
10047
10048   resdsc.dsc$a_pointer = resspec;
10049   resdsc.dsc$b_dtype  = DSC$K_DTYPE_T;
10050   resdsc.dsc$b_class  = DSC$K_CLASS_S;
10051   resdsc.dsc$w_length = VMS_MAXRSS - 1;
10052
10053   vmscmd->dsc$a_pointer = NULL;
10054   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
10055   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
10056   vmscmd->dsc$w_length = 0;
10057   if (pvmscmd) *pvmscmd = vmscmd;
10058
10059   if (suggest_quote) *suggest_quote = 0;
10060
10061   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10062     PerlMem_free(cmd);
10063     PerlMem_free(vmsspec);
10064     PerlMem_free(resspec);
10065     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
10066   }
10067
10068   s = cmd;
10069
10070   while (*s && isspace(*s)) s++;
10071
10072   if (*s == '@' || *s == '$') {
10073     vmsspec[0] = *s;  rest = s + 1;
10074     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10075   }
10076   else { cp = vmsspec; rest = s; }
10077   if (*rest == '.' || *rest == '/') {
10078     char *cp2;
10079     for (cp2 = resspec;
10080          *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10081          rest++, cp2++) *cp2 = *rest;
10082     *cp2 = '\0';
10083     if (do_tovmsspec(resspec,cp,0,NULL)) {
10084       s = vmsspec;
10085
10086       /* When a UNIX spec with no file type is translated to VMS, */
10087       /* A trailing '.' is appended under ODS-5 rules.            */
10088       /* Here we do not want that trailing "." as it prevents     */
10089       /* Looking for a implied ".exe" type. */
10090       if (decc_efs_charset) {
10091           int i;
10092           i = strlen(vmsspec);
10093           if (vmsspec[i-1] == '.') {
10094               vmsspec[i-1] = '\0';
10095           }
10096       }
10097
10098       if (*rest) {
10099         for (cp2 = vmsspec + strlen(vmsspec);
10100              *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10101              rest++, cp2++) *cp2 = *rest;
10102         *cp2 = '\0';
10103       }
10104     }
10105   }
10106   /* Intuit whether verb (first word of cmd) is a DCL command:
10107    *   - if first nonspace char is '@', it's a DCL indirection
10108    * otherwise
10109    *   - if verb contains a filespec separator, it's not a DCL command
10110    *   - if it doesn't, caller tells us whether to default to a DCL
10111    *     command, or to a local image unless told it's DCL (by leading '$')
10112    */
10113   if (*s == '@') {
10114       isdcl = 1;
10115       if (suggest_quote) *suggest_quote = 1;
10116   } else {
10117     register char *filespec = strpbrk(s,":<[.;");
10118     rest = wordbreak = strpbrk(s," \"\t/");
10119     if (!wordbreak) wordbreak = s + strlen(s);
10120     if (*s == '$') check_img = 0;
10121     if (filespec && (filespec < wordbreak)) isdcl = 0;
10122     else isdcl = !check_img;
10123   }
10124
10125   if (!isdcl) {
10126     int rsts;
10127     imgdsc.dsc$a_pointer = s;
10128     imgdsc.dsc$w_length = wordbreak - s;
10129     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10130     if (!(retsts&1)) {
10131         _ckvmssts_noperl(lib$find_file_end(&cxt));
10132         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10133       if (!(retsts & 1) && *s == '$') {
10134         _ckvmssts_noperl(lib$find_file_end(&cxt));
10135         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10136         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10137         if (!(retsts&1)) {
10138           _ckvmssts_noperl(lib$find_file_end(&cxt));
10139           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10140         }
10141       }
10142     }
10143     _ckvmssts_noperl(lib$find_file_end(&cxt));
10144
10145     if (retsts & 1) {
10146       FILE *fp;
10147       s = resspec;
10148       while (*s && !isspace(*s)) s++;
10149       *s = '\0';
10150
10151       /* check that it's really not DCL with no file extension */
10152       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10153       if (fp) {
10154         char b[256] = {0,0,0,0};
10155         read(fileno(fp), b, 256);
10156         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10157         if (isdcl) {
10158           int shebang_len;
10159
10160           /* Check for script */
10161           shebang_len = 0;
10162           if ((b[0] == '#') && (b[1] == '!'))
10163              shebang_len = 2;
10164 #ifdef ALTERNATE_SHEBANG
10165           else {
10166             shebang_len = strlen(ALTERNATE_SHEBANG);
10167             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10168               char * perlstr;
10169                 perlstr = strstr("perl",b);
10170                 if (perlstr == NULL)
10171                   shebang_len = 0;
10172             }
10173             else
10174               shebang_len = 0;
10175           }
10176 #endif
10177
10178           if (shebang_len > 0) {
10179           int i;
10180           int j;
10181           char tmpspec[NAM$C_MAXRSS + 1];
10182
10183             i = shebang_len;
10184              /* Image is following after white space */
10185             /*--------------------------------------*/
10186             while (isprint(b[i]) && isspace(b[i]))
10187                 i++;
10188
10189             j = 0;
10190             while (isprint(b[i]) && !isspace(b[i])) {
10191                 tmpspec[j++] = b[i++];
10192                 if (j >= NAM$C_MAXRSS)
10193                    break;
10194             }
10195             tmpspec[j] = '\0';
10196
10197              /* There may be some default parameters to the image */
10198             /*---------------------------------------------------*/
10199             j = 0;
10200             while (isprint(b[i])) {
10201                 image_argv[j++] = b[i++];
10202                 if (j >= NAM$C_MAXRSS)
10203                    break;
10204             }
10205             while ((j > 0) && !isprint(image_argv[j-1]))
10206                 j--;
10207             image_argv[j] = 0;
10208
10209             /* It will need to be converted to VMS format and validated */
10210             if (tmpspec[0] != '\0') {
10211               char * iname;
10212
10213                /* Try to find the exact program requested to be run */
10214               /*---------------------------------------------------*/
10215               iname = do_rmsexpand
10216                  (tmpspec, image_name, 0, ".exe",
10217                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10218               if (iname != NULL) {
10219                 if (cando_by_name_int
10220                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10221                   /* MCR prefix needed */
10222                   isdcl = 0;
10223                 }
10224                 else {
10225                    /* Try again with a null type */
10226                   /*----------------------------*/
10227                   iname = do_rmsexpand
10228                     (tmpspec, image_name, 0, ".",
10229                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10230                   if (iname != NULL) {
10231                     if (cando_by_name_int
10232                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10233                       /* MCR prefix needed */
10234                       isdcl = 0;
10235                     }
10236                   }
10237                 }
10238
10239                  /* Did we find the image to run the script? */
10240                 /*------------------------------------------*/
10241                 if (isdcl) {
10242                   char *tchr;
10243
10244                    /* Assume DCL or foreign command exists */
10245                   /*--------------------------------------*/
10246                   tchr = strrchr(tmpspec, '/');
10247                   if (tchr != NULL) {
10248                     tchr++;
10249                   }
10250                   else {
10251                     tchr = tmpspec;
10252                   }
10253                   strcpy(image_name, tchr);
10254                 }
10255               }
10256             }
10257           }
10258         }
10259         fclose(fp);
10260       }
10261       if (check_img && isdcl) {
10262           PerlMem_free(cmd);
10263           PerlMem_free(resspec);
10264           PerlMem_free(vmsspec);
10265           return RMS$_FNF;
10266       }
10267
10268       if (cando_by_name(S_IXUSR,0,resspec)) {
10269         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10270         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10271         if (!isdcl) {
10272             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
10273             if (image_name[0] != 0) {
10274                 strcat(vmscmd->dsc$a_pointer, image_name);
10275                 strcat(vmscmd->dsc$a_pointer, " ");
10276             }
10277         } else if (image_name[0] != 0) {
10278             strcpy(vmscmd->dsc$a_pointer, image_name);
10279             strcat(vmscmd->dsc$a_pointer, " ");
10280         } else {
10281             strcpy(vmscmd->dsc$a_pointer,"@");
10282         }
10283         if (suggest_quote) *suggest_quote = 1;
10284
10285         /* If there is an image name, use original command */
10286         if (image_name[0] == 0)
10287             strcat(vmscmd->dsc$a_pointer,resspec);
10288         else {
10289             rest = cmd;
10290             while (*rest && isspace(*rest)) rest++;
10291         }
10292
10293         if (image_argv[0] != 0) {
10294           strcat(vmscmd->dsc$a_pointer,image_argv);
10295           strcat(vmscmd->dsc$a_pointer, " ");
10296         }
10297         if (rest) {
10298            int rest_len;
10299            int vmscmd_len;
10300
10301            rest_len = strlen(rest);
10302            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10303            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10304               strcat(vmscmd->dsc$a_pointer,rest);
10305            else
10306              retsts = CLI$_BUFOVF;
10307         }
10308         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10309         PerlMem_free(cmd);
10310         PerlMem_free(vmsspec);
10311         PerlMem_free(resspec);
10312         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10313       }
10314       else
10315         retsts = RMS$_PRV;
10316     }
10317   }
10318   /* It's either a DCL command or we couldn't find a suitable image */
10319   vmscmd->dsc$w_length = strlen(cmd);
10320
10321   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
10322   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
10323   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
10324
10325   PerlMem_free(cmd);
10326   PerlMem_free(resspec);
10327   PerlMem_free(vmsspec);
10328
10329   /* check if it's a symbol (for quoting purposes) */
10330   if (suggest_quote && !*suggest_quote) {
10331     int iss;
10332     char equiv[LNM$C_NAMLENGTH];
10333     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10334     eqvdsc.dsc$a_pointer = equiv;
10335
10336     iss = lib$get_symbol(vmscmd,&eqvdsc);
10337     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10338   }
10339   if (!(retsts & 1)) {
10340     /* just hand off status values likely to be due to user error */
10341     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10342         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10343        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10344     else { _ckvmssts_noperl(retsts); }
10345   }
10346
10347   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10348
10349 }  /* end of setup_cmddsc() */
10350
10351
10352 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10353 bool
10354 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10355 {
10356 bool exec_sts;
10357 char * cmd;
10358
10359   if (sp > mark) {
10360     if (vfork_called) {           /* this follows a vfork - act Unixish */
10361       vfork_called--;
10362       if (vfork_called < 0) {
10363         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10364         vfork_called = 0;
10365       }
10366       else return do_aexec(really,mark,sp);
10367     }
10368                                            /* no vfork - act VMSish */
10369     cmd = setup_argstr(aTHX_ really,mark,sp);
10370     exec_sts = vms_do_exec(cmd);
10371     Safefree(cmd);  /* Clean up from setup_argstr() */
10372     return exec_sts;
10373   }
10374
10375   return FALSE;
10376 }  /* end of vms_do_aexec() */
10377 /*}}}*/
10378
10379 /* {{{bool vms_do_exec(char *cmd) */
10380 bool
10381 Perl_vms_do_exec(pTHX_ const char *cmd)
10382 {
10383   struct dsc$descriptor_s *vmscmd;
10384
10385   if (vfork_called) {             /* this follows a vfork - act Unixish */
10386     vfork_called--;
10387     if (vfork_called < 0) {
10388       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10389       vfork_called = 0;
10390     }
10391     else return do_exec(cmd);
10392   }
10393
10394   {                               /* no vfork - act VMSish */
10395     unsigned long int retsts;
10396
10397     TAINT_ENV();
10398     TAINT_PROPER("exec");
10399     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10400       retsts = lib$do_command(vmscmd);
10401
10402     switch (retsts) {
10403       case RMS$_FNF: case RMS$_DNF:
10404         set_errno(ENOENT); break;
10405       case RMS$_DIR:
10406         set_errno(ENOTDIR); break;
10407       case RMS$_DEV:
10408         set_errno(ENODEV); break;
10409       case RMS$_PRV:
10410         set_errno(EACCES); break;
10411       case RMS$_SYN:
10412         set_errno(EINVAL); break;
10413       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10414         set_errno(E2BIG); break;
10415       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10416         _ckvmssts_noperl(retsts); /* fall through */
10417       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10418         set_errno(EVMSERR);
10419     }
10420     set_vaxc_errno(retsts);
10421     if (ckWARN(WARN_EXEC)) {
10422       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10423              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10424     }
10425     vms_execfree(vmscmd);
10426   }
10427
10428   return FALSE;
10429
10430 }  /* end of vms_do_exec() */
10431 /*}}}*/
10432
10433 int do_spawn2(pTHX_ const char *, int);
10434
10435 int
10436 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
10437 {
10438 unsigned long int sts;
10439 char * cmd;
10440 int flags = 0;
10441
10442   if (sp > mark) {
10443
10444     /* We'll copy the (undocumented?) Win32 behavior and allow a
10445      * numeric first argument.  But the only value we'll support
10446      * through do_aspawn is a value of 1, which means spawn without
10447      * waiting for completion -- other values are ignored.
10448      */
10449     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
10450         ++mark;
10451         flags = SvIVx(*mark);
10452     }
10453
10454     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
10455         flags = CLI$M_NOWAIT;
10456     else
10457         flags = 0;
10458
10459     cmd = setup_argstr(aTHX_ really, mark, sp);
10460     sts = do_spawn2(aTHX_ cmd, flags);
10461     /* pp_sys will clean up cmd */
10462     return sts;
10463   }
10464   return SS$_ABORT;
10465 }  /* end of do_aspawn() */
10466 /*}}}*/
10467
10468
10469 /* {{{int do_spawn(char* cmd) */
10470 int
10471 Perl_do_spawn(pTHX_ char* cmd)
10472 {
10473     PERL_ARGS_ASSERT_DO_SPAWN;
10474
10475     return do_spawn2(aTHX_ cmd, 0);
10476 }
10477 /*}}}*/
10478
10479 /* {{{int do_spawn_nowait(char* cmd) */
10480 int
10481 Perl_do_spawn_nowait(pTHX_ char* cmd)
10482 {
10483     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
10484
10485     return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
10486 }
10487 /*}}}*/
10488
10489 /* {{{int do_spawn2(char *cmd) */
10490 int
10491 do_spawn2(pTHX_ const char *cmd, int flags)
10492 {
10493   unsigned long int sts, substs;
10494
10495   /* The caller of this routine expects to Safefree(PL_Cmd) */
10496   Newx(PL_Cmd,10,char);
10497
10498   TAINT_ENV();
10499   TAINT_PROPER("spawn");
10500   if (!cmd || !*cmd) {
10501     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
10502     if (!(sts & 1)) {
10503       switch (sts) {
10504         case RMS$_FNF:  case RMS$_DNF:
10505           set_errno(ENOENT); break;
10506         case RMS$_DIR:
10507           set_errno(ENOTDIR); break;
10508         case RMS$_DEV:
10509           set_errno(ENODEV); break;
10510         case RMS$_PRV:
10511           set_errno(EACCES); break;
10512         case RMS$_SYN:
10513           set_errno(EINVAL); break;
10514         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10515           set_errno(E2BIG); break;
10516         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10517           _ckvmssts_noperl(sts); /* fall through */
10518         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10519           set_errno(EVMSERR);
10520       }
10521       set_vaxc_errno(sts);
10522       if (ckWARN(WARN_EXEC)) {
10523         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
10524                     Strerror(errno));
10525       }
10526     }
10527     sts = substs;
10528   }
10529   else {
10530     char mode[3];
10531     PerlIO * fp;
10532     if (flags & CLI$M_NOWAIT)
10533         strcpy(mode, "n");
10534     else
10535         strcpy(mode, "nW");
10536
10537     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
10538     if (fp != NULL)
10539       my_pclose(fp);
10540     /* sts will be the pid in the nowait case */
10541   }
10542   return sts;
10543 }  /* end of do_spawn2() */
10544 /*}}}*/
10545
10546
10547 static unsigned int *sockflags, sockflagsize;
10548
10549 /*
10550  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
10551  * routines found in some versions of the CRTL can't deal with sockets.
10552  * We don't shim the other file open routines since a socket isn't
10553  * likely to be opened by a name.
10554  */
10555 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
10556 FILE *my_fdopen(int fd, const char *mode)
10557 {
10558   FILE *fp = fdopen(fd, mode);
10559
10560   if (fp) {
10561     unsigned int fdoff = fd / sizeof(unsigned int);
10562     Stat_t sbuf; /* native stat; we don't need flex_stat */
10563     if (!sockflagsize || fdoff > sockflagsize) {
10564       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
10565       else           Newx  (sockflags,fdoff+2,unsigned int);
10566       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
10567       sockflagsize = fdoff + 2;
10568     }
10569     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
10570       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
10571   }
10572   return fp;
10573
10574 }
10575 /*}}}*/
10576
10577
10578 /*
10579  * Clear the corresponding bit when the (possibly) socket stream is closed.
10580  * There still a small hole: we miss an implicit close which might occur
10581  * via freopen().  >> Todo
10582  */
10583 /*{{{ int my_fclose(FILE *fp)*/
10584 int my_fclose(FILE *fp) {
10585   if (fp) {
10586     unsigned int fd = fileno(fp);
10587     unsigned int fdoff = fd / sizeof(unsigned int);
10588
10589     if (sockflagsize && fdoff < sockflagsize)
10590       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
10591   }
10592   return fclose(fp);
10593 }
10594 /*}}}*/
10595
10596
10597 /*
10598  * A simple fwrite replacement which outputs itmsz*nitm chars without
10599  * introducing record boundaries every itmsz chars.
10600  * We are using fputs, which depends on a terminating null.  We may
10601  * well be writing binary data, so we need to accommodate not only
10602  * data with nulls sprinkled in the middle but also data with no null
10603  * byte at the end.
10604  */
10605 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
10606 int
10607 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
10608 {
10609   register char *cp, *end, *cpd, *data;
10610   register unsigned int fd = fileno(dest);
10611   register unsigned int fdoff = fd / sizeof(unsigned int);
10612   int retval;
10613   int bufsize = itmsz * nitm + 1;
10614
10615   if (fdoff < sockflagsize &&
10616       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
10617     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
10618     return nitm;
10619   }
10620
10621   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
10622   memcpy( data, src, itmsz*nitm );
10623   data[itmsz*nitm] = '\0';
10624
10625   end = data + itmsz * nitm;
10626   retval = (int) nitm; /* on success return # items written */
10627
10628   cpd = data;
10629   while (cpd <= end) {
10630     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
10631     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
10632     if (cp < end)
10633       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
10634     cpd = cp + 1;
10635   }
10636
10637   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
10638   return retval;
10639
10640 }  /* end of my_fwrite() */
10641 /*}}}*/
10642
10643 /*{{{ int my_flush(FILE *fp)*/
10644 int
10645 Perl_my_flush(pTHX_ FILE *fp)
10646 {
10647     int res;
10648     if ((res = fflush(fp)) == 0 && fp) {
10649 #ifdef VMS_DO_SOCKETS
10650         Stat_t s;
10651         if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
10652 #endif
10653             res = fsync(fileno(fp));
10654     }
10655 /*
10656  * If the flush succeeded but set end-of-file, we need to clear
10657  * the error because our caller may check ferror().  BTW, this
10658  * probably means we just flushed an empty file.
10659  */
10660     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
10661
10662     return res;
10663 }
10664 /*}}}*/
10665
10666 /*
10667  * Here are replacements for the following Unix routines in the VMS environment:
10668  *      getpwuid    Get information for a particular UIC or UID
10669  *      getpwnam    Get information for a named user
10670  *      getpwent    Get information for each user in the rights database
10671  *      setpwent    Reset search to the start of the rights database
10672  *      endpwent    Finish searching for users in the rights database
10673  *
10674  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
10675  * (defined in pwd.h), which contains the following fields:-
10676  *      struct passwd {
10677  *              char        *pw_name;    Username (in lower case)
10678  *              char        *pw_passwd;  Hashed password
10679  *              unsigned int pw_uid;     UIC
10680  *              unsigned int pw_gid;     UIC group  number
10681  *              char        *pw_unixdir; Default device/directory (VMS-style)
10682  *              char        *pw_gecos;   Owner name
10683  *              char        *pw_dir;     Default device/directory (Unix-style)
10684  *              char        *pw_shell;   Default CLI name (eg. DCL)
10685  *      };
10686  * If the specified user does not exist, getpwuid and getpwnam return NULL.
10687  *
10688  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
10689  * not the UIC member number (eg. what's returned by getuid()),
10690  * getpwuid() can accept either as input (if uid is specified, the caller's
10691  * UIC group is used), though it won't recognise gid=0.
10692  *
10693  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
10694  * information about other users in your group or in other groups, respectively.
10695  * If the required privilege is not available, then these routines fill only
10696  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
10697  * string).
10698  *
10699  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
10700  */
10701
10702 /* sizes of various UAF record fields */
10703 #define UAI$S_USERNAME 12
10704 #define UAI$S_IDENT    31
10705 #define UAI$S_OWNER    31
10706 #define UAI$S_DEFDEV   31
10707 #define UAI$S_DEFDIR   63
10708 #define UAI$S_DEFCLI   31
10709 #define UAI$S_PWD       8
10710
10711 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
10712                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
10713                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
10714
10715 static char __empty[]= "";
10716 static struct passwd __passwd_empty=
10717     {(char *) __empty, (char *) __empty, 0, 0,
10718      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
10719 static int contxt= 0;
10720 static struct passwd __pwdcache;
10721 static char __pw_namecache[UAI$S_IDENT+1];
10722
10723 /*
10724  * This routine does most of the work extracting the user information.
10725  */
10726 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
10727 {
10728     static struct {
10729         unsigned char length;
10730         char pw_gecos[UAI$S_OWNER+1];
10731     } owner;
10732     static union uicdef uic;
10733     static struct {
10734         unsigned char length;
10735         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
10736     } defdev;
10737     static struct {
10738         unsigned char length;
10739         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
10740     } defdir;
10741     static struct {
10742         unsigned char length;
10743         char pw_shell[UAI$S_DEFCLI+1];
10744     } defcli;
10745     static char pw_passwd[UAI$S_PWD+1];
10746
10747     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
10748     struct dsc$descriptor_s name_desc;
10749     unsigned long int sts;
10750
10751     static struct itmlst_3 itmlst[]= {
10752         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
10753         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
10754         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
10755         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
10756         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
10757         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
10758         {0,                0,           NULL,    NULL}};
10759
10760     name_desc.dsc$w_length=  strlen(name);
10761     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
10762     name_desc.dsc$b_class=   DSC$K_CLASS_S;
10763     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
10764
10765 /*  Note that sys$getuai returns many fields as counted strings. */
10766     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
10767     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
10768       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
10769     }
10770     else { _ckvmssts(sts); }
10771     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
10772
10773     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
10774     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
10775     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
10776     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
10777     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
10778     owner.pw_gecos[lowner]=            '\0';
10779     defdev.pw_dir[ldefdev+ldefdir]= '\0';
10780     defcli.pw_shell[ldefcli]=          '\0';
10781     if (valid_uic(uic)) {
10782         pwd->pw_uid= uic.uic$l_uic;
10783         pwd->pw_gid= uic.uic$v_group;
10784     }
10785     else
10786       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
10787     pwd->pw_passwd=  pw_passwd;
10788     pwd->pw_gecos=   owner.pw_gecos;
10789     pwd->pw_dir=     defdev.pw_dir;
10790     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
10791     pwd->pw_shell=   defcli.pw_shell;
10792     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
10793         int ldir;
10794         ldir= strlen(pwd->pw_unixdir) - 1;
10795         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
10796     }
10797     else
10798         strcpy(pwd->pw_unixdir, pwd->pw_dir);
10799     if (!decc_efs_case_preserve)
10800         __mystrtolower(pwd->pw_unixdir);
10801     return 1;
10802 }
10803
10804 /*
10805  * Get information for a named user.
10806 */
10807 /*{{{struct passwd *getpwnam(char *name)*/
10808 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
10809 {
10810     struct dsc$descriptor_s name_desc;
10811     union uicdef uic;
10812     unsigned long int status, sts;
10813
10814     __pwdcache = __passwd_empty;
10815     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
10816       /* We still may be able to determine pw_uid and pw_gid */
10817       name_desc.dsc$w_length=  strlen(name);
10818       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
10819       name_desc.dsc$b_class=   DSC$K_CLASS_S;
10820       name_desc.dsc$a_pointer= (char *) name;
10821       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
10822         __pwdcache.pw_uid= uic.uic$l_uic;
10823         __pwdcache.pw_gid= uic.uic$v_group;
10824       }
10825       else {
10826         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
10827           set_vaxc_errno(sts);
10828           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
10829           return NULL;
10830         }
10831         else { _ckvmssts(sts); }
10832       }
10833     }
10834     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
10835     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
10836     __pwdcache.pw_name= __pw_namecache;
10837     return &__pwdcache;
10838 }  /* end of my_getpwnam() */
10839 /*}}}*/
10840
10841 /*
10842  * Get information for a particular UIC or UID.
10843  * Called by my_getpwent with uid=-1 to list all users.
10844 */
10845 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
10846 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
10847 {
10848     const $DESCRIPTOR(name_desc,__pw_namecache);
10849     unsigned short lname;
10850     union uicdef uic;
10851     unsigned long int status;
10852
10853     if (uid == (unsigned int) -1) {
10854       do {
10855         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
10856         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
10857           set_vaxc_errno(status);
10858           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10859           my_endpwent();
10860           return NULL;
10861         }
10862         else { _ckvmssts(status); }
10863       } while (!valid_uic (uic));
10864     }
10865     else {
10866       uic.uic$l_uic= uid;
10867       if (!uic.uic$v_group)
10868         uic.uic$v_group= PerlProc_getgid();
10869       if (valid_uic(uic))
10870         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
10871       else status = SS$_IVIDENT;
10872       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
10873           status == RMS$_PRV) {
10874         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10875         return NULL;
10876       }
10877       else { _ckvmssts(status); }
10878     }
10879     __pw_namecache[lname]= '\0';
10880     __mystrtolower(__pw_namecache);
10881
10882     __pwdcache = __passwd_empty;
10883     __pwdcache.pw_name = __pw_namecache;
10884
10885 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
10886     The identifier's value is usually the UIC, but it doesn't have to be,
10887     so if we can, we let fillpasswd update this. */
10888     __pwdcache.pw_uid =  uic.uic$l_uic;
10889     __pwdcache.pw_gid =  uic.uic$v_group;
10890
10891     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
10892     return &__pwdcache;
10893
10894 }  /* end of my_getpwuid() */
10895 /*}}}*/
10896
10897 /*
10898  * Get information for next user.
10899 */
10900 /*{{{struct passwd *my_getpwent()*/
10901 struct passwd *Perl_my_getpwent(pTHX)
10902 {
10903     return (my_getpwuid((unsigned int) -1));
10904 }
10905 /*}}}*/
10906
10907 /*
10908  * Finish searching rights database for users.
10909 */
10910 /*{{{void my_endpwent()*/
10911 void Perl_my_endpwent(pTHX)
10912 {
10913     if (contxt) {
10914       _ckvmssts(sys$finish_rdb(&contxt));
10915       contxt= 0;
10916     }
10917 }
10918 /*}}}*/
10919
10920 #ifdef HOMEGROWN_POSIX_SIGNALS
10921   /* Signal handling routines, pulled into the core from POSIX.xs.
10922    *
10923    * We need these for threads, so they've been rolled into the core,
10924    * rather than left in POSIX.xs.
10925    *
10926    * (DRS, Oct 23, 1997)
10927    */
10928
10929   /* sigset_t is atomic under VMS, so these routines are easy */
10930 /*{{{int my_sigemptyset(sigset_t *) */
10931 int my_sigemptyset(sigset_t *set) {
10932     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10933     *set = 0; return 0;
10934 }
10935 /*}}}*/
10936
10937
10938 /*{{{int my_sigfillset(sigset_t *)*/
10939 int my_sigfillset(sigset_t *set) {
10940     int i;
10941     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10942     for (i = 0; i < NSIG; i++) *set |= (1 << i);
10943     return 0;
10944 }
10945 /*}}}*/
10946
10947
10948 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
10949 int my_sigaddset(sigset_t *set, int sig) {
10950     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10951     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10952     *set |= (1 << (sig - 1));
10953     return 0;
10954 }
10955 /*}}}*/
10956
10957
10958 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
10959 int my_sigdelset(sigset_t *set, int sig) {
10960     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10961     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10962     *set &= ~(1 << (sig - 1));
10963     return 0;
10964 }
10965 /*}}}*/
10966
10967
10968 /*{{{int my_sigismember(sigset_t *set, int sig)*/
10969 int my_sigismember(sigset_t *set, int sig) {
10970     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10971     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10972     return *set & (1 << (sig - 1));
10973 }
10974 /*}}}*/
10975
10976
10977 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10978 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10979     sigset_t tempmask;
10980
10981     /* If set and oset are both null, then things are badly wrong. Bail out. */
10982     if ((oset == NULL) && (set == NULL)) {
10983       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
10984       return -1;
10985     }
10986
10987     /* If set's null, then we're just handling a fetch. */
10988     if (set == NULL) {
10989         tempmask = sigblock(0);
10990     }
10991     else {
10992       switch (how) {
10993       case SIG_SETMASK:
10994         tempmask = sigsetmask(*set);
10995         break;
10996       case SIG_BLOCK:
10997         tempmask = sigblock(*set);
10998         break;
10999       case SIG_UNBLOCK:
11000         tempmask = sigblock(0);
11001         sigsetmask(*oset & ~tempmask);
11002         break;
11003       default:
11004         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11005         return -1;
11006       }
11007     }
11008
11009     /* Did they pass us an oset? If so, stick our holding mask into it */
11010     if (oset)
11011       *oset = tempmask;
11012
11013     return 0;
11014 }
11015 /*}}}*/
11016 #endif  /* HOMEGROWN_POSIX_SIGNALS */
11017
11018
11019 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11020  * my_utime(), and flex_stat(), all of which operate on UTC unless
11021  * VMSISH_TIMES is true.
11022  */
11023 /* method used to handle UTC conversions:
11024  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
11025  */
11026 static int gmtime_emulation_type;
11027 /* number of secs to add to UTC POSIX-style time to get local time */
11028 static long int utc_offset_secs;
11029
11030 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11031  * in vmsish.h.  #undef them here so we can call the CRTL routines
11032  * directly.
11033  */
11034 #undef gmtime
11035 #undef localtime
11036 #undef time
11037
11038
11039 /*
11040  * DEC C previous to 6.0 corrupts the behavior of the /prefix
11041  * qualifier with the extern prefix pragma.  This provisional
11042  * hack circumvents this prefix pragma problem in previous
11043  * precompilers.
11044  */
11045 #if defined(__VMS_VER) && __VMS_VER >= 70000000
11046 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
11047 #    pragma __extern_prefix save
11048 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
11049 #    define gmtime decc$__utctz_gmtime
11050 #    define localtime decc$__utctz_localtime
11051 #    define time decc$__utc_time
11052 #    pragma __extern_prefix restore
11053
11054      struct tm *gmtime(), *localtime();
11055
11056 #  endif
11057 #endif
11058
11059
11060 static time_t toutc_dst(time_t loc) {
11061   struct tm *rsltmp;
11062
11063   if ((rsltmp = localtime(&loc)) == NULL) return -1;
11064   loc -= utc_offset_secs;
11065   if (rsltmp->tm_isdst) loc -= 3600;
11066   return loc;
11067 }
11068 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11069        ((gmtime_emulation_type || my_time(NULL)), \
11070        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11071        ((secs) - utc_offset_secs))))
11072
11073 static time_t toloc_dst(time_t utc) {
11074   struct tm *rsltmp;
11075
11076   utc += utc_offset_secs;
11077   if ((rsltmp = localtime(&utc)) == NULL) return -1;
11078   if (rsltmp->tm_isdst) utc += 3600;
11079   return utc;
11080 }
11081 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11082        ((gmtime_emulation_type || my_time(NULL)), \
11083        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11084        ((secs) + utc_offset_secs))))
11085
11086 #ifndef RTL_USES_UTC
11087 /*
11088
11089     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
11090         DST starts on 1st sun of april      at 02:00  std time
11091             ends on last sun of october     at 02:00  dst time
11092     see the UCX management command reference, SET CONFIG TIMEZONE
11093     for formatting info.
11094
11095     No, it's not as general as it should be, but then again, NOTHING
11096     will handle UK times in a sensible way.
11097 */
11098
11099
11100 /*
11101     parse the DST start/end info:
11102     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
11103 */
11104
11105 static char *
11106 tz_parse_startend(char *s, struct tm *w, int *past)
11107 {
11108     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
11109     int ly, dozjd, d, m, n, hour, min, sec, j, k;
11110     time_t g;
11111
11112     if (!s)    return 0;
11113     if (!w) return 0;
11114     if (!past) return 0;
11115
11116     ly = 0;
11117     if (w->tm_year % 4        == 0) ly = 1;
11118     if (w->tm_year % 100      == 0) ly = 0;
11119     if (w->tm_year+1900 % 400 == 0) ly = 1;
11120     if (ly) dinm[1]++;
11121
11122     dozjd = isdigit(*s);
11123     if (*s == 'J' || *s == 'j' || dozjd) {
11124         if (!dozjd && !isdigit(*++s)) return 0;
11125         d = *s++ - '0';
11126         if (isdigit(*s)) {
11127             d = d*10 + *s++ - '0';
11128             if (isdigit(*s)) {
11129                 d = d*10 + *s++ - '0';
11130             }
11131         }
11132         if (d == 0) return 0;
11133         if (d > 366) return 0;
11134         d--;
11135         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
11136         g = d * 86400;
11137         dozjd = 1;
11138     } else if (*s == 'M' || *s == 'm') {
11139         if (!isdigit(*++s)) return 0;
11140         m = *s++ - '0';
11141         if (isdigit(*s)) m = 10*m + *s++ - '0';
11142         if (*s != '.') return 0;
11143         if (!isdigit(*++s)) return 0;
11144         n = *s++ - '0';
11145         if (n < 1 || n > 5) return 0;
11146         if (*s != '.') return 0;
11147         if (!isdigit(*++s)) return 0;
11148         d = *s++ - '0';
11149         if (d > 6) return 0;
11150     }
11151
11152     if (*s == '/') {
11153         if (!isdigit(*++s)) return 0;
11154         hour = *s++ - '0';
11155         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
11156         if (*s == ':') {
11157             if (!isdigit(*++s)) return 0;
11158             min = *s++ - '0';
11159             if (isdigit(*s)) min = 10*min + *s++ - '0';
11160             if (*s == ':') {
11161                 if (!isdigit(*++s)) return 0;
11162                 sec = *s++ - '0';
11163                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
11164             }
11165         }
11166     } else {
11167         hour = 2;
11168         min = 0;
11169         sec = 0;
11170     }
11171
11172     if (dozjd) {
11173         if (w->tm_yday < d) goto before;
11174         if (w->tm_yday > d) goto after;
11175     } else {
11176         if (w->tm_mon+1 < m) goto before;
11177         if (w->tm_mon+1 > m) goto after;
11178
11179         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
11180         k = d - j; /* mday of first d */
11181         if (k <= 0) k += 7;
11182         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
11183         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
11184         if (w->tm_mday < k) goto before;
11185         if (w->tm_mday > k) goto after;
11186     }
11187
11188     if (w->tm_hour < hour) goto before;
11189     if (w->tm_hour > hour) goto after;
11190     if (w->tm_min  < min)  goto before;
11191     if (w->tm_min  > min)  goto after;
11192     if (w->tm_sec  < sec)  goto before;
11193     goto after;
11194
11195 before:
11196     *past = 0;
11197     return s;
11198 after:
11199     *past = 1;
11200     return s;
11201 }
11202
11203
11204
11205
11206 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
11207
11208 static char *
11209 tz_parse_offset(char *s, int *offset)
11210 {
11211     int hour = 0, min = 0, sec = 0;
11212     int neg = 0;
11213     if (!s) return 0;
11214     if (!offset) return 0;
11215
11216     if (*s == '-') {neg++; s++;}
11217     if (*s == '+') s++;
11218     if (!isdigit(*s)) return 0;
11219     hour = *s++ - '0';
11220     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
11221     if (hour > 24) return 0;
11222     if (*s == ':') {
11223         if (!isdigit(*++s)) return 0;
11224         min = *s++ - '0';
11225         if (isdigit(*s)) min = min*10 + (*s++ - '0');
11226         if (min > 59) return 0;
11227         if (*s == ':') {
11228             if (!isdigit(*++s)) return 0;
11229             sec = *s++ - '0';
11230             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
11231             if (sec > 59) return 0;
11232         }
11233     }
11234
11235     *offset = (hour*60+min)*60 + sec;
11236     if (neg) *offset = -*offset;
11237     return s;
11238 }
11239
11240 /*
11241     input time is w, whatever type of time the CRTL localtime() uses.
11242     sets dst, the zone, and the gmtoff (seconds)
11243
11244     caches the value of TZ and UCX$TZ env variables; note that
11245     my_setenv looks for these and sets a flag if they're changed
11246     for efficiency.
11247
11248     We have to watch out for the "australian" case (dst starts in
11249     october, ends in april)...flagged by "reverse" and checked by
11250     scanning through the months of the previous year.
11251
11252 */
11253
11254 static int
11255 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
11256 {
11257     time_t when;
11258     struct tm *w2;
11259     char *s,*s2;
11260     char *dstzone, *tz, *s_start, *s_end;
11261     int std_off, dst_off, isdst;
11262     int y, dststart, dstend;
11263     static char envtz[1025];  /* longer than any logical, symbol, ... */
11264     static char ucxtz[1025];
11265     static char reversed = 0;
11266
11267     if (!w) return 0;
11268
11269     if (tz_updated) {
11270         tz_updated = 0;
11271         reversed = -1;  /* flag need to check  */
11272         envtz[0] = ucxtz[0] = '\0';
11273         tz = my_getenv("TZ",0);
11274         if (tz) strcpy(envtz, tz);
11275         tz = my_getenv("UCX$TZ",0);
11276         if (tz) strcpy(ucxtz, tz);
11277         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
11278     }
11279     tz = envtz;
11280     if (!*tz) tz = ucxtz;
11281
11282     s = tz;
11283     while (isalpha(*s)) s++;
11284     s = tz_parse_offset(s, &std_off);
11285     if (!s) return 0;
11286     if (!*s) {                  /* no DST, hurray we're done! */
11287         isdst = 0;
11288         goto done;
11289     }
11290
11291     dstzone = s;
11292     while (isalpha(*s)) s++;
11293     s2 = tz_parse_offset(s, &dst_off);
11294     if (s2) {
11295         s = s2;
11296     } else {
11297         dst_off = std_off - 3600;
11298     }
11299
11300     if (!*s) {      /* default dst start/end?? */
11301         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
11302             s = strchr(ucxtz,',');
11303         }
11304         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
11305     }
11306     if (*s != ',') return 0;
11307
11308     when = *w;
11309     when = _toutc(when);      /* convert to utc */
11310     when = when - std_off;    /* convert to pseudolocal time*/
11311
11312     w2 = localtime(&when);
11313     y = w2->tm_year;
11314     s_start = s+1;
11315     s = tz_parse_startend(s_start,w2,&dststart);
11316     if (!s) return 0;
11317     if (*s != ',') return 0;
11318
11319     when = *w;
11320     when = _toutc(when);      /* convert to utc */
11321     when = when - dst_off;    /* convert to pseudolocal time*/
11322     w2 = localtime(&when);
11323     if (w2->tm_year != y) {   /* spans a year, just check one time */
11324         when += dst_off - std_off;
11325         w2 = localtime(&when);
11326     }
11327     s_end = s+1;
11328     s = tz_parse_startend(s_end,w2,&dstend);
11329     if (!s) return 0;
11330
11331     if (reversed == -1) {  /* need to check if start later than end */
11332         int j, ds, de;
11333
11334         when = *w;
11335         if (when < 2*365*86400) {
11336             when += 2*365*86400;
11337         } else {
11338             when -= 365*86400;
11339         }
11340         w2 =localtime(&when);
11341         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
11342
11343         for (j = 0; j < 12; j++) {
11344             w2 =localtime(&when);
11345             tz_parse_startend(s_start,w2,&ds);
11346             tz_parse_startend(s_end,w2,&de);
11347             if (ds != de) break;
11348             when += 30*86400;
11349         }
11350         reversed = 0;
11351         if (de && !ds) reversed = 1;
11352     }
11353
11354     isdst = dststart && !dstend;
11355     if (reversed) isdst = dststart  || !dstend;
11356
11357 done:
11358     if (dst)    *dst = isdst;
11359     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
11360     if (isdst)  tz = dstzone;
11361     if (zone) {
11362         while(isalpha(*tz))  *zone++ = *tz++;
11363         *zone = '\0';
11364     }
11365     return 1;
11366 }
11367
11368 #endif /* !RTL_USES_UTC */
11369
11370 /* my_time(), my_localtime(), my_gmtime()
11371  * By default traffic in UTC time values, using CRTL gmtime() or
11372  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11373  * Note: We need to use these functions even when the CRTL has working
11374  * UTC support, since they also handle C<use vmsish qw(times);>
11375  *
11376  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
11377  * Modified by Charles Bailey <bailey@newman.upenn.edu>
11378  */
11379
11380 /*{{{time_t my_time(time_t *timep)*/
11381 time_t Perl_my_time(pTHX_ time_t *timep)
11382 {
11383   time_t when;
11384   struct tm *tm_p;
11385
11386   if (gmtime_emulation_type == 0) {
11387     int dstnow;
11388     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
11389                               /* results of calls to gmtime() and localtime() */
11390                               /* for same &base */
11391
11392     gmtime_emulation_type++;
11393     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11394       char off[LNM$C_NAMLENGTH+1];;
11395
11396       gmtime_emulation_type++;
11397       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11398         gmtime_emulation_type++;
11399         utc_offset_secs = 0;
11400         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11401       }
11402       else { utc_offset_secs = atol(off); }
11403     }
11404     else { /* We've got a working gmtime() */
11405       struct tm gmt, local;
11406
11407       gmt = *tm_p;
11408       tm_p = localtime(&base);
11409       local = *tm_p;
11410       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
11411       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11412       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
11413       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
11414     }
11415   }
11416
11417   when = time(NULL);
11418 # ifdef VMSISH_TIME
11419 # ifdef RTL_USES_UTC
11420   if (VMSISH_TIME) when = _toloc(when);
11421 # else
11422   if (!VMSISH_TIME) when = _toutc(when);
11423 # endif
11424 # endif
11425   if (timep != NULL) *timep = when;
11426   return when;
11427
11428 }  /* end of my_time() */
11429 /*}}}*/
11430
11431
11432 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11433 struct tm *
11434 Perl_my_gmtime(pTHX_ const time_t *timep)
11435 {
11436   char *p;
11437   time_t when;
11438   struct tm *rsltmp;
11439
11440   if (timep == NULL) {
11441     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11442     return NULL;
11443   }
11444   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11445
11446   when = *timep;
11447 # ifdef VMSISH_TIME
11448   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11449 #  endif
11450 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
11451   return gmtime(&when);
11452 # else
11453   /* CRTL localtime() wants local time as input, so does no tz correction */
11454   rsltmp = localtime(&when);
11455   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
11456   return rsltmp;
11457 #endif
11458 }  /* end of my_gmtime() */
11459 /*}}}*/
11460
11461
11462 /*{{{struct tm *my_localtime(const time_t *timep)*/
11463 struct tm *
11464 Perl_my_localtime(pTHX_ const time_t *timep)
11465 {
11466   time_t when, whenutc;
11467   struct tm *rsltmp;
11468   int dst, offset;
11469
11470   if (timep == NULL) {
11471     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11472     return NULL;
11473   }
11474   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11475   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11476
11477   when = *timep;
11478 # ifdef RTL_USES_UTC
11479 # ifdef VMSISH_TIME
11480   if (VMSISH_TIME) when = _toutc(when);
11481 # endif
11482   /* CRTL localtime() wants UTC as input, does tz correction itself */
11483   return localtime(&when);
11484
11485 # else /* !RTL_USES_UTC */
11486   whenutc = when;
11487 # ifdef VMSISH_TIME
11488   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
11489   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
11490 # endif
11491   dst = -1;
11492 #ifndef RTL_USES_UTC
11493   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
11494       when = whenutc - offset;                   /* pseudolocal time*/
11495   }
11496 # endif
11497   /* CRTL localtime() wants local time as input, so does no tz correction */
11498   rsltmp = localtime(&when);
11499   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
11500   return rsltmp;
11501 # endif
11502
11503 } /*  end of my_localtime() */
11504 /*}}}*/
11505
11506 /* Reset definitions for later calls */
11507 #define gmtime(t)    my_gmtime(t)
11508 #define localtime(t) my_localtime(t)
11509 #define time(t)      my_time(t)
11510
11511
11512 /* my_utime - update modification/access time of a file
11513  *
11514  * VMS 7.3 and later implementation
11515  * Only the UTC translation is home-grown. The rest is handled by the
11516  * CRTL utime(), which will take into account the relevant feature
11517  * logicals and ODS-5 volume characteristics for true access times.
11518  *
11519  * pre VMS 7.3 implementation:
11520  * The calling sequence is identical to POSIX utime(), but under
11521  * VMS with ODS-2, only the modification time is changed; ODS-2 does
11522  * not maintain access times.  Restrictions differ from the POSIX
11523  * definition in that the time can be changed as long as the
11524  * caller has permission to execute the necessary IO$_MODIFY $QIO;
11525  * no separate checks are made to insure that the caller is the
11526  * owner of the file or has special privs enabled.
11527  * Code here is based on Joe Meadows' FILE utility.
11528  *
11529  */
11530
11531 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11532  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
11533  * in 100 ns intervals.
11534  */
11535 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11536
11537 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11538 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11539 {
11540 #if __CRTL_VER >= 70300000
11541   struct utimbuf utc_utimes, *utc_utimesp;
11542
11543   if (utimes != NULL) {
11544     utc_utimes.actime = utimes->actime;
11545     utc_utimes.modtime = utimes->modtime;
11546 # ifdef VMSISH_TIME
11547     /* If input was local; convert to UTC for sys svc */
11548     if (VMSISH_TIME) {
11549       utc_utimes.actime = _toutc(utimes->actime);
11550       utc_utimes.modtime = _toutc(utimes->modtime);
11551     }
11552 # endif
11553     utc_utimesp = &utc_utimes;
11554   }
11555   else {
11556     utc_utimesp = NULL;
11557   }
11558
11559   return utime(file, utc_utimesp);
11560
11561 #else /* __CRTL_VER < 70300000 */
11562
11563   register int i;
11564   int sts;
11565   long int bintime[2], len = 2, lowbit, unixtime,
11566            secscale = 10000000; /* seconds --> 100 ns intervals */
11567   unsigned long int chan, iosb[2], retsts;
11568   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11569   struct FAB myfab = cc$rms_fab;
11570   struct NAM mynam = cc$rms_nam;
11571 #if defined (__DECC) && defined (__VAX)
11572   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11573    * at least through VMS V6.1, which causes a type-conversion warning.
11574    */
11575 #  pragma message save
11576 #  pragma message disable cvtdiftypes
11577 #endif
11578   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11579   struct fibdef myfib;
11580 #if defined (__DECC) && defined (__VAX)
11581   /* This should be right after the declaration of myatr, but due
11582    * to a bug in VAX DEC C, this takes effect a statement early.
11583    */
11584 #  pragma message restore
11585 #endif
11586   /* cast ok for read only parameter */
11587   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11588                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11589                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
11590
11591   if (file == NULL || *file == '\0') {
11592     SETERRNO(ENOENT, LIB$_INVARG);
11593     return -1;
11594   }
11595
11596   /* Convert to VMS format ensuring that it will fit in 255 characters */
11597   if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
11598       SETERRNO(ENOENT, LIB$_INVARG);
11599       return -1;
11600   }
11601   if (utimes != NULL) {
11602     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
11603      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11604      * Since time_t is unsigned long int, and lib$emul takes a signed long int
11605      * as input, we force the sign bit to be clear by shifting unixtime right
11606      * one bit, then multiplying by an extra factor of 2 in lib$emul().
11607      */
11608     lowbit = (utimes->modtime & 1) ? secscale : 0;
11609     unixtime = (long int) utimes->modtime;
11610 #   ifdef VMSISH_TIME
11611     /* If input was UTC; convert to local for sys svc */
11612     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
11613 #   endif
11614     unixtime >>= 1;  secscale <<= 1;
11615     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11616     if (!(retsts & 1)) {
11617       SETERRNO(EVMSERR, retsts);
11618       return -1;
11619     }
11620     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11621     if (!(retsts & 1)) {
11622       SETERRNO(EVMSERR, retsts);
11623       return -1;
11624     }
11625   }
11626   else {
11627     /* Just get the current time in VMS format directly */
11628     retsts = sys$gettim(bintime);
11629     if (!(retsts & 1)) {
11630       SETERRNO(EVMSERR, retsts);
11631       return -1;
11632     }
11633   }
11634
11635   myfab.fab$l_fna = vmsspec;
11636   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11637   myfab.fab$l_nam = &mynam;
11638   mynam.nam$l_esa = esa;
11639   mynam.nam$b_ess = (unsigned char) sizeof esa;
11640   mynam.nam$l_rsa = rsa;
11641   mynam.nam$b_rss = (unsigned char) sizeof rsa;
11642   if (decc_efs_case_preserve)
11643       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
11644
11645   /* Look for the file to be affected, letting RMS parse the file
11646    * specification for us as well.  I have set errno using only
11647    * values documented in the utime() man page for VMS POSIX.
11648    */
11649   retsts = sys$parse(&myfab,0,0);
11650   if (!(retsts & 1)) {
11651     set_vaxc_errno(retsts);
11652     if      (retsts == RMS$_PRV) set_errno(EACCES);
11653     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11654     else                         set_errno(EVMSERR);
11655     return -1;
11656   }
11657   retsts = sys$search(&myfab,0,0);
11658   if (!(retsts & 1)) {
11659     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11660     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11661     set_vaxc_errno(retsts);
11662     if      (retsts == RMS$_PRV) set_errno(EACCES);
11663     else if (retsts == RMS$_FNF) set_errno(ENOENT);
11664     else                         set_errno(EVMSERR);
11665     return -1;
11666   }
11667
11668   devdsc.dsc$w_length = mynam.nam$b_dev;
11669   /* cast ok for read only parameter */
11670   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11671
11672   retsts = sys$assign(&devdsc,&chan,0,0);
11673   if (!(retsts & 1)) {
11674     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11675     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11676     set_vaxc_errno(retsts);
11677     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
11678     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
11679     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
11680     else                               set_errno(EVMSERR);
11681     return -1;
11682   }
11683
11684   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11685   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11686
11687   memset((void *) &myfib, 0, sizeof myfib);
11688 #if defined(__DECC) || defined(__DECCXX)
11689   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11690   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11691   /* This prevents the revision time of the file being reset to the current
11692    * time as a result of our IO$_MODIFY $QIO. */
11693   myfib.fib$l_acctl = FIB$M_NORECORD;
11694 #else
11695   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11696   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11697   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11698 #endif
11699   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
11700   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11701   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11702   _ckvmssts(sys$dassgn(chan));
11703   if (retsts & 1) retsts = iosb[0];
11704   if (!(retsts & 1)) {
11705     set_vaxc_errno(retsts);
11706     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11707     else                      set_errno(EVMSERR);
11708     return -1;
11709   }
11710
11711   return 0;
11712
11713 #endif /* #if __CRTL_VER >= 70300000 */
11714
11715 }  /* end of my_utime() */
11716 /*}}}*/
11717
11718 /*
11719  * flex_stat, flex_lstat, flex_fstat
11720  * basic stat, but gets it right when asked to stat
11721  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11722  */
11723
11724 #ifndef _USE_STD_STAT
11725 /* encode_dev packs a VMS device name string into an integer to allow
11726  * simple comparisons. This can be used, for example, to check whether two
11727  * files are located on the same device, by comparing their encoded device
11728  * names. Even a string comparison would not do, because stat() reuses the
11729  * device name buffer for each call; so without encode_dev, it would be
11730  * necessary to save the buffer and use strcmp (this would mean a number of
11731  * changes to the standard Perl code, to say nothing of what a Perl script
11732  * would have to do.
11733  *
11734  * The device lock id, if it exists, should be unique (unless perhaps compared
11735  * with lock ids transferred from other nodes). We have a lock id if the disk is
11736  * mounted cluster-wide, which is when we tend to get long (host-qualified)
11737  * device names. Thus we use the lock id in preference, and only if that isn't
11738  * available, do we try to pack the device name into an integer (flagged by
11739  * the sign bit (LOCKID_MASK) being set).
11740  *
11741  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11742  * name and its encoded form, but it seems very unlikely that we will find
11743  * two files on different disks that share the same encoded device names,
11744  * and even more remote that they will share the same file id (if the test
11745  * is to check for the same file).
11746  *
11747  * A better method might be to use sys$device_scan on the first call, and to
11748  * search for the device, returning an index into the cached array.
11749  * The number returned would be more intelligible.
11750  * This is probably not worth it, and anyway would take quite a bit longer
11751  * on the first call.
11752  */
11753 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
11754 static mydev_t encode_dev (pTHX_ const char *dev)
11755 {
11756   int i;
11757   unsigned long int f;
11758   mydev_t enc;
11759   char c;
11760   const char *q;
11761
11762   if (!dev || !dev[0]) return 0;
11763
11764 #if LOCKID_MASK
11765   {
11766     struct dsc$descriptor_s dev_desc;
11767     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11768
11769     /* For cluster-mounted disks, the disk lock identifier is unique, so we
11770        can try that first. */
11771     dev_desc.dsc$w_length =  strlen (dev);
11772     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
11773     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
11774     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
11775     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11776     if (!$VMS_STATUS_SUCCESS(status)) {
11777       switch (status) {
11778         case SS$_NOSUCHDEV:
11779           SETERRNO(ENODEV, status);
11780           return 0;
11781         default:
11782           _ckvmssts(status);
11783       }
11784     }
11785     if (lockid) return (lockid & ~LOCKID_MASK);
11786   }
11787 #endif
11788
11789   /* Otherwise we try to encode the device name */
11790   enc = 0;
11791   f = 1;
11792   i = 0;
11793   for (q = dev + strlen(dev); q--; q >= dev) {
11794     if (*q == ':')
11795         break;
11796     if (isdigit (*q))
11797       c= (*q) - '0';
11798     else if (isalpha (toupper (*q)))
11799       c= toupper (*q) - 'A' + (char)10;
11800     else
11801       continue; /* Skip '$'s */
11802     i++;
11803     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
11804     if (i>1) f *= 36;
11805     enc += f * (unsigned long int) c;
11806   }
11807   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
11808
11809 }  /* end of encode_dev() */
11810 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11811         device_no = encode_dev(aTHX_ devname)
11812 #else
11813 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11814         device_no = new_dev_no
11815 #endif
11816
11817 static int
11818 is_null_device(name)
11819     const char *name;
11820 {
11821   if (decc_bug_devnull != 0) {
11822     if (strncmp("/dev/null", name, 9) == 0)
11823       return 1;
11824   }
11825     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11826        The underscore prefix, controller letter, and unit number are
11827        independently optional; for our purposes, the colon punctuation
11828        is not.  The colon can be trailed by optional directory and/or
11829        filename, but two consecutive colons indicates a nodename rather
11830        than a device.  [pr]  */
11831   if (*name == '_') ++name;
11832   if (tolower(*name++) != 'n') return 0;
11833   if (tolower(*name++) != 'l') return 0;
11834   if (tolower(*name) == 'a') ++name;
11835   if (*name == '0') ++name;
11836   return (*name++ == ':') && (*name != ':');
11837 }
11838
11839
11840 static I32
11841 Perl_cando_by_name_int
11842    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
11843 {
11844   char usrname[L_cuserid];
11845   struct dsc$descriptor_s usrdsc =
11846          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11847   char *vmsname = NULL, *fileified = NULL;
11848   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11849   unsigned short int retlen, trnlnm_iter_count;
11850   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11851   union prvdef curprv;
11852   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11853          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11854          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11855   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11856          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11857          {0,0,0,0}};
11858   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11859          {0,0,0,0}};
11860   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11861   Stat_t st;
11862   static int profile_context = -1;
11863
11864   if (!fname || !*fname) return FALSE;
11865
11866   /* Make sure we expand logical names, since sys$check_access doesn't */
11867   fileified = PerlMem_malloc(VMS_MAXRSS);
11868   if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11869   if (!strpbrk(fname,"/]>:")) {
11870       strcpy(fileified,fname);
11871       trnlnm_iter_count = 0;
11872       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11873         trnlnm_iter_count++;
11874         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11875       }
11876       fname = fileified;
11877   }
11878
11879   vmsname = PerlMem_malloc(VMS_MAXRSS);
11880   if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11881   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11882     /* Don't know if already in VMS format, so make sure */
11883     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11884       PerlMem_free(fileified);
11885       PerlMem_free(vmsname);
11886       return FALSE;
11887     }
11888   }
11889   else {
11890     strcpy(vmsname,fname);
11891   }
11892
11893   /* sys$check_access needs a file spec, not a directory spec.
11894    * Don't use flex_stat here, as that depends on thread context
11895    * having been initialized, and we may get here during startup.
11896    */
11897
11898   retlen = namdsc.dsc$w_length = strlen(vmsname);
11899   if (vmsname[retlen-1] == ']'
11900       || vmsname[retlen-1] == '>'
11901       || vmsname[retlen-1] == ':'
11902       || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
11903
11904       if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) {
11905         PerlMem_free(fileified);
11906         PerlMem_free(vmsname);
11907         return FALSE;
11908       }
11909       fname = fileified;
11910   }
11911   else {
11912       fname = vmsname;
11913   }
11914
11915   retlen = namdsc.dsc$w_length = strlen(fname);
11916   namdsc.dsc$a_pointer = (char *)fname;
11917
11918   switch (bit) {
11919     case S_IXUSR: case S_IXGRP: case S_IXOTH:
11920       access = ARM$M_EXECUTE;
11921       flags = CHP$M_READ;
11922       break;
11923     case S_IRUSR: case S_IRGRP: case S_IROTH:
11924       access = ARM$M_READ;
11925       flags = CHP$M_READ | CHP$M_USEREADALL;
11926       break;
11927     case S_IWUSR: case S_IWGRP: case S_IWOTH:
11928       access = ARM$M_WRITE;
11929       flags = CHP$M_READ | CHP$M_WRITE;
11930       break;
11931     case S_IDUSR: case S_IDGRP: case S_IDOTH:
11932       access = ARM$M_DELETE;
11933       flags = CHP$M_READ | CHP$M_WRITE;
11934       break;
11935     default:
11936       if (fileified != NULL)
11937         PerlMem_free(fileified);
11938       if (vmsname != NULL)
11939         PerlMem_free(vmsname);
11940       return FALSE;
11941   }
11942
11943   /* Before we call $check_access, create a user profile with the current
11944    * process privs since otherwise it just uses the default privs from the
11945    * UAF and might give false positives or negatives.  This only works on
11946    * VMS versions v6.0 and later since that's when sys$create_user_profile
11947    * became available.
11948    */
11949
11950   /* get current process privs and username */
11951   _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11952   _ckvmssts_noperl(iosb[0]);
11953
11954 #if defined(__VMS_VER) && __VMS_VER >= 60000000
11955
11956   /* find out the space required for the profile */
11957   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11958                                     &usrprodsc.dsc$w_length,&profile_context));
11959
11960   /* allocate space for the profile and get it filled in */
11961   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11962   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11963   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11964                                     &usrprodsc.dsc$w_length,&profile_context));
11965
11966   /* use the profile to check access to the file; free profile & analyze results */
11967   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
11968   PerlMem_free(usrprodsc.dsc$a_pointer);
11969   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11970
11971 #else
11972
11973   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11974
11975 #endif
11976
11977   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
11978       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11979       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11980     set_vaxc_errno(retsts);
11981     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11982     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11983     else set_errno(ENOENT);
11984     if (fileified != NULL)
11985       PerlMem_free(fileified);
11986     if (vmsname != NULL)
11987       PerlMem_free(vmsname);
11988     return FALSE;
11989   }
11990   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11991     if (fileified != NULL)
11992       PerlMem_free(fileified);
11993     if (vmsname != NULL)
11994       PerlMem_free(vmsname);
11995     return TRUE;
11996   }
11997   _ckvmssts_noperl(retsts);
11998
11999   if (fileified != NULL)
12000     PerlMem_free(fileified);
12001   if (vmsname != NULL)
12002     PerlMem_free(vmsname);
12003   return FALSE;  /* Should never get here */
12004
12005 }
12006
12007 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
12008 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12009  * subset of the applicable information.
12010  */
12011 bool
12012 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12013 {
12014   return cando_by_name_int
12015         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12016 }  /* end of cando() */
12017 /*}}}*/
12018
12019
12020 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12021 I32
12022 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12023 {
12024    return cando_by_name_int(bit, effective, fname, 0);
12025
12026 }  /* end of cando_by_name() */
12027 /*}}}*/
12028
12029
12030 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12031 int
12032 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12033 {
12034   if (!fstat(fd,(stat_t *) statbufp)) {
12035     char *cptr;
12036     char *vms_filename;
12037     vms_filename = PerlMem_malloc(VMS_MAXRSS);
12038     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12039
12040     /* Save name for cando by name in VMS format */
12041     cptr = getname(fd, vms_filename, 1);
12042
12043     /* This should not happen, but just in case */
12044     if (cptr == NULL) {
12045         statbufp->st_devnam[0] = 0;
12046     }
12047     else {
12048         /* Make sure that the saved name fits in 255 characters */
12049         cptr = do_rmsexpand
12050                        (vms_filename,
12051                         statbufp->st_devnam,
12052                         0,
12053                         NULL,
12054                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
12055                         NULL,
12056                         NULL);
12057         if (cptr == NULL)
12058             statbufp->st_devnam[0] = 0;
12059     }
12060     PerlMem_free(vms_filename);
12061
12062     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12063     VMS_DEVICE_ENCODE
12064         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12065
12066 #   ifdef RTL_USES_UTC
12067 #   ifdef VMSISH_TIME
12068     if (VMSISH_TIME) {
12069       statbufp->st_mtime = _toloc(statbufp->st_mtime);
12070       statbufp->st_atime = _toloc(statbufp->st_atime);
12071       statbufp->st_ctime = _toloc(statbufp->st_ctime);
12072     }
12073 #   endif
12074 #   else
12075 #   ifdef VMSISH_TIME
12076     if (!VMSISH_TIME) { /* Return UTC instead of local time */
12077 #   else
12078     if (1) {
12079 #   endif
12080       statbufp->st_mtime = _toutc(statbufp->st_mtime);
12081       statbufp->st_atime = _toutc(statbufp->st_atime);
12082       statbufp->st_ctime = _toutc(statbufp->st_ctime);
12083     }
12084 #endif
12085     return 0;
12086   }
12087   return -1;
12088
12089 }  /* end of flex_fstat() */
12090 /*}}}*/
12091
12092 #if !defined(__VAX) && __CRTL_VER >= 80200000
12093 #ifdef lstat
12094 #undef lstat
12095 #endif
12096 #else
12097 #ifdef lstat
12098 #undef lstat
12099 #endif
12100 #define lstat(_x, _y) stat(_x, _y)
12101 #endif
12102
12103 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
12104
12105 static int
12106 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12107 {
12108     char fileified[VMS_MAXRSS];
12109     char temp_fspec[VMS_MAXRSS];
12110     char *save_spec;
12111     int retval = -1;
12112     dSAVEDERRNO;
12113
12114     if (!fspec) return retval;
12115     SAVE_ERRNO;
12116     strcpy(temp_fspec, fspec);
12117
12118     if (decc_bug_devnull != 0) {
12119       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
12120         memset(statbufp,0,sizeof *statbufp);
12121         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12122         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12123         statbufp->st_uid = 0x00010001;
12124         statbufp->st_gid = 0x0001;
12125         time((time_t *)&statbufp->st_mtime);
12126         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12127         return 0;
12128       }
12129     }
12130
12131     /* Try for a directory name first.  If fspec contains a filename without
12132      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12133      * and sea:[wine.dark]water. exist, we prefer the directory here.
12134      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12135      * not sea:[wine.dark]., if the latter exists.  If the intended target is
12136      * the file with null type, specify this by calling flex_stat() with
12137      * a '.' at the end of fspec.
12138      *
12139      * If we are in Posix filespec mode, accept the filename as is.
12140      */
12141
12142
12143 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12144   /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
12145    * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
12146    */
12147   if (!decc_efs_charset)
12148     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
12149 #endif
12150
12151 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12152   if (decc_posix_compliant_pathnames == 0) {
12153 #endif
12154     if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
12155       if (lstat_flag == 0)
12156         retval = stat(fileified,(stat_t *) statbufp);
12157       else
12158         retval = lstat(fileified,(stat_t *) statbufp);
12159       save_spec = fileified;
12160     }
12161     if (retval) {
12162       if (lstat_flag == 0)
12163         retval = stat(temp_fspec,(stat_t *) statbufp);
12164       else
12165         retval = lstat(temp_fspec,(stat_t *) statbufp);
12166       save_spec = temp_fspec;
12167     }
12168 /*
12169  * In debugging, on 8.3 Alpha, I found a case where stat was returning a
12170  * file not found error for a directory named foo:[bar.t] or /foo/bar/t
12171  * and lstat was working correctly for the same file.
12172  * The only syntax that was working for stat was "foo:[bar]t.dir".
12173  *
12174  * Other directories with the same syntax worked fine.
12175  * So work around the problem when it shows up here.
12176  */
12177     if (retval) {
12178         int save_errno = errno;
12179         if (do_tovmsspec(fspec, temp_fspec, 0, NULL) != NULL) {
12180             if (do_fileify_dirspec(temp_fspec, fileified, 0, NULL) != NULL) {
12181                 retval = stat(fileified, (stat_t *) statbufp);
12182                 save_spec = fileified;
12183             }
12184         }
12185         /* Restore the errno value if third stat does not succeed */
12186         if (retval != 0)
12187             errno = save_errno;
12188     }
12189 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12190   } else {
12191     if (lstat_flag == 0)
12192       retval = stat(temp_fspec,(stat_t *) statbufp);
12193     else
12194       retval = lstat(temp_fspec,(stat_t *) statbufp);
12195       save_spec = temp_fspec;
12196   }
12197 #endif
12198
12199 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12200   /* As you were... */
12201   if (!decc_efs_charset)
12202     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12203 #endif
12204
12205     if (!retval) {
12206     char * cptr;
12207     int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12208
12209       /* If this is an lstat, do not follow the link */
12210       if (lstat_flag)
12211         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12212
12213       cptr = do_rmsexpand
12214        (save_spec, statbufp->st_devnam, 0, NULL, rmsex_flags, NULL, NULL);
12215       if (cptr == NULL)
12216         statbufp->st_devnam[0] = 0;
12217
12218       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12219       VMS_DEVICE_ENCODE
12220         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12221 #     ifdef RTL_USES_UTC
12222 #     ifdef VMSISH_TIME
12223       if (VMSISH_TIME) {
12224         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12225         statbufp->st_atime = _toloc(statbufp->st_atime);
12226         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12227       }
12228 #     endif
12229 #     else
12230 #     ifdef VMSISH_TIME
12231       if (!VMSISH_TIME) { /* Return UTC instead of local time */
12232 #     else
12233       if (1) {
12234 #     endif
12235         statbufp->st_mtime = _toutc(statbufp->st_mtime);
12236         statbufp->st_atime = _toutc(statbufp->st_atime);
12237         statbufp->st_ctime = _toutc(statbufp->st_ctime);
12238       }
12239 #     endif
12240     }
12241     /* If we were successful, leave errno where we found it */
12242     if (retval == 0) RESTORE_ERRNO;
12243     return retval;
12244
12245 }  /* end of flex_stat_int() */
12246
12247
12248 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12249 int
12250 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12251 {
12252    return flex_stat_int(fspec, statbufp, 0);
12253 }
12254 /*}}}*/
12255
12256 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12257 int
12258 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12259 {
12260    return flex_stat_int(fspec, statbufp, 1);
12261 }
12262 /*}}}*/
12263
12264
12265 /*{{{char *my_getlogin()*/
12266 /* VMS cuserid == Unix getlogin, except calling sequence */
12267 char *
12268 my_getlogin(void)
12269 {
12270     static char user[L_cuserid];
12271     return cuserid(user);
12272 }
12273 /*}}}*/
12274
12275
12276 /*  rmscopy - copy a file using VMS RMS routines
12277  *
12278  *  Copies contents and attributes of spec_in to spec_out, except owner
12279  *  and protection information.  Name and type of spec_in are used as
12280  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
12281  *  should try to propagate timestamps from the input file to the output file.
12282  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
12283  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
12284  *  propagated to the output file at creation iff the output file specification
12285  *  did not contain an explicit name or type, and the revision date is always
12286  *  updated at the end of the copy operation.  If it is greater than 0, then
12287  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12288  *  other than the revision date should be propagated, and bit 1 indicates
12289  *  that the revision date should be propagated.
12290  *
12291  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12292  *
12293  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12294  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
12295  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
12296  * as part of the Perl standard distribution under the terms of the
12297  * GNU General Public License or the Perl Artistic License.  Copies
12298  * of each may be found in the Perl standard distribution.
12299  */ /* FIXME */
12300 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12301 int
12302 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12303 {
12304     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12305          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12306     unsigned long int i, sts, sts2;
12307     int dna_len;
12308     struct FAB fab_in, fab_out;
12309     struct RAB rab_in, rab_out;
12310     rms_setup_nam(nam);
12311     rms_setup_nam(nam_out);
12312     struct XABDAT xabdat;
12313     struct XABFHC xabfhc;
12314     struct XABRDT xabrdt;
12315     struct XABSUM xabsum;
12316
12317     vmsin = PerlMem_malloc(VMS_MAXRSS);
12318     if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12319     vmsout = PerlMem_malloc(VMS_MAXRSS);
12320     if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12321     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
12322         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
12323       PerlMem_free(vmsin);
12324       PerlMem_free(vmsout);
12325       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12326       return 0;
12327     }
12328
12329     esa = PerlMem_malloc(VMS_MAXRSS);
12330     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12331     esal = NULL;
12332 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12333     esal = PerlMem_malloc(VMS_MAXRSS);
12334     if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12335 #endif
12336     fab_in = cc$rms_fab;
12337     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12338     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12339     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12340     fab_in.fab$l_fop = FAB$M_SQO;
12341     rms_bind_fab_nam(fab_in, nam);
12342     fab_in.fab$l_xab = (void *) &xabdat;
12343
12344     rsa = PerlMem_malloc(VMS_MAXRSS);
12345     if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12346     rsal = NULL;
12347 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12348     rsal = PerlMem_malloc(VMS_MAXRSS);
12349     if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12350 #endif
12351     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12352     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12353     rms_nam_esl(nam) = 0;
12354     rms_nam_rsl(nam) = 0;
12355     rms_nam_esll(nam) = 0;
12356     rms_nam_rsll(nam) = 0;
12357 #ifdef NAM$M_NO_SHORT_UPCASE
12358     if (decc_efs_case_preserve)
12359         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12360 #endif
12361
12362     xabdat = cc$rms_xabdat;        /* To get creation date */
12363     xabdat.xab$l_nxt = (void *) &xabfhc;
12364
12365     xabfhc = cc$rms_xabfhc;        /* To get record length */
12366     xabfhc.xab$l_nxt = (void *) &xabsum;
12367
12368     xabsum = cc$rms_xabsum;        /* To get key and area information */
12369
12370     if (!((sts = sys$open(&fab_in)) & 1)) {
12371       PerlMem_free(vmsin);
12372       PerlMem_free(vmsout);
12373       PerlMem_free(esa);
12374       if (esal != NULL)
12375         PerlMem_free(esal);
12376       PerlMem_free(rsa);
12377       if (rsal != NULL)
12378         PerlMem_free(rsal);
12379       set_vaxc_errno(sts);
12380       switch (sts) {
12381         case RMS$_FNF: case RMS$_DNF:
12382           set_errno(ENOENT); break;
12383         case RMS$_DIR:
12384           set_errno(ENOTDIR); break;
12385         case RMS$_DEV:
12386           set_errno(ENODEV); break;
12387         case RMS$_SYN:
12388           set_errno(EINVAL); break;
12389         case RMS$_PRV:
12390           set_errno(EACCES); break;
12391         default:
12392           set_errno(EVMSERR);
12393       }
12394       return 0;
12395     }
12396
12397     nam_out = nam;
12398     fab_out = fab_in;
12399     fab_out.fab$w_ifi = 0;
12400     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12401     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12402     fab_out.fab$l_fop = FAB$M_SQO;
12403     rms_bind_fab_nam(fab_out, nam_out);
12404     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12405     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12406     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12407     esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12408     if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12409     rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12410     if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12411     esal_out = NULL;
12412     rsal_out = NULL;
12413 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12414     esal_out = PerlMem_malloc(VMS_MAXRSS);
12415     if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12416     rsal_out = PerlMem_malloc(VMS_MAXRSS);
12417     if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12418 #endif
12419     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12420     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12421
12422     if (preserve_dates == 0) {  /* Act like DCL COPY */
12423       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12424       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
12425       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12426         PerlMem_free(vmsin);
12427         PerlMem_free(vmsout);
12428         PerlMem_free(esa);
12429         if (esal != NULL)
12430             PerlMem_free(esal);
12431         PerlMem_free(rsa);
12432         if (rsal != NULL)
12433             PerlMem_free(rsal);
12434         PerlMem_free(esa_out);
12435         if (esal_out != NULL)
12436             PerlMem_free(esal_out);
12437         PerlMem_free(rsa_out);
12438         if (rsal_out != NULL)
12439             PerlMem_free(rsal_out);
12440         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12441         set_vaxc_errno(sts);
12442         return 0;
12443       }
12444       fab_out.fab$l_xab = (void *) &xabdat;
12445       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12446         preserve_dates = 1;
12447     }
12448     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
12449       preserve_dates =0;      /* bitmask from this point forward   */
12450
12451     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12452     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12453       PerlMem_free(vmsin);
12454       PerlMem_free(vmsout);
12455       PerlMem_free(esa);
12456       if (esal != NULL)
12457           PerlMem_free(esal);
12458       PerlMem_free(rsa);
12459       if (rsal != NULL)
12460           PerlMem_free(rsal);
12461       PerlMem_free(esa_out);
12462       if (esal_out != NULL)
12463           PerlMem_free(esal_out);
12464       PerlMem_free(rsa_out);
12465       if (rsal_out != NULL)
12466           PerlMem_free(rsal_out);
12467       set_vaxc_errno(sts);
12468       switch (sts) {
12469         case RMS$_DNF:
12470           set_errno(ENOENT); break;
12471         case RMS$_DIR:
12472           set_errno(ENOTDIR); break;
12473         case RMS$_DEV:
12474           set_errno(ENODEV); break;
12475         case RMS$_SYN:
12476           set_errno(EINVAL); break;
12477         case RMS$_PRV:
12478           set_errno(EACCES); break;
12479         default:
12480           set_errno(EVMSERR);
12481       }
12482       return 0;
12483     }
12484     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
12485     if (preserve_dates & 2) {
12486       /* sys$close() will process xabrdt, not xabdat */
12487       xabrdt = cc$rms_xabrdt;
12488 #ifndef __GNUC__
12489       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12490 #else
12491       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12492        * is unsigned long[2], while DECC & VAXC use a struct */
12493       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12494 #endif
12495       fab_out.fab$l_xab = (void *) &xabrdt;
12496     }
12497
12498     ubf = PerlMem_malloc(32256);
12499     if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12500     rab_in = cc$rms_rab;
12501     rab_in.rab$l_fab = &fab_in;
12502     rab_in.rab$l_rop = RAB$M_BIO;
12503     rab_in.rab$l_ubf = ubf;
12504     rab_in.rab$w_usz = 32256;
12505     if (!((sts = sys$connect(&rab_in)) & 1)) {
12506       sys$close(&fab_in); sys$close(&fab_out);
12507       PerlMem_free(vmsin);
12508       PerlMem_free(vmsout);
12509       PerlMem_free(ubf);
12510       PerlMem_free(esa);
12511       if (esal != NULL)
12512           PerlMem_free(esal);
12513       PerlMem_free(rsa);
12514       if (rsal != NULL)
12515           PerlMem_free(rsal);
12516       PerlMem_free(esa_out);
12517       if (esal_out != NULL)
12518           PerlMem_free(esal_out);
12519       PerlMem_free(rsa_out);
12520       if (rsal_out != NULL)
12521           PerlMem_free(rsal_out);
12522       set_errno(EVMSERR); set_vaxc_errno(sts);
12523       return 0;
12524     }
12525
12526     rab_out = cc$rms_rab;
12527     rab_out.rab$l_fab = &fab_out;
12528     rab_out.rab$l_rbf = ubf;
12529     if (!((sts = sys$connect(&rab_out)) & 1)) {
12530       sys$close(&fab_in); sys$close(&fab_out);
12531       PerlMem_free(vmsin);
12532       PerlMem_free(vmsout);
12533       PerlMem_free(ubf);
12534       PerlMem_free(esa);
12535       if (esal != NULL)
12536           PerlMem_free(esal);
12537       PerlMem_free(rsa);
12538       if (rsal != NULL)
12539           PerlMem_free(rsal);
12540       PerlMem_free(esa_out);
12541       if (esal_out != NULL)
12542           PerlMem_free(esal_out);
12543       PerlMem_free(rsa_out);
12544       if (rsal_out != NULL)
12545           PerlMem_free(rsal_out);
12546       set_errno(EVMSERR); set_vaxc_errno(sts);
12547       return 0;
12548     }
12549
12550     while ((sts = sys$read(&rab_in))) {  /* always true  */
12551       if (sts == RMS$_EOF) break;
12552       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12553       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12554         sys$close(&fab_in); sys$close(&fab_out);
12555         PerlMem_free(vmsin);
12556         PerlMem_free(vmsout);
12557         PerlMem_free(ubf);
12558         PerlMem_free(esa);
12559         if (esal != NULL)
12560             PerlMem_free(esal);
12561         PerlMem_free(rsa);
12562         if (rsal != NULL)
12563             PerlMem_free(rsal);
12564         PerlMem_free(esa_out);
12565         if (esal_out != NULL)
12566             PerlMem_free(esal_out);
12567         PerlMem_free(rsa_out);
12568         if (rsal_out != NULL)
12569             PerlMem_free(rsal_out);
12570         set_errno(EVMSERR); set_vaxc_errno(sts);
12571         return 0;
12572       }
12573     }
12574
12575
12576     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
12577     sys$close(&fab_in);  sys$close(&fab_out);
12578     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12579
12580     PerlMem_free(vmsin);
12581     PerlMem_free(vmsout);
12582     PerlMem_free(ubf);
12583     PerlMem_free(esa);
12584     if (esal != NULL)
12585         PerlMem_free(esal);
12586     PerlMem_free(rsa);
12587     if (rsal != NULL)
12588         PerlMem_free(rsal);
12589     PerlMem_free(esa_out);
12590     if (esal_out != NULL)
12591         PerlMem_free(esal_out);
12592     PerlMem_free(rsa_out);
12593     if (rsal_out != NULL)
12594         PerlMem_free(rsal_out);
12595
12596     if (!(sts & 1)) {
12597       set_errno(EVMSERR); set_vaxc_errno(sts);
12598       return 0;
12599     }
12600
12601     return 1;
12602
12603 }  /* end of rmscopy() */
12604 /*}}}*/
12605
12606
12607 /***  The following glue provides 'hooks' to make some of the routines
12608  * from this file available from Perl.  These routines are sufficiently
12609  * basic, and are required sufficiently early in the build process,
12610  * that's it's nice to have them available to miniperl as well as the
12611  * full Perl, so they're set up here instead of in an extension.  The
12612  * Perl code which handles importation of these names into a given
12613  * package lives in [.VMS]Filespec.pm in @INC.
12614  */
12615
12616 void
12617 rmsexpand_fromperl(pTHX_ CV *cv)
12618 {
12619   dXSARGS;
12620   char *fspec, *defspec = NULL, *rslt;
12621   STRLEN n_a;
12622   int fs_utf8, dfs_utf8;
12623
12624   fs_utf8 = 0;
12625   dfs_utf8 = 0;
12626   if (!items || items > 2)
12627     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12628   fspec = SvPV(ST(0),n_a);
12629   fs_utf8 = SvUTF8(ST(0));
12630   if (!fspec || !*fspec) XSRETURN_UNDEF;
12631   if (items == 2) {
12632     defspec = SvPV(ST(1),n_a);
12633     dfs_utf8 = SvUTF8(ST(1));
12634   }
12635   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12636   ST(0) = sv_newmortal();
12637   if (rslt != NULL) {
12638     sv_usepvn(ST(0),rslt,strlen(rslt));
12639     if (fs_utf8) {
12640         SvUTF8_on(ST(0));
12641     }
12642   }
12643   XSRETURN(1);
12644 }
12645
12646 void
12647 vmsify_fromperl(pTHX_ CV *cv)
12648 {
12649   dXSARGS;
12650   char *vmsified;
12651   STRLEN n_a;
12652   int utf8_fl;
12653
12654   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12655   utf8_fl = SvUTF8(ST(0));
12656   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12657   ST(0) = sv_newmortal();
12658   if (vmsified != NULL) {
12659     sv_usepvn(ST(0),vmsified,strlen(vmsified));
12660     if (utf8_fl) {
12661         SvUTF8_on(ST(0));
12662     }
12663   }
12664   XSRETURN(1);
12665 }
12666
12667 void
12668 unixify_fromperl(pTHX_ CV *cv)
12669 {
12670   dXSARGS;
12671   char *unixified;
12672   STRLEN n_a;
12673   int utf8_fl;
12674
12675   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12676   utf8_fl = SvUTF8(ST(0));
12677   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12678   ST(0) = sv_newmortal();
12679   if (unixified != NULL) {
12680     sv_usepvn(ST(0),unixified,strlen(unixified));
12681     if (utf8_fl) {
12682         SvUTF8_on(ST(0));
12683     }
12684   }
12685   XSRETURN(1);
12686 }
12687
12688 void
12689 fileify_fromperl(pTHX_ CV *cv)
12690 {
12691   dXSARGS;
12692   char *fileified;
12693   STRLEN n_a;
12694   int utf8_fl;
12695
12696   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12697   utf8_fl = SvUTF8(ST(0));
12698   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12699   ST(0) = sv_newmortal();
12700   if (fileified != NULL) {
12701     sv_usepvn(ST(0),fileified,strlen(fileified));
12702     if (utf8_fl) {
12703         SvUTF8_on(ST(0));
12704     }
12705   }
12706   XSRETURN(1);
12707 }
12708
12709 void
12710 pathify_fromperl(pTHX_ CV *cv)
12711 {
12712   dXSARGS;
12713   char *pathified;
12714   STRLEN n_a;
12715   int utf8_fl;
12716
12717   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12718   utf8_fl = SvUTF8(ST(0));
12719   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12720   ST(0) = sv_newmortal();
12721   if (pathified != NULL) {
12722     sv_usepvn(ST(0),pathified,strlen(pathified));
12723     if (utf8_fl) {
12724         SvUTF8_on(ST(0));
12725     }
12726   }
12727   XSRETURN(1);
12728 }
12729
12730 void
12731 vmspath_fromperl(pTHX_ CV *cv)
12732 {
12733   dXSARGS;
12734   char *vmspath;
12735   STRLEN n_a;
12736   int utf8_fl;
12737
12738   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12739   utf8_fl = SvUTF8(ST(0));
12740   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12741   ST(0) = sv_newmortal();
12742   if (vmspath != NULL) {
12743     sv_usepvn(ST(0),vmspath,strlen(vmspath));
12744     if (utf8_fl) {
12745         SvUTF8_on(ST(0));
12746     }
12747   }
12748   XSRETURN(1);
12749 }
12750
12751 void
12752 unixpath_fromperl(pTHX_ CV *cv)
12753 {
12754   dXSARGS;
12755   char *unixpath;
12756   STRLEN n_a;
12757   int utf8_fl;
12758
12759   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12760   utf8_fl = SvUTF8(ST(0));
12761   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12762   ST(0) = sv_newmortal();
12763   if (unixpath != NULL) {
12764     sv_usepvn(ST(0),unixpath,strlen(unixpath));
12765     if (utf8_fl) {
12766         SvUTF8_on(ST(0));
12767     }
12768   }
12769   XSRETURN(1);
12770 }
12771
12772 void
12773 candelete_fromperl(pTHX_ CV *cv)
12774 {
12775   dXSARGS;
12776   char *fspec, *fsp;
12777   SV *mysv;
12778   IO *io;
12779   STRLEN n_a;
12780
12781   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12782
12783   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12784   Newx(fspec, VMS_MAXRSS, char);
12785   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12786   if (SvTYPE(mysv) == SVt_PVGV) {
12787     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12788       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12789       ST(0) = &PL_sv_no;
12790       Safefree(fspec);
12791       XSRETURN(1);
12792     }
12793     fsp = fspec;
12794   }
12795   else {
12796     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12797       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12798       ST(0) = &PL_sv_no;
12799       Safefree(fspec);
12800       XSRETURN(1);
12801     }
12802   }
12803
12804   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12805   Safefree(fspec);
12806   XSRETURN(1);
12807 }
12808
12809 void
12810 rmscopy_fromperl(pTHX_ CV *cv)
12811 {
12812   dXSARGS;
12813   char *inspec, *outspec, *inp, *outp;
12814   int date_flag;
12815   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
12816                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12817   unsigned long int sts;
12818   SV *mysv;
12819   IO *io;
12820   STRLEN n_a;
12821
12822   if (items < 2 || items > 3)
12823     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12824
12825   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12826   Newx(inspec, VMS_MAXRSS, char);
12827   if (SvTYPE(mysv) == SVt_PVGV) {
12828     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12829       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12830       ST(0) = &PL_sv_no;
12831       Safefree(inspec);
12832       XSRETURN(1);
12833     }
12834     inp = inspec;
12835   }
12836   else {
12837     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12838       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12839       ST(0) = &PL_sv_no;
12840       Safefree(inspec);
12841       XSRETURN(1);
12842     }
12843   }
12844   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12845   Newx(outspec, VMS_MAXRSS, char);
12846   if (SvTYPE(mysv) == SVt_PVGV) {
12847     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12848       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12849       ST(0) = &PL_sv_no;
12850       Safefree(inspec);
12851       Safefree(outspec);
12852       XSRETURN(1);
12853     }
12854     outp = outspec;
12855   }
12856   else {
12857     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12858       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12859       ST(0) = &PL_sv_no;
12860       Safefree(inspec);
12861       Safefree(outspec);
12862       XSRETURN(1);
12863     }
12864   }
12865   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12866
12867   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
12868   Safefree(inspec);
12869   Safefree(outspec);
12870   XSRETURN(1);
12871 }
12872
12873 /* The mod2fname is limited to shorter filenames by design, so it should
12874  * not be modified to support longer EFS pathnames
12875  */
12876 void
12877 mod2fname(pTHX_ CV *cv)
12878 {
12879   dXSARGS;
12880   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12881        workbuff[NAM$C_MAXRSS*1 + 1];
12882   int total_namelen = 3, counter, num_entries;
12883   /* ODS-5 ups this, but we want to be consistent, so... */
12884   int max_name_len = 39;
12885   AV *in_array = (AV *)SvRV(ST(0));
12886
12887   num_entries = av_len(in_array);
12888
12889   /* All the names start with PL_. */
12890   strcpy(ultimate_name, "PL_");
12891
12892   /* Clean up our working buffer */
12893   Zero(work_name, sizeof(work_name), char);
12894
12895   /* Run through the entries and build up a working name */
12896   for(counter = 0; counter <= num_entries; counter++) {
12897     /* If it's not the first name then tack on a __ */
12898     if (counter) {
12899       strcat(work_name, "__");
12900     }
12901     strcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)));
12902   }
12903
12904   /* Check to see if we actually have to bother...*/
12905   if (strlen(work_name) + 3 <= max_name_len) {
12906     strcat(ultimate_name, work_name);
12907   } else {
12908     /* It's too darned big, so we need to go strip. We use the same */
12909     /* algorithm as xsubpp does. First, strip out doubled __ */
12910     char *source, *dest, last;
12911     dest = workbuff;
12912     last = 0;
12913     for (source = work_name; *source; source++) {
12914       if (last == *source && last == '_') {
12915         continue;
12916       }
12917       *dest++ = *source;
12918       last = *source;
12919     }
12920     /* Go put it back */
12921     strcpy(work_name, workbuff);
12922     /* Is it still too big? */
12923     if (strlen(work_name) + 3 > max_name_len) {
12924       /* Strip duplicate letters */
12925       last = 0;
12926       dest = workbuff;
12927       for (source = work_name; *source; source++) {
12928         if (last == toupper(*source)) {
12929         continue;
12930         }
12931         *dest++ = *source;
12932         last = toupper(*source);
12933       }
12934       strcpy(work_name, workbuff);
12935     }
12936
12937     /* Is it *still* too big? */
12938     if (strlen(work_name) + 3 > max_name_len) {
12939       /* Too bad, we truncate */
12940       work_name[max_name_len - 2] = 0;
12941     }
12942     strcat(ultimate_name, work_name);
12943   }
12944
12945   /* Okay, return it */
12946   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
12947   XSRETURN(1);
12948 }
12949
12950 void
12951 hushexit_fromperl(pTHX_ CV *cv)
12952 {
12953     dXSARGS;
12954
12955     if (items > 0) {
12956         VMSISH_HUSHED = SvTRUE(ST(0));
12957     }
12958     ST(0) = boolSV(VMSISH_HUSHED);
12959     XSRETURN(1);
12960 }
12961
12962
12963 PerlIO *
12964 Perl_vms_start_glob
12965    (pTHX_ SV *tmpglob,
12966     IO *io)
12967 {
12968     PerlIO *fp;
12969     struct vs_str_st *rslt;
12970     char *vmsspec;
12971     char *rstr;
12972     char *begin, *cp;
12973     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
12974     PerlIO *tmpfp;
12975     STRLEN i;
12976     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12977     struct dsc$descriptor_vs rsdsc;
12978     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
12979     unsigned long hasver = 0, isunix = 0;
12980     unsigned long int lff_flags = 0;
12981     int rms_sts;
12982
12983     if (!SvOK(tmpglob)) {
12984         SETERRNO(ENOENT,RMS$_FNF);
12985         return NULL;
12986     }
12987
12988 #ifdef VMS_LONGNAME_SUPPORT
12989     lff_flags = LIB$M_FIL_LONG_NAMES;
12990 #endif
12991     /* The Newx macro will not allow me to assign a smaller array
12992      * to the rslt pointer, so we will assign it to the begin char pointer
12993      * and then copy the value into the rslt pointer.
12994      */
12995     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
12996     rslt = (struct vs_str_st *)begin;
12997     rslt->length = 0;
12998     rstr = &rslt->str[0];
12999     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13000     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13001     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13002     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13003
13004     Newx(vmsspec, VMS_MAXRSS, char);
13005
13006         /* We could find out if there's an explicit dev/dir or version
13007            by peeking into lib$find_file's internal context at
13008            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13009            but that's unsupported, so I don't want to do it now and
13010            have it bite someone in the future. */
13011         /* Fix-me: vms_split_path() is the only way to do this, the
13012            existing method will fail with many legal EFS or UNIX specifications
13013          */
13014
13015     cp = SvPV(tmpglob,i);
13016
13017     for (; i; i--) {
13018         if (cp[i] == ';') hasver = 1;
13019         if (cp[i] == '.') {
13020             if (sts) hasver = 1;
13021             else sts = 1;
13022         }
13023         if (cp[i] == '/') {
13024             hasdir = isunix = 1;
13025             break;
13026         }
13027         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13028             hasdir = 1;
13029             break;
13030         }
13031     }
13032     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13033         int found = 0;
13034         Stat_t st;
13035         int stat_sts;
13036         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13037         if (!stat_sts && S_ISDIR(st.st_mode)) {
13038             wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
13039             ok = (wilddsc.dsc$a_pointer != NULL);
13040             /* maybe passed 'foo' rather than '[.foo]', thus not detected above */
13041             hasdir = 1;
13042         }
13043         else {
13044             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13045             ok = (wilddsc.dsc$a_pointer != NULL);
13046         }
13047         if (ok)
13048             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13049
13050         /* If not extended character set, replace ? with % */
13051         /* With extended character set, ? is a wildcard single character */
13052         if (!decc_efs_case_preserve) {
13053             for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
13054                 if (*cp == '?') *cp = '%';
13055         }
13056         sts = SS$_NORMAL;
13057         while (ok && $VMS_STATUS_SUCCESS(sts)) {
13058          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13059          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13060
13061             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13062                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
13063             if (!$VMS_STATUS_SUCCESS(sts))
13064                 break;
13065
13066             found++;
13067
13068             /* with varying string, 1st word of buffer contains result length */
13069             rstr[rslt->length] = '\0';
13070
13071              /* Find where all the components are */
13072              v_sts = vms_split_path
13073                        (rstr,
13074                         &v_spec,
13075                         &v_len,
13076                         &r_spec,
13077                         &r_len,
13078                         &d_spec,
13079                         &d_len,
13080                         &n_spec,
13081                         &n_len,
13082                         &e_spec,
13083                         &e_len,
13084                         &vs_spec,
13085                         &vs_len);
13086
13087             /* If no version on input, truncate the version on output */
13088             if (!hasver && (vs_len > 0)) {
13089                 *vs_spec = '\0';
13090                 vs_len = 0;
13091
13092                 /* No version & a null extension on UNIX handling */
13093                 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
13094                     e_len = 0;
13095                     *e_spec = '\0';
13096                 }
13097             }
13098
13099             if (!decc_efs_case_preserve) {
13100                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13101             }
13102
13103             if (hasdir) {
13104                 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13105                 begin = rstr;
13106             }
13107             else {
13108                 /* Start with the name */
13109                 begin = n_spec;
13110             }
13111             strcat(begin,"\n");
13112             ok = (PerlIO_puts(tmpfp,begin) != EOF);
13113         }
13114         if (cxt) (void)lib$find_file_end(&cxt);
13115
13116         if (!found) {
13117             /* Be POSIXish: return the input pattern when no matches */
13118             strcpy(rstr,SvPVX(tmpglob));
13119             strcat(rstr,"\n");
13120             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13121         }
13122
13123         if (ok && sts != RMS$_NMF &&
13124             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13125         if (!ok) {
13126             if (!(sts & 1)) {
13127                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13128             }
13129             PerlIO_close(tmpfp);
13130             fp = NULL;
13131         }
13132         else {
13133             PerlIO_rewind(tmpfp);
13134             IoTYPE(io) = IoTYPE_RDONLY;
13135             IoIFP(io) = fp = tmpfp;
13136             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
13137         }
13138     }
13139     Safefree(vmsspec);
13140     Safefree(rslt);
13141     return fp;
13142 }
13143
13144
13145 static char *
13146 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13147                    int *utf8_fl);
13148
13149 void
13150 unixrealpath_fromperl(pTHX_ CV *cv)
13151 {
13152     dXSARGS;
13153     char *fspec, *rslt_spec, *rslt;
13154     STRLEN n_a;
13155
13156     if (!items || items != 1)
13157         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
13158
13159     fspec = SvPV(ST(0),n_a);
13160     if (!fspec || !*fspec) XSRETURN_UNDEF;
13161
13162     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13163     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13164
13165     ST(0) = sv_newmortal();
13166     if (rslt != NULL)
13167         sv_usepvn(ST(0),rslt,strlen(rslt));
13168     else
13169         Safefree(rslt_spec);
13170         XSRETURN(1);
13171 }
13172
13173 static char *
13174 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13175                    int *utf8_fl);
13176
13177 void
13178 vmsrealpath_fromperl(pTHX_ CV *cv)
13179 {
13180     dXSARGS;
13181     char *fspec, *rslt_spec, *rslt;
13182     STRLEN n_a;
13183
13184     if (!items || items != 1)
13185         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
13186
13187     fspec = SvPV(ST(0),n_a);
13188     if (!fspec || !*fspec) XSRETURN_UNDEF;
13189
13190     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13191     rslt = do_vms_realname(fspec, rslt_spec, NULL);
13192
13193     ST(0) = sv_newmortal();
13194     if (rslt != NULL)
13195         sv_usepvn(ST(0),rslt,strlen(rslt));
13196     else
13197         Safefree(rslt_spec);
13198         XSRETURN(1);
13199 }
13200
13201 #ifdef HAS_SYMLINK
13202 /*
13203  * A thin wrapper around decc$symlink to make sure we follow the
13204  * standard and do not create a symlink with a zero-length name.
13205  *
13206  * Also in ODS-2 mode, existing tests assume that the link target
13207  * will be converted to UNIX format.
13208  */
13209 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
13210 int Perl_my_symlink(pTHX_ const char *contents, const char *link_name) {
13211   if (!link_name || !*link_name) {
13212     SETERRNO(ENOENT, SS$_NOSUCHFILE);
13213     return -1;
13214   }
13215
13216   if (decc_efs_charset) {
13217       return symlink(contents, link_name);
13218   } else {
13219       int sts;
13220       char * utarget;
13221
13222       /* Unless we are in ODS-5 mode, convert the symlink target to UNIX */
13223       /* because in order to work, the symlink target must be in UNIX format */
13224
13225       /* As symbolic links can hold things other than files, we will only do */
13226       /* the conversion in in ODS-2 mode */
13227
13228       Newx(utarget, VMS_MAXRSS + 1, char);
13229       if (do_tounixspec(contents, utarget, 0, NULL) == NULL) {
13230
13231           /* This should not fail, as an untranslatable filename */
13232           /* should be passed through */
13233           utarget = (char *)contents;
13234       }
13235       sts = symlink(utarget, link_name);
13236       Safefree(utarget);
13237       return sts;
13238   }
13239
13240 }
13241 /*}}}*/
13242
13243 #endif /* HAS_SYMLINK */
13244
13245 int do_vms_case_tolerant(void);
13246
13247 void
13248 case_tolerant_process_fromperl(pTHX_ CV *cv)
13249 {
13250   dXSARGS;
13251   ST(0) = boolSV(do_vms_case_tolerant());
13252   XSRETURN(1);
13253 }
13254
13255 #ifdef USE_ITHREADS
13256
13257 void
13258 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13259                           struct interp_intern *dst)
13260 {
13261     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13262
13263     memcpy(dst,src,sizeof(struct interp_intern));
13264 }
13265
13266 #endif
13267
13268 void
13269 Perl_sys_intern_clear(pTHX)
13270 {
13271 }
13272
13273 void
13274 Perl_sys_intern_init(pTHX)
13275 {
13276     unsigned int ix = RAND_MAX;
13277     double x;
13278
13279     VMSISH_HUSHED = 0;
13280
13281     MY_POSIX_EXIT = vms_posix_exit;
13282
13283     x = (float)ix;
13284     MY_INV_RAND_MAX = 1./x;
13285 }
13286
13287 void
13288 init_os_extras(void)
13289 {
13290   dTHX;
13291   char* file = __FILE__;
13292   if (decc_disable_to_vms_logname_translation) {
13293     no_translate_barewords = TRUE;
13294   } else {
13295     no_translate_barewords = FALSE;
13296   }
13297
13298   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13299   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13300   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13301   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13302   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13303   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13304   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13305   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13306   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13307   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13308   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13309   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13310   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13311   newXSproto("VMS::Filespec::case_tolerant_process",
13312       case_tolerant_process_fromperl,file,"");
13313
13314   store_pipelocs(aTHX);         /* will redo any earlier attempts */
13315
13316   return;
13317 }
13318
13319 #if __CRTL_VER == 80200000
13320 /* This missed getting in to the DECC SDK for 8.2 */
13321 char *realpath(const char *file_name, char * resolved_name, ...);
13322 #endif
13323
13324 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13325 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13326  * The perl fallback routine to provide realpath() is not as efficient
13327  * on OpenVMS.
13328  */
13329
13330 /* Hack, use old stat() as fastest way of getting ino_t and device */
13331 int decc$stat(const char *name, void * statbuf);
13332
13333
13334 /* Realpath is fragile.  In 8.3 it does not work if the feature
13335  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13336  * links are implemented in RMS, not the CRTL. It also can fail if the
13337  * user does not have read/execute access to some of the directories.
13338  * So in order for Do What I Mean mode to work, if realpath() fails,
13339  * fall back to looking up the filename by the device name and FID.
13340  */
13341
13342 int vms_fid_to_name(char * outname, int outlen, const char * name)
13343 {
13344 struct statbuf_t {
13345     char           * st_dev;
13346     unsigned short st_ino[3];
13347     unsigned short padw;
13348     unsigned long  padl[30];  /* plenty of room */
13349 } statbuf;
13350 int sts;
13351 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13352 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13353
13354     sts = decc$stat(name, &statbuf);
13355     if (sts == 0) {
13356
13357         dvidsc.dsc$a_pointer=statbuf.st_dev;
13358        dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13359
13360         specdsc.dsc$a_pointer = outname;
13361         specdsc.dsc$w_length = outlen-1;
13362
13363        sts = lib$fid_to_name
13364             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13365        if ($VMS_STATUS_SUCCESS(sts)) {
13366             outname[specdsc.dsc$w_length] = 0;
13367             return 0;
13368         }
13369     }
13370     return sts;
13371 }
13372
13373
13374
13375 static char *
13376 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13377                    int *utf8_fl)
13378 {
13379     char * rslt = NULL;
13380
13381 #ifdef HAS_SYMLINK
13382     if (decc_posix_compliant_pathnames > 0 ) {
13383         /* realpath currently only works if posix compliant pathnames are
13384          * enabled.  It may start working when they are not, but in that
13385          * case we still want the fallback behavior for backwards compatibility
13386          */
13387         rslt = realpath(filespec, outbuf);
13388     }
13389 #endif
13390
13391     if (rslt == NULL) {
13392         char * vms_spec;
13393         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13394         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13395         int file_len;
13396
13397         /* Fall back to fid_to_name */
13398
13399         Newx(vms_spec, VMS_MAXRSS + 1, char);
13400
13401         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec);
13402         if (sts == 0) {
13403
13404
13405             /* Now need to trim the version off */
13406             sts = vms_split_path
13407                   (vms_spec,
13408                    &v_spec,
13409                    &v_len,
13410                    &r_spec,
13411                    &r_len,
13412                    &d_spec,
13413                    &d_len,
13414                    &n_spec,
13415                    &n_len,
13416                    &e_spec,
13417                    &e_len,
13418                    &vs_spec,
13419                    &vs_len);
13420
13421
13422                 if (sts == 0) {
13423                     int haslower = 0;
13424                     const char *cp;
13425
13426                     /* Trim off the version */
13427                     int file_len = v_len + r_len + d_len + n_len + e_len;
13428                     vms_spec[file_len] = 0;
13429
13430                     /* The result is expected to be in UNIX format */
13431                     rslt = do_tounixspec(vms_spec, outbuf, 0, utf8_fl);
13432
13433                     /* Downcase if input had any lower case letters and
13434                      * case preservation is not in effect.
13435                      */
13436                     if (!decc_efs_case_preserve) {
13437                         for (cp = filespec; *cp; cp++)
13438                             if (islower(*cp)) { haslower = 1; break; }
13439
13440                         if (haslower) __mystrtolower(rslt);
13441                     }
13442                 }
13443         } else {
13444
13445             /* Now for some hacks to deal with backwards and forward */
13446             /* compatibilty */
13447             if (!decc_efs_charset) {
13448
13449                 /* 1. ODS-2 mode wants to do a syntax only translation */
13450                 rslt = do_rmsexpand(filespec, outbuf,
13451                                     0, NULL, 0, NULL, utf8_fl);
13452
13453             } else {
13454                 if (decc_filename_unix_report) {
13455                     char * dir_name;
13456                     char * vms_dir_name;
13457                     char * file_name;
13458
13459                     /* 2. ODS-5 / UNIX report mode should return a failure */
13460                     /*    if the parent directory also does not exist */
13461                     /*    Otherwise, get the real path for the parent */
13462                     /*    and add the child to it.
13463
13464                     /* basename / dirname only available for VMS 7.0+ */
13465                     /* So we may need to implement them as common routines */
13466
13467                     Newx(dir_name, VMS_MAXRSS + 1, char);
13468                     Newx(vms_dir_name, VMS_MAXRSS + 1, char);
13469                     dir_name[0] = '\0';
13470                     file_name = NULL;
13471
13472                     /* First try a VMS parse */
13473                     sts = vms_split_path
13474                           (filespec,
13475                            &v_spec,
13476                            &v_len,
13477                            &r_spec,
13478                            &r_len,
13479                            &d_spec,
13480                            &d_len,
13481                            &n_spec,
13482                            &n_len,
13483                            &e_spec,
13484                            &e_len,
13485                            &vs_spec,
13486                            &vs_len);
13487
13488                     if (sts == 0) {
13489                         /* This is VMS */
13490
13491                         int dir_len = v_len + r_len + d_len + n_len;
13492                         if (dir_len > 0) {
13493                            strncpy(dir_name, filespec, dir_len);
13494                            dir_name[dir_len] = '\0';
13495                            file_name = (char *)&filespec[dir_len + 1];
13496                         }
13497                     } else {
13498                         /* This must be UNIX */
13499                         char * tchar;
13500
13501                         tchar = strrchr(filespec, '/');
13502
13503                         if (tchar != NULL) {
13504                             int dir_len = tchar - filespec;
13505                             strncpy(dir_name, filespec, dir_len);
13506                             dir_name[dir_len] = '\0';
13507                             file_name = (char *) &filespec[dir_len + 1];
13508                         }
13509                     }
13510
13511                     /* Dir name is defaulted */
13512                     if (dir_name[0] == 0) {
13513                         dir_name[0] = '.';
13514                         dir_name[1] = '\0';
13515                     }
13516
13517                     /* Need realpath for the directory */
13518                     sts = vms_fid_to_name(vms_dir_name,
13519                                           VMS_MAXRSS + 1,
13520                                           dir_name);
13521
13522                     if (sts == 0) {
13523                         /* Now need to pathify it.
13524                         char *tdir = do_pathify_dirspec(vms_dir_name,
13525                                                         outbuf, utf8_fl);
13526
13527                         /* And now add the original filespec to it */
13528                         if (file_name != NULL) {
13529                             strcat(outbuf, file_name);
13530                         }
13531                         return outbuf;
13532                     }
13533                     Safefree(vms_dir_name);
13534                     Safefree(dir_name);
13535                 }
13536             }
13537         }
13538         Safefree(vms_spec);
13539     }
13540     return rslt;
13541 }
13542
13543 static char *
13544 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13545                    int *utf8_fl)
13546 {
13547     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13548     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13549     int file_len;
13550
13551     /* Fall back to fid_to_name */
13552
13553     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec);
13554     if (sts != 0) {
13555         return NULL;
13556     }
13557     else {
13558
13559
13560         /* Now need to trim the version off */
13561         sts = vms_split_path
13562                   (outbuf,
13563                    &v_spec,
13564                    &v_len,
13565                    &r_spec,
13566                    &r_len,
13567                    &d_spec,
13568                    &d_len,
13569                    &n_spec,
13570                    &n_len,
13571                    &e_spec,
13572                    &e_len,
13573                    &vs_spec,
13574                    &vs_len);
13575
13576
13577         if (sts == 0) {
13578             int haslower = 0;
13579             const char *cp;
13580
13581             /* Trim off the version */
13582             int file_len = v_len + r_len + d_len + n_len + e_len;
13583             outbuf[file_len] = 0;
13584
13585             /* Downcase if input had any lower case letters and
13586              * case preservation is not in effect.
13587              */
13588             if (!decc_efs_case_preserve) {
13589                 for (cp = filespec; *cp; cp++)
13590                     if (islower(*cp)) { haslower = 1; break; }
13591
13592                 if (haslower) __mystrtolower(outbuf);
13593             }
13594         }
13595     }
13596     return outbuf;
13597 }
13598
13599
13600 /*}}}*/
13601 /* External entry points */
13602 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13603 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
13604
13605 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13606 { return do_vms_realname(filespec, outbuf, utf8_fl); }
13607
13608 /* case_tolerant */
13609
13610 /*{{{int do_vms_case_tolerant(void)*/
13611 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13612  * controlled by a process setting.
13613  */
13614 int do_vms_case_tolerant(void)
13615 {
13616     return vms_process_case_tolerant;
13617 }
13618 /*}}}*/
13619 /* External entry points */
13620 #if __CRTL_VER >= 70301000 && !defined(__VAX)
13621 int Perl_vms_case_tolerant(void)
13622 { return do_vms_case_tolerant(); }
13623 #else
13624 int Perl_vms_case_tolerant(void)
13625 { return vms_process_case_tolerant; }
13626 #endif
13627
13628
13629  /* Start of DECC RTL Feature handling */
13630
13631 static int sys_trnlnm
13632    (const char * logname,
13633     char * value,
13634     int value_len)
13635 {
13636     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
13637     const unsigned long attr = LNM$M_CASE_BLIND;
13638     struct dsc$descriptor_s name_dsc;
13639     int status;
13640     unsigned short result;
13641     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
13642                                 {0, 0, 0, 0}};
13643
13644     name_dsc.dsc$w_length = strlen(logname);
13645     name_dsc.dsc$a_pointer = (char *)logname;
13646     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13647     name_dsc.dsc$b_class = DSC$K_CLASS_S;
13648
13649     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
13650
13651     if ($VMS_STATUS_SUCCESS(status)) {
13652
13653          /* Null terminate and return the string */
13654         /*--------------------------------------*/
13655         value[result] = 0;
13656     }
13657
13658     return status;
13659 }
13660
13661 static int sys_crelnm
13662    (const char * logname,
13663     const char * value)
13664 {
13665     int ret_val;
13666     const char * proc_table = "LNM$PROCESS_TABLE";
13667     struct dsc$descriptor_s proc_table_dsc;
13668     struct dsc$descriptor_s logname_dsc;
13669     struct itmlst_3 item_list[2];
13670
13671     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
13672     proc_table_dsc.dsc$w_length = strlen(proc_table);
13673     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13674     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
13675
13676     logname_dsc.dsc$a_pointer = (char *) logname;
13677     logname_dsc.dsc$w_length = strlen(logname);
13678     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13679     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
13680
13681     item_list[0].buflen = strlen(value);
13682     item_list[0].itmcode = LNM$_STRING;
13683     item_list[0].bufadr = (char *)value;
13684     item_list[0].retlen = NULL;
13685
13686     item_list[1].buflen = 0;
13687     item_list[1].itmcode = 0;
13688
13689     ret_val = sys$crelnm
13690                        (NULL,
13691                         (const struct dsc$descriptor_s *)&proc_table_dsc,
13692                         (const struct dsc$descriptor_s *)&logname_dsc,
13693                         NULL,
13694                         (const struct item_list_3 *) item_list);
13695
13696     return ret_val;
13697 }
13698
13699 /* C RTL Feature settings */
13700
13701 static int set_features
13702    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
13703     int (* cli_routine)(void),  /* Not documented */
13704     void *image_info)           /* Not documented */
13705 {
13706     int status;
13707     int s;
13708     char* str;
13709     char val_str[10];
13710 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13711     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13712     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13713     unsigned long case_perm;
13714     unsigned long case_image;
13715 #endif
13716
13717     /* Allow an exception to bring Perl into the VMS debugger */
13718     vms_debug_on_exception = 0;
13719     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
13720     if ($VMS_STATUS_SUCCESS(status)) {
13721        val_str[0] = _toupper(val_str[0]);
13722        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13723          vms_debug_on_exception = 1;
13724        else
13725          vms_debug_on_exception = 0;
13726     }
13727
13728     /* Debug unix/vms file translation routines */
13729     vms_debug_fileify = 0;
13730     status = sys_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
13731     if ($VMS_STATUS_SUCCESS(status)) {
13732         val_str[0] = _toupper(val_str[0]);
13733         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13734             vms_debug_fileify = 1;
13735         else
13736             vms_debug_fileify = 0;
13737     }
13738
13739
13740     /* Historically PERL has been doing vmsify / stat differently than */
13741     /* the CRTL.  In particular, under some conditions the CRTL will   */
13742     /* remove some illegal characters like spaces from filenames       */
13743     /* resulting in some differences.  The stat()/lstat() wrapper has  */
13744     /* been reporting such file names as invalid and fails to stat them */
13745     /* fixing this bug so that stat()/lstat() accept these like the     */
13746     /* CRTL does will result in several tests failing.                  */
13747     /* This should really be fixed, but for now, set up a feature to    */
13748     /* enable it so that the impact can be studied.                     */
13749     vms_bug_stat_filename = 0;
13750     status = sys_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
13751     if ($VMS_STATUS_SUCCESS(status)) {
13752         val_str[0] = _toupper(val_str[0]);
13753         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13754             vms_bug_stat_filename = 1;
13755         else
13756             vms_bug_stat_filename = 0;
13757     }
13758
13759
13760     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
13761     vms_vtf7_filenames = 0;
13762     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
13763     if ($VMS_STATUS_SUCCESS(status)) {
13764        val_str[0] = _toupper(val_str[0]);
13765        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13766          vms_vtf7_filenames = 1;
13767        else
13768          vms_vtf7_filenames = 0;
13769     }
13770
13771     /* unlink all versions on unlink() or rename() */
13772     vms_unlink_all_versions = 0;
13773     status = sys_trnlnm
13774         ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13775     if ($VMS_STATUS_SUCCESS(status)) {
13776        val_str[0] = _toupper(val_str[0]);
13777        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13778          vms_unlink_all_versions = 1;
13779        else
13780          vms_unlink_all_versions = 0;
13781     }
13782
13783     /* Dectect running under GNV Bash or other UNIX like shell */
13784 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13785     gnv_unix_shell = 0;
13786     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
13787     if ($VMS_STATUS_SUCCESS(status)) {
13788          gnv_unix_shell = 1;
13789          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
13790          set_feature_default("DECC$EFS_CHARSET", 1);
13791          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
13792          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
13793          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
13794          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
13795          vms_unlink_all_versions = 1;
13796          vms_posix_exit = 1;
13797     }
13798 #endif
13799
13800     /* hacks to see if known bugs are still present for testing */
13801
13802     /* PCP mode requires creating /dev/null special device file */
13803     decc_bug_devnull = 0;
13804     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
13805     if ($VMS_STATUS_SUCCESS(status)) {
13806        val_str[0] = _toupper(val_str[0]);
13807        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13808           decc_bug_devnull = 1;
13809        else
13810           decc_bug_devnull = 0;
13811     }
13812
13813     /* UNIX directory names with no paths are broken in a lot of places */
13814     decc_dir_barename = 1;
13815     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
13816     if ($VMS_STATUS_SUCCESS(status)) {
13817       val_str[0] = _toupper(val_str[0]);
13818       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13819         decc_dir_barename = 1;
13820       else
13821         decc_dir_barename = 0;
13822     }
13823
13824 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13825     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
13826     if (s >= 0) {
13827         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
13828         if (decc_disable_to_vms_logname_translation < 0)
13829             decc_disable_to_vms_logname_translation = 0;
13830     }
13831
13832     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
13833     if (s >= 0) {
13834         decc_efs_case_preserve = decc$feature_get_value(s, 1);
13835         if (decc_efs_case_preserve < 0)
13836             decc_efs_case_preserve = 0;
13837     }
13838
13839     s = decc$feature_get_index("DECC$EFS_CHARSET");
13840     decc_efs_charset_index = s;
13841     if (s >= 0) {
13842         decc_efs_charset = decc$feature_get_value(s, 1);
13843         if (decc_efs_charset < 0)
13844             decc_efs_charset = 0;
13845     }
13846
13847     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
13848     if (s >= 0) {
13849         decc_filename_unix_report = decc$feature_get_value(s, 1);
13850         if (decc_filename_unix_report > 0) {
13851             decc_filename_unix_report = 1;
13852             vms_posix_exit = 1;
13853         }
13854         else
13855             decc_filename_unix_report = 0;
13856     }
13857
13858     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
13859     if (s >= 0) {
13860         decc_filename_unix_only = decc$feature_get_value(s, 1);
13861         if (decc_filename_unix_only > 0) {
13862             decc_filename_unix_only = 1;
13863         }
13864         else {
13865             decc_filename_unix_only = 0;
13866         }
13867     }
13868
13869     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
13870     if (s >= 0) {
13871         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
13872         if (decc_filename_unix_no_version < 0)
13873             decc_filename_unix_no_version = 0;
13874     }
13875
13876     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
13877     if (s >= 0) {
13878         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
13879         if (decc_readdir_dropdotnotype < 0)
13880             decc_readdir_dropdotnotype = 0;
13881     }
13882
13883 #if __CRTL_VER >= 80200000
13884     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
13885     if (s >= 0) {
13886         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
13887         if (decc_posix_compliant_pathnames < 0)
13888             decc_posix_compliant_pathnames = 0;
13889         if (decc_posix_compliant_pathnames > 4)
13890             decc_posix_compliant_pathnames = 0;
13891     }
13892
13893 #endif
13894 #else
13895     status = sys_trnlnm
13896         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
13897     if ($VMS_STATUS_SUCCESS(status)) {
13898         val_str[0] = _toupper(val_str[0]);
13899         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13900            decc_disable_to_vms_logname_translation = 1;
13901         }
13902     }
13903
13904 #ifndef __VAX
13905     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
13906     if ($VMS_STATUS_SUCCESS(status)) {
13907         val_str[0] = _toupper(val_str[0]);
13908         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13909            decc_efs_case_preserve = 1;
13910         }
13911     }
13912 #endif
13913
13914     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
13915     if ($VMS_STATUS_SUCCESS(status)) {
13916         val_str[0] = _toupper(val_str[0]);
13917         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13918            decc_filename_unix_report = 1;
13919         }
13920     }
13921     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
13922     if ($VMS_STATUS_SUCCESS(status)) {
13923         val_str[0] = _toupper(val_str[0]);
13924         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13925            decc_filename_unix_only = 1;
13926            decc_filename_unix_report = 1;
13927         }
13928     }
13929     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
13930     if ($VMS_STATUS_SUCCESS(status)) {
13931         val_str[0] = _toupper(val_str[0]);
13932         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13933            decc_filename_unix_no_version = 1;
13934         }
13935     }
13936     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
13937     if ($VMS_STATUS_SUCCESS(status)) {
13938         val_str[0] = _toupper(val_str[0]);
13939         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13940            decc_readdir_dropdotnotype = 1;
13941         }
13942     }
13943 #endif
13944
13945 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
13946
13947      /* Report true case tolerance */
13948     /*----------------------------*/
13949     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
13950     if (!$VMS_STATUS_SUCCESS(status))
13951         case_perm = PPROP$K_CASE_BLIND;
13952     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
13953     if (!$VMS_STATUS_SUCCESS(status))
13954         case_image = PPROP$K_CASE_BLIND;
13955     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
13956         (case_image == PPROP$K_CASE_SENSITIVE))
13957         vms_process_case_tolerant = 0;
13958
13959 #endif
13960
13961     /* USE POSIX/DCL Exit codes - Recommended, but needs to default to  */
13962     /* for strict backward compatibilty */
13963     status = sys_trnlnm
13964         ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
13965     if ($VMS_STATUS_SUCCESS(status)) {
13966        val_str[0] = _toupper(val_str[0]);
13967        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13968          vms_posix_exit = 1;
13969        else
13970          vms_posix_exit = 0;
13971     }
13972
13973
13974     /* CRTL can be initialized past this point, but not before. */
13975 /*    DECC$CRTL_INIT(); */
13976
13977     return SS$_NORMAL;
13978 }
13979
13980 #ifdef __DECC
13981 #pragma nostandard
13982 #pragma extern_model save
13983 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
13984         const __align (LONGWORD) int spare[8] = {0};
13985
13986 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
13987 #if __DECC_VER >= 60560002
13988 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
13989 #else
13990 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
13991 #endif
13992 #endif /* __DECC */
13993
13994 const long vms_cc_features = (const long)set_features;
13995
13996 /*
13997 ** Force a reference to LIB$INITIALIZE to ensure it
13998 ** exists in the image.
13999 */
14000 int lib$initialize(void);
14001 #ifdef __DECC
14002 #pragma extern_model strict_refdef
14003 #endif
14004     int lib_init_ref = (int) lib$initialize;
14005
14006 #ifdef __DECC
14007 #pragma extern_model restore
14008 #pragma standard
14009 #endif
14010
14011 /*  End of vms.c */