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 #if !defined(__VAX) && __CRTL_VER >= 80200000
 223 #ifdef lstat
 224 #undef lstat
 225 #endif
 226 #else
 227 #ifdef lstat
 228 #undef lstat
 229 #endif
 230 #define lstat(_x, _y) stat(_x, _y)
 231 #endif
 232
 233 /* Routine to create a decterm for use with the Perl debugger */
 234 /* No headers, this information was found in the Programming Concepts Manual */
 235
 236 static int (*decw_term_port)
 237    (const struct dsc$descriptor_s * display,
 238     const struct dsc$descriptor_s * setup_file,
 239     const struct dsc$descriptor_s * customization,
 240     struct dsc$descriptor_s * result_device_name,
 241     unsigned short * result_device_name_length,
 242     void * controller,
 243     void * char_buffer,
 244     void * char_change_buffer) = 0;
 245
 246 /* gcc's header files don't #define direct access macros
 247  * corresponding to VAXC's variant structs */
 248 #ifdef __GNUC__
 249 #  define uic$v_format uic$r_uic_form.uic$v_format
 250 #  define uic$v_group uic$r_uic_form.uic$v_group
 251 #  define uic$v_member uic$r_uic_form.uic$v_member
 252 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 253 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 254 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 255 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 256 #endif
 257
 258 #if defined(NEED_AN_H_ERRNO)
 259 dEXT int h_errno;
 260 #endif
 261
 262 #ifdef __DECC
 263 #pragma message disable pragma
 264 #pragma member_alignment save
 265 #pragma nomember_alignment longword
 266 #pragma message save
 267 #pragma message disable misalgndmem
 268 #endif
 269 struct itmlst_3 {
 270   unsigned short int buflen;
 271   unsigned short int itmcode;
 272   void *bufadr;
 273   unsigned short int *retlen;
 274 };
 275
 276 struct filescan_itmlst_2 {
 277     unsigned short length;
 278     unsigned short itmcode;
 279     char * component;
 280 };
 281
 282 struct vs_str_st {
 283     unsigned short length;
 284     char str[65536];
 285 };
 286
 287 #ifdef __DECC
 288 #pragma message restore
 289 #pragma member_alignment restore
 290 #endif
 291
 292 #define do_fileify_dirspec(a,b,c,d)     mp_do_fileify_dirspec(aTHX_ a,b,c,d)
 293 #define do_pathify_dirspec(a,b,c,d)     mp_do_pathify_dirspec(aTHX_ a,b,c,d)
 294 #define do_tovmsspec(a,b,c,d)           mp_do_tovmsspec(aTHX_ a,b,c,0,d)
 295 #define do_tovmspath(a,b,c,d)           mp_do_tovmspath(aTHX_ a,b,c,d)
 296 #define do_rmsexpand(a,b,c,d,e,f,g)     mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
 297 #define do_vms_realpath(a,b,c)          mp_do_vms_realpath(aTHX_ a,b,c)
 298 #define do_vms_realname(a,b,c)          mp_do_vms_realname(aTHX_ a,b,c)
 299 #define do_tounixspec(a,b,c,d)          mp_do_tounixspec(aTHX_ a,b,c,d)
 300 #define do_tounixpath(a,b,c,d)          mp_do_tounixpath(aTHX_ a,b,c,d)
 301 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 302 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 303 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 304
 305 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
 306 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
 307 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
 308 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
 309
 310 static char *  int_rmsexpand_vms(
 311     const char * filespec, char * outbuf, unsigned opts);
 312 static char * int_rmsexpand_tovms(
 313     const char * filespec, char * outbuf, unsigned opts);
 314 static char *int_tovmsspec
 315    (const char *path, char *buf, int dir_flag, int * utf8_flag);
 316 static char * int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl);
 317 static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl);
 318 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl);
 319
 320 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 321 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 322
 323 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 324  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 325  * the Perl facility.
 326  */
 327 #define PERL_LNM_MAX_ITER 10
 328
 329   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 330 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 331 #define MAX_DCL_SYMBOL          (8192)
 332 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 333 #else
 334 #define MAX_DCL_SYMBOL          (1024)
 335 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 336 #endif
 337
 338 static char *__mystrtolower(char *str)
 339 {
 340   if (str) for (; *str; ++str) *str= tolower(*str);
 341   return str;
 342 }
 343
 344 static struct dsc$descriptor_s fildevdsc =
 345   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 346 static struct dsc$descriptor_s crtlenvdsc =
 347   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 348 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 349 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 350 static struct dsc$descriptor_s **env_tables = defenv;
 351 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 352
 353 /* True if we shouldn't treat barewords as logicals during directory */
 354 /* munching */
 355 static int no_translate_barewords;
 356
 357 #ifndef RTL_USES_UTC
 358 static int tz_updated = 1;
 359 #endif
 360
 361 /* DECC Features that may need to affect how Perl interprets
 362  * displays filename information
 363  */
 364 static int decc_disable_to_vms_logname_translation = 1;
 365 static int decc_disable_posix_root = 1;
 366 int decc_efs_case_preserve = 0;
 367 static int decc_efs_charset = 0;
 368 static int decc_efs_charset_index = -1;
 369 static int decc_filename_unix_no_version = 0;
 370 static int decc_filename_unix_only = 0;
 371 int decc_filename_unix_report = 0;
 372 int decc_posix_compliant_pathnames = 0;
 373 int decc_readdir_dropdotnotype = 0;
 374 static int vms_process_case_tolerant = 1;
 375 int vms_vtf7_filenames = 0;
 376 int gnv_unix_shell = 0;
 377 static int vms_unlink_all_versions = 0;
 378 static int vms_posix_exit = 0;
 379
 380 /* bug workarounds if needed */
 381 int decc_bug_devnull = 1;
 382 int decc_dir_barename = 0;
 383 int vms_bug_stat_filename = 0;
 384
 385 static int vms_debug_on_exception = 0;
 386 static int vms_debug_fileify = 0;
 387
 388 /* Simple logical name translation */
 389 static int simple_trnlnm
 390    (const char * logname,
 391     char * value,
 392     int value_len)
 393 {
 394     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
 395     const unsigned long attr = LNM$M_CASE_BLIND;
 396     struct dsc$descriptor_s name_dsc;
 397     int status;
 398     unsigned short result;
 399     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
 400                                 {0, 0, 0, 0}};
 401
 402     name_dsc.dsc$w_length = strlen(logname);
 403     name_dsc.dsc$a_pointer = (char *)logname;
 404     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
 405     name_dsc.dsc$b_class = DSC$K_CLASS_S;
 406
 407     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
 408
 409     if ($VMS_STATUS_SUCCESS(status)) {
 410
 411          /* Null terminate and return the string */
 412         /*--------------------------------------*/
 413         value[result] = 0;
 414         return result;
 415     }
 416
 417     return 0;
 418 }
 419
 420
 421 /* Is this a UNIX file specification?
 422  *   No longer a simple check with EFS file specs
 423  *   For now, not a full check, but need to
 424  *   handle POSIX ^UP^ specifications
 425  *   Fixing to handle ^/ cases would require
 426  *   changes to many other conversion routines.
 427  */
 428
 429 static int is_unix_filespec(const char *path)
 430 {
 431 int ret_val;
 432 const char * pch1;
 433
 434     ret_val = 0;
 435     if (strncmp(path,"\"^UP^",5) != 0) {
 436         pch1 = strchr(path, '/');
 437         if (pch1 != NULL)
 438             ret_val = 1;
 439         else {
 440
 441             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 442             if (decc_filename_unix_report || decc_filename_unix_only) {
 443             if (strcmp(path,".") == 0)
 444                 ret_val = 1;
 445             }
 446         }
 447     }
 448     return ret_val;
 449 }
 450
 451 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 452  */
 453
 454 static void ucs2_to_vtf7
 455    (char *outspec,
 456     unsigned long ucs2_char,
 457     int * output_cnt)
 458 {
 459 unsigned char * ucs_ptr;
 460 int hex;
 461
 462     ucs_ptr = (unsigned char *)&ucs2_char;
 463
 464     outspec[0] = '^';
 465     outspec[1] = 'U';
 466     hex = (ucs_ptr[1] >> 4) & 0xf;
 467     if (hex < 0xA)
 468         outspec[2] = hex + '0';
 469     else
 470         outspec[2] = (hex - 9) + 'A';
 471     hex = ucs_ptr[1] & 0xF;
 472     if (hex < 0xA)
 473         outspec[3] = hex + '0';
 474     else {
 475         outspec[3] = (hex - 9) + 'A';
 476     }
 477     hex = (ucs_ptr[0] >> 4) & 0xf;
 478     if (hex < 0xA)
 479         outspec[4] = hex + '0';
 480     else
 481         outspec[4] = (hex - 9) + 'A';
 482     hex = ucs_ptr[1] & 0xF;
 483     if (hex < 0xA)
 484         outspec[5] = hex + '0';
 485     else {
 486         outspec[5] = (hex - 9) + 'A';
 487     }
 488     *output_cnt = 6;
 489 }
 490
 491
 492 /* This handles the conversion of a UNIX extended character set to a ^
 493  * escaped VMS character.
 494  * in a UNIX file specification.
 495  *
 496  * The output count variable contains the number of characters added
 497  * to the output string.
 498  *
 499  * The return value is the number of characters read from the input string
 500  */
 501 static int copy_expand_unix_filename_escape
 502   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 503 {
 504 int count;
 505 int scnt;
 506 int utf8_flag;
 507
 508     utf8_flag = 0;
 509     if (utf8_fl)
 510       utf8_flag = *utf8_fl;
 511
 512     count = 0;
 513     *output_cnt = 0;
 514     if (*inspec >= 0x80) {
 515         if (utf8_fl && vms_vtf7_filenames) {
 516         unsigned long ucs_char;
 517
 518             ucs_char = 0;
 519
 520             if ((*inspec & 0xE0) == 0xC0) {
 521                 /* 2 byte Unicode */
 522                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 523                 if (ucs_char >= 0x80) {
 524                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 525                     return 2;
 526                 }
 527             } else if ((*inspec & 0xF0) == 0xE0) {
 528                 /* 3 byte Unicode */
 529                 ucs_char = ((inspec[0] & 0xF) << 12) +
 530                    ((inspec[1] & 0x3f) << 6) +
 531                    (inspec[2] & 0x3f);
 532                 if (ucs_char >= 0x800) {
 533                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 534                     return 3;
 535                 }
 536
 537 #if 0 /* I do not see longer sequences supported by OpenVMS */
 538       /* Maybe some one can fix this later */
 539             } else if ((*inspec & 0xF8) == 0xF0) {
 540                 /* 4 byte Unicode */
 541                 /* UCS-4 to UCS-2 */
 542             } else if ((*inspec & 0xFC) == 0xF8) {
 543                 /* 5 byte Unicode */
 544                 /* UCS-4 to UCS-2 */
 545             } else if ((*inspec & 0xFE) == 0xFC) {
 546                 /* 6 byte Unicode */
 547                 /* UCS-4 to UCS-2 */
 548 #endif
 549             }
 550         }
 551
 552         /* High bit set, but not a Unicode character! */
 553
 554         /* Non printing DECMCS or ISO Latin-1 character? */
 555         if (*inspec <= 0x9F) {
 556         int hex;
 557             outspec[0] = '^';
 558             outspec++;
 559             hex = (*inspec >> 4) & 0xF;
 560             if (hex < 0xA)
 561                 outspec[1] = hex + '0';
 562             else {
 563                 outspec[1] = (hex - 9) + 'A';
 564             }
 565             hex = *inspec & 0xF;
 566             if (hex < 0xA)
 567                 outspec[2] = hex + '0';
 568             else {
 569                 outspec[2] = (hex - 9) + 'A';
 570             }
 571             *output_cnt = 3;
 572             return 1;
 573         } else if (*inspec == 0xA0) {
 574             outspec[0] = '^';
 575             outspec[1] = 'A';
 576             outspec[2] = '0';
 577             *output_cnt = 3;
 578             return 1;
 579         } else if (*inspec == 0xFF) {
 580             outspec[0] = '^';
 581             outspec[1] = 'F';
 582             outspec[2] = 'F';
 583             *output_cnt = 3;
 584             return 1;
 585         }
 586         *outspec = *inspec;
 587         *output_cnt = 1;
 588         return 1;
 589     }
 590
 591     /* Is this a macro that needs to be passed through?
 592      * Macros start with $( and an alpha character, followed
 593      * by a string of alpha numeric characters ending with a )
 594      * If this does not match, then encode it as ODS-5.
 595      */
 596     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 597     int tcnt;
 598
 599         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 600             tcnt = 3;
 601             outspec[0] = inspec[0];
 602             outspec[1] = inspec[1];
 603             outspec[2] = inspec[2];
 604
 605             while(isalnum(inspec[tcnt]) ||
 606                   (inspec[2] == '.') || (inspec[2] == '_')) {
 607                 outspec[tcnt] = inspec[tcnt];
 608                 tcnt++;
 609             }
 610             if (inspec[tcnt] == ')') {
 611                 outspec[tcnt] = inspec[tcnt];
 612                 tcnt++;
 613                 *output_cnt = tcnt;
 614                 return tcnt;
 615             }
 616         }
 617     }
 618
 619     switch (*inspec) {
 620     case 0x7f:
 621         outspec[0] = '^';
 622         outspec[1] = '7';
 623         outspec[2] = 'F';
 624         *output_cnt = 3;
 625         return 1;
 626         break;
 627     case '?':
 628         if (decc_efs_charset == 0)
 629           outspec[0] = '%';
 630         else
 631           outspec[0] = '?';
 632         *output_cnt = 1;
 633         return 1;
 634         break;
 635     case '.':
 636     case '~':
 637     case '!':
 638     case '#':
 639     case '&':
 640     case '\'':
 641     case '`':
 642     case '(':
 643     case ')':
 644     case '+':
 645     case '@':
 646     case '{':
 647     case '}':
 648     case ',':
 649     case ';':
 650     case '[':
 651     case ']':
 652     case '%':
 653     case '^':
 654     case '\\':
 655         /* Don't escape again if following character is
 656          * already something we escape.
 657          */
 658         if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
 659             *outspec = *inspec;
 660             *output_cnt = 1;
 661             return 1;
 662             break;
 663         }
 664         /* But otherwise fall through and escape it. */
 665     case '=':
 666         /* Assume that this is to be escaped */
 667         outspec[0] = '^';
 668         outspec[1] = *inspec;
 669         *output_cnt = 2;
 670         return 1;
 671         break;
 672     case ' ': /* space */
 673         /* Assume that this is to be escaped */
 674         outspec[0] = '^';
 675         outspec[1] = '_';
 676         *output_cnt = 2;
 677         return 1;
 678         break;
 679     default:
 680         *outspec = *inspec;
 681         *output_cnt = 1;
 682         return 1;
 683         break;
 684     }
 685 }
 686
 687
 688 /* This handles the expansion of a '^' prefix to the proper character
 689  * in a UNIX file specification.
 690  *
 691  * The output count variable contains the number of characters added
 692  * to the output string.
 693  *
 694  * The return value is the number of characters read from the input
 695  * string
 696  */
 697 static int copy_expand_vms_filename_escape
 698   (char *outspec, const char *inspec, int *output_cnt)
 699 {
 700 int count;
 701 int scnt;
 702
 703     count = 0;
 704     *output_cnt = 0;
 705     if (*inspec == '^') {
 706         inspec++;
 707         switch (*inspec) {
 708         /* Spaces and non-trailing dots should just be passed through,
 709          * but eat the escape character.
 710          */
 711         case '.':
 712             *outspec = *inspec;
 713             count += 2;
 714             (*output_cnt)++;
 715             break;
 716         case '_': /* space */
 717             *outspec = ' ';
 718             count += 2;
 719             (*output_cnt)++;
 720             break;
 721         case '^':
 722             /* Hmm.  Better leave the escape escaped. */
 723             outspec[0] = '^';
 724             outspec[1] = '^';
 725             count += 2;
 726             (*output_cnt) += 2;
 727             break;
 728         case 'U': /* Unicode - FIX-ME this is wrong. */
 729             inspec++;
 730             count++;
 731             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 732             if (scnt == 4) {
 733                 unsigned int c1, c2;
 734                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 735                 outspec[0] == c1 & 0xff;
 736                 outspec[1] == c2 & 0xff;
 737                 if (scnt > 1) {
 738                     (*output_cnt) += 2;
 739                     count += 4;
 740                 }
 741             }
 742             else {
 743                 /* Error - do best we can to continue */
 744                 *outspec = 'U';
 745                 outspec++;
 746                 (*output_cnt++);
 747                 *outspec = *inspec;
 748                 count++;
 749                 (*output_cnt++);
 750             }
 751             break;
 752         default:
 753             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 754             if (scnt == 2) {
 755                 /* Hex encoded */
 756                 unsigned int c1;
 757                 scnt = sscanf(inspec, "%2x", &c1);
 758                 outspec[0] = c1 & 0xff;
 759                 if (scnt > 0) {
 760                     (*output_cnt++);
 761                     count += 2;
 762                 }
 763             }
 764             else {
 765                 *outspec = *inspec;
 766                 count++;
 767                 (*output_cnt++);
 768             }
 769         }
 770     }
 771     else {
 772         *outspec = *inspec;
 773         count++;
 774         (*output_cnt)++;
 775     }
 776     return count;
 777 }
 778
 779 #ifdef sys$filescan
 780 #undef sys$filescan
 781 int sys$filescan
 782    (const struct dsc$descriptor_s * srcstr,
 783     struct filescan_itmlst_2 * valuelist,
 784     unsigned long * fldflags,
 785     struct dsc$descriptor_s *auxout,
 786     unsigned short * retlen);
 787 #endif
 788
 789 /* vms_split_path - Verify that the input file specification is a
 790  * VMS format file specification, and provide pointers to the components of
 791  * it.  With EFS format filenames, this is virtually the only way to
 792  * parse a VMS path specification into components.
 793  *
 794  * If the sum of the components do not add up to the length of the
 795  * string, then the passed file specification is probably a UNIX style
 796  * path.
 797  */
 798 static int vms_split_path
 799    (const char * path,
 800     char * * volume,
 801     int * vol_len,
 802     char * * root,
 803     int * root_len,
 804     char * * dir,
 805     int * dir_len,
 806     char * * name,
 807     int * name_len,
 808     char * * ext,
 809     int * ext_len,
 810     char * * version,
 811     int * ver_len)
 812 {
 813 struct dsc$descriptor path_desc;
 814 int status;
 815 unsigned long flags;
 816 int ret_stat;
 817 struct filescan_itmlst_2 item_list[9];
 818 const int filespec = 0;
 819 const int nodespec = 1;
 820 const int devspec = 2;
 821 const int rootspec = 3;
 822 const int dirspec = 4;
 823 const int namespec = 5;
 824 const int typespec = 6;
 825 const int verspec = 7;
 826
 827     /* Assume the worst for an easy exit */
 828     ret_stat = -1;
 829     *volume = NULL;
 830     *vol_len = 0;
 831     *root = NULL;
 832     *root_len = 0;
 833     *dir = NULL;
 834     *dir_len;
 835     *name = NULL;
 836     *name_len = 0;
 837     *ext = NULL;
 838     *ext_len = 0;
 839     *version = NULL;
 840     *ver_len = 0;
 841
 842     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 843     path_desc.dsc$w_length = strlen(path);
 844     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 845     path_desc.dsc$b_class = DSC$K_CLASS_S;
 846
 847     /* Get the total length, if it is shorter than the string passed
 848      * then this was probably not a VMS formatted file specification
 849      */
 850     item_list[filespec].itmcode = FSCN$_FILESPEC;
 851     item_list[filespec].length = 0;
 852     item_list[filespec].component = NULL;
 853
 854     /* If the node is present, then it gets considered as part of the
 855      * volume name to hopefully make things simple.
 856      */
 857     item_list[nodespec].itmcode = FSCN$_NODE;
 858     item_list[nodespec].length = 0;
 859     item_list[nodespec].component = NULL;
 860
 861     item_list[devspec].itmcode = FSCN$_DEVICE;
 862     item_list[devspec].length = 0;
 863     item_list[devspec].component = NULL;
 864
 865     /* root is a special case,  adding it to either the directory or
 866      * the device components will probalby complicate things for the
 867      * callers of this routine, so leave it separate.
 868      */
 869     item_list[rootspec].itmcode = FSCN$_ROOT;
 870     item_list[rootspec].length = 0;
 871     item_list[rootspec].component = NULL;
 872
 873     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 874     item_list[dirspec].length = 0;
 875     item_list[dirspec].component = NULL;
 876
 877     item_list[namespec].itmcode = FSCN$_NAME;
 878     item_list[namespec].length = 0;
 879     item_list[namespec].component = NULL;
 880
 881     item_list[typespec].itmcode = FSCN$_TYPE;
 882     item_list[typespec].length = 0;
 883     item_list[typespec].component = NULL;
 884
 885     item_list[verspec].itmcode = FSCN$_VERSION;
 886     item_list[verspec].length = 0;
 887     item_list[verspec].component = NULL;
 888
 889     item_list[8].itmcode = 0;
 890     item_list[8].length = 0;
 891     item_list[8].component = NULL;
 892
 893     status = sys$filescan
 894        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 895         &flags, NULL, NULL);
 896     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 897
 898     /* If we parsed it successfully these two lengths should be the same */
 899     if (path_desc.dsc$w_length != item_list[filespec].length)
 900         return ret_stat;
 901
 902     /* If we got here, then it is a VMS file specification */
 903     ret_stat = 0;
 904
 905     /* set the volume name */
 906     if (item_list[nodespec].length > 0) {
 907         *volume = item_list[nodespec].component;
 908         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 909     }
 910     else {
 911         *volume = item_list[devspec].component;
 912         *vol_len = item_list[devspec].length;
 913     }
 914
 915     *root = item_list[rootspec].component;
 916     *root_len = item_list[rootspec].length;
 917
 918     *dir = item_list[dirspec].component;
 919     *dir_len = item_list[dirspec].length;
 920
 921     /* Now fun with versions and EFS file specifications
 922      * The parser can not tell the difference when a "." is a version
 923      * delimiter or a part of the file specification.
 924      */
 925     if ((decc_efs_charset) &&
 926         (item_list[verspec].length > 0) &&
 927         (item_list[verspec].component[0] == '.')) {
 928         *name = item_list[namespec].component;
 929         *name_len = item_list[namespec].length + item_list[typespec].length;
 930         *ext = item_list[verspec].component;
 931         *ext_len = item_list[verspec].length;
 932         *version = NULL;
 933         *ver_len = 0;
 934     }
 935     else {
 936         *name = item_list[namespec].component;
 937         *name_len = item_list[namespec].length;
 938         *ext = item_list[typespec].component;
 939         *ext_len = item_list[typespec].length;
 940         *version = item_list[verspec].component;
 941         *ver_len = item_list[verspec].length;
 942     }
 943     return ret_stat;
 944 }
 945
 946 /* Routine to determine if the file specification ends with .dir */
 947 static int is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len) {
 948
 949     /* e_len must be 4, and version must be <= 2 characters */
 950     if (e_len != 4 || vs_len > 2)
 951         return 0;
 952
 953     /* If a version number is present, it needs to be one */
 954     if ((vs_len == 2) && (vs_spec[1] != '1'))
 955         return 0;
 956
 957     /* Look for the DIR on the extension */
 958     if (vms_process_case_tolerant) {
 959         if ((toupper(e_spec[1]) == 'D') &&
 960             (toupper(e_spec[2]) == 'I') &&
 961             (toupper(e_spec[3]) == 'R')) {
 962             return 1;
 963         }
 964     } else {
 965         /* Directory extensions are supposed to be in upper case only */
 966         /* I would not be surprised if this rule can not be enforced */
 967         /* if and when someone fully debugs the case sensitive mode */
 968         if ((e_spec[1] == 'D') &&
 969             (e_spec[2] == 'I') &&
 970             (e_spec[3] == 'R')) {
 971             return 1;
 972         }
 973     }
 974     return 0;
 975 }
 976
 977
 978 /* my_maxidx
 979  * Routine to retrieve the maximum equivalence index for an input
 980  * logical name.  Some calls to this routine have no knowledge if
 981  * the variable is a logical or not.  So on error we return a max
 982  * index of zero.
 983  */
 984 /*{{{int my_maxidx(const char *lnm) */
 985 static int
 986 my_maxidx(const char *lnm)
 987 {
 988     int status;
 989     int midx;
 990     int attr = LNM$M_CASE_BLIND;
 991     struct dsc$descriptor lnmdsc;
 992     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 993                                 {0, 0, 0, 0}};
 994
 995     lnmdsc.dsc$w_length = strlen(lnm);
 996     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 997     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 998     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 999
1000     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
1001     if ((status & 1) == 0)
1002        midx = 0;
1003
1004     return (midx);
1005 }
1006 /*}}}*/
1007
1008 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
1009 int
1010 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
1011   struct dsc$descriptor_s **tabvec, unsigned long int flags)
1012 {
1013     const char *cp1;
1014     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
1015     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
1016     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
1017     int midx;
1018     unsigned char acmode;
1019     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1020                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1021     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
1022                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
1023                                  {0, 0, 0, 0}};
1024     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1025 #if defined(PERL_IMPLICIT_CONTEXT)
1026     pTHX = NULL;
1027     if (PL_curinterp) {
1028       aTHX = PERL_GET_INTERP;
1029     } else {
1030       aTHX = NULL;
1031     }
1032 #endif
1033
1034     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
1035       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
1036     }
1037     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1038       *cp2 = _toupper(*cp1);
1039       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1040         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1041         return 0;
1042       }
1043     }
1044     lnmdsc.dsc$w_length = cp1 - lnm;
1045     lnmdsc.dsc$a_pointer = uplnm;
1046     uplnm[lnmdsc.dsc$w_length] = '\0';
1047     secure = flags & PERL__TRNENV_SECURE;
1048     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
1049     if (!tabvec || !*tabvec) tabvec = env_tables;
1050
1051     for (curtab = 0; tabvec[curtab]; curtab++) {
1052       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1053         if (!ivenv && !secure) {
1054           char *eq, *end;
1055           int i;
1056           if (!environ) {
1057             ivenv = 1;
1058 #if defined(PERL_IMPLICIT_CONTEXT)
1059             if (aTHX == NULL) {
1060                 fprintf(stderr,
1061                     "%%PERL-W-VMS_INIT Can't read CRTL environ\n");
1062             } else
1063 #endif
1064                 Perl_warn(aTHX_ "Can't read CRTL environ\n");
1065             continue;
1066           }
1067           retsts = SS$_NOLOGNAM;
1068           for (i = 0; environ[i]; i++) {
1069             if ((eq = strchr(environ[i],'=')) &&
1070                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
1071                 !strncmp(environ[i],uplnm,eq - environ[i])) {
1072               eq++;
1073               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
1074               if (!eqvlen) continue;
1075               retsts = SS$_NORMAL;
1076               break;
1077             }
1078           }
1079           if (retsts != SS$_NOLOGNAM) break;
1080         }
1081       }
1082       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1083                !str$case_blind_compare(&tmpdsc,&clisym)) {
1084         if (!ivsym && !secure) {
1085           unsigned short int deflen = LNM$C_NAMLENGTH;
1086           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1087           /* dynamic dsc to accomodate possible long value */
1088           _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
1089           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
1090           if (retsts & 1) {
1091             if (eqvlen > MAX_DCL_SYMBOL) {
1092               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
1093               eqvlen = MAX_DCL_SYMBOL;
1094               /* Special hack--we might be called before the interpreter's */
1095               /* fully initialized, in which case either thr or PL_curcop */
1096               /* might be bogus. We have to check, since ckWARN needs them */
1097               /* both to be valid if running threaded */
1098 #if defined(PERL_IMPLICIT_CONTEXT)
1099               if (aTHX == NULL) {
1100                   fprintf(stderr,
1101                      "%Perl-VMS-Init, Value of CLI symbol \"%s\" too long",lnm);
1102               } else
1103 #endif
1104                 if (ckWARN(WARN_MISC)) {
1105                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
1106                 }
1107             }
1108             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
1109           }
1110           _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
1111           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1112           if (retsts == LIB$_NOSUCHSYM) continue;
1113           break;
1114         }
1115       }
1116       else if (!ivlnm) {
1117         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
1118           midx = my_maxidx(lnm);
1119           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1120             lnmlst[1].bufadr = cp2;
1121             eqvlen = 0;
1122             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1123             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1124             if (retsts == SS$_NOLOGNAM) break;
1125             /* PPFs have a prefix */
1126             if (
1127 #if INTSIZE == 4
1128                  *((int *)uplnm) == *((int *)"SYS$")                    &&
1129 #endif
1130                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
1131                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
1132                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
1133                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
1134                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
1135               memmove(eqv,eqv+4,eqvlen-4);
1136               eqvlen -= 4;
1137             }
1138             cp2 += eqvlen;
1139             *cp2 = '\0';
1140           }
1141           if ((retsts == SS$_IVLOGNAM) ||
1142               (retsts == SS$_NOLOGNAM)) { continue; }
1143         }
1144         else {
1145           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1146           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1147           if (retsts == SS$_NOLOGNAM) continue;
1148           eqv[eqvlen] = '\0';
1149         }
1150         eqvlen = strlen(eqv);
1151         break;
1152       }
1153     }
1154     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1155     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1156              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
1157              retsts == SS$_NOLOGNAM) {
1158       set_errno(EINVAL);  set_vaxc_errno(retsts);
1159     }
1160     else _ckvmssts_noperl(retsts);
1161     return 0;
1162 }  /* end of vmstrnenv */
1163 /*}}}*/
1164
1165 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1166 /* Define as a function so we can access statics. */
1167 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1168 {
1169     int flags = 0;
1170
1171 #if defined(PERL_IMPLICIT_CONTEXT)
1172     if (aTHX != NULL)
1173 #endif
1174 #ifdef SECURE_INTERNAL_GETENV
1175         flags = (PL_curinterp ? PL_tainting : will_taint) ?
1176                  PERL__TRNENV_SECURE : 0;
1177 #endif
1178
1179     return vmstrnenv(lnm, eqv, idx, fildev, flags);
1180 }
1181 /*}}}*/
1182
1183 /* my_getenv
1184  * Note: Uses Perl temp to store result so char * can be returned to
1185  * caller; this pointer will be invalidated at next Perl statement
1186  * transition.
1187  * We define this as a function rather than a macro in terms of my_getenv_len()
1188  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1189  * allocate SVs).
1190  */
1191 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1192 char *
1193 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1194 {
1195     const char *cp1;
1196     static char *__my_getenv_eqv = NULL;
1197     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1198     unsigned long int idx = 0;
1199     int trnsuccess, success, secure, saverr, savvmserr;
1200     int midx, flags;
1201     SV *tmpsv;
1202
1203     midx = my_maxidx(lnm) + 1;
1204
1205     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1206       /* Set up a temporary buffer for the return value; Perl will
1207        * clean it up at the next statement transition */
1208       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1209       if (!tmpsv) return NULL;
1210       eqv = SvPVX(tmpsv);
1211     }
1212     else {
1213       /* Assume no interpreter ==> single thread */
1214       if (__my_getenv_eqv != NULL) {
1215         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1216       }
1217       else {
1218         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1219       }
1220       eqv = __my_getenv_eqv;
1221     }
1222
1223     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1224     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1225       int len;
1226       getcwd(eqv,LNM$C_NAMLENGTH);
1227
1228       len = strlen(eqv);
1229
1230       /* Get rid of "000000/ in rooted filespecs */
1231       if (len > 7) {
1232         char * zeros;
1233         zeros = strstr(eqv, "/000000/");
1234         if (zeros != NULL) {
1235           int mlen;
1236           mlen = len - (zeros - eqv) - 7;
1237           memmove(zeros, &zeros[7], mlen);
1238           len = len - 7;
1239           eqv[len] = '\0';
1240         }
1241       }
1242       return eqv;
1243     }
1244     else {
1245       /* Impose security constraints only if tainting */
1246       if (sys) {
1247         /* Impose security constraints only if tainting */
1248         secure = PL_curinterp ? PL_tainting : will_taint;
1249         saverr = errno;  savvmserr = vaxc$errno;
1250       }
1251       else {
1252         secure = 0;
1253       }
1254
1255       flags =
1256 #ifdef SECURE_INTERNAL_GETENV
1257               secure ? PERL__TRNENV_SECURE : 0
1258 #else
1259               0
1260 #endif
1261       ;
1262
1263       /* For the getenv interface we combine all the equivalence names
1264        * of a search list logical into one value to acquire a maximum
1265        * value length of 255*128 (assuming %ENV is using logicals).
1266        */
1267       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1268
1269       /* If the name contains a semicolon-delimited index, parse it
1270        * off and make sure we only retrieve the equivalence name for
1271        * that index.  */
1272       if ((cp2 = strchr(lnm,';')) != NULL) {
1273         strcpy(uplnm,lnm);
1274         uplnm[cp2-lnm] = '\0';
1275         idx = strtoul(cp2+1,NULL,0);
1276         lnm = uplnm;
1277         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1278       }
1279
1280       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1281
1282       /* Discard NOLOGNAM on internal calls since we're often looking
1283        * for an optional name, and this "error" often shows up as the
1284        * (bogus) exit status for a die() call later on.  */
1285       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1286       return success ? eqv : NULL;
1287     }
1288
1289 }  /* end of my_getenv() */
1290 /*}}}*/
1291
1292
1293 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1294 char *
1295 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1296 {
1297     const char *cp1;
1298     char *buf, *cp2;
1299     unsigned long idx = 0;
1300     int midx, flags;
1301     static char *__my_getenv_len_eqv = NULL;
1302     int secure, saverr, savvmserr;
1303     SV *tmpsv;
1304
1305     midx = my_maxidx(lnm) + 1;
1306
1307     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1308       /* Set up a temporary buffer for the return value; Perl will
1309        * clean it up at the next statement transition */
1310       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1311       if (!tmpsv) return NULL;
1312       buf = SvPVX(tmpsv);
1313     }
1314     else {
1315       /* Assume no interpreter ==> single thread */
1316       if (__my_getenv_len_eqv != NULL) {
1317         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1318       }
1319       else {
1320         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1321       }
1322       buf = __my_getenv_len_eqv;
1323     }
1324
1325     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1326     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1327     char * zeros;
1328
1329       getcwd(buf,LNM$C_NAMLENGTH);
1330       *len = strlen(buf);
1331
1332       /* Get rid of "000000/ in rooted filespecs */
1333       if (*len > 7) {
1334       zeros = strstr(buf, "/000000/");
1335       if (zeros != NULL) {
1336         int mlen;
1337         mlen = *len - (zeros - buf) - 7;
1338         memmove(zeros, &zeros[7], mlen);
1339         *len = *len - 7;
1340         buf[*len] = '\0';
1341         }
1342       }
1343       return buf;
1344     }
1345     else {
1346       if (sys) {
1347         /* Impose security constraints only if tainting */
1348         secure = PL_curinterp ? PL_tainting : will_taint;
1349         saverr = errno;  savvmserr = vaxc$errno;
1350       }
1351       else {
1352         secure = 0;
1353       }
1354
1355       flags =
1356 #ifdef SECURE_INTERNAL_GETENV
1357               secure ? PERL__TRNENV_SECURE : 0
1358 #else
1359               0
1360 #endif
1361       ;
1362
1363       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1364
1365       if ((cp2 = strchr(lnm,';')) != NULL) {
1366         strcpy(buf,lnm);
1367         buf[cp2-lnm] = '\0';
1368         idx = strtoul(cp2+1,NULL,0);
1369         lnm = buf;
1370         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1371       }
1372
1373       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1374
1375       /* Get rid of "000000/ in rooted filespecs */
1376       if (*len > 7) {
1377       char * zeros;
1378         zeros = strstr(buf, "/000000/");
1379         if (zeros != NULL) {
1380           int mlen;
1381           mlen = *len - (zeros - buf) - 7;
1382           memmove(zeros, &zeros[7], mlen);
1383           *len = *len - 7;
1384           buf[*len] = '\0';
1385         }
1386       }
1387
1388       /* Discard NOLOGNAM on internal calls since we're often looking
1389        * for an optional name, and this "error" often shows up as the
1390        * (bogus) exit status for a die() call later on.  */
1391       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1392       return *len ? buf : NULL;
1393     }
1394
1395 }  /* end of my_getenv_len() */
1396 /*}}}*/
1397
1398 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
1399
1400 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1401
1402 /*{{{ void prime_env_iter() */
1403 void
1404 prime_env_iter(void)
1405 /* Fill the %ENV associative array with all logical names we can
1406  * find, in preparation for iterating over it.
1407  */
1408 {
1409   static int primed = 0;
1410   HV *seenhv = NULL, *envhv;
1411   SV *sv = NULL;
1412   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1413   unsigned short int chan;
1414 #ifndef CLI$M_TRUSTED
1415 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1416 #endif
1417   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1418   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1419   long int i;
1420   bool have_sym = FALSE, have_lnm = FALSE;
1421   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1422   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1423   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1424   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1425   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1426 #if defined(PERL_IMPLICIT_CONTEXT)
1427   pTHX;
1428 #endif
1429 #if defined(USE_ITHREADS)
1430   static perl_mutex primenv_mutex;
1431   MUTEX_INIT(&primenv_mutex);
1432 #endif
1433
1434 #if defined(PERL_IMPLICIT_CONTEXT)
1435     /* We jump through these hoops because we can be called at */
1436     /* platform-specific initialization time, which is before anything is */
1437     /* set up--we can't even do a plain dTHX since that relies on the */
1438     /* interpreter structure to be initialized */
1439     if (PL_curinterp) {
1440       aTHX = PERL_GET_INTERP;
1441     } else {
1442       /* we never get here because the NULL pointer will cause the */
1443       /* several of the routines called by this routine to access violate */
1444
1445       /* This routine is only called by hv.c/hv_iterinit which has a */
1446       /* context, so the real fix may be to pass it through instead of */
1447       /* the hoops above */
1448       aTHX = NULL;
1449     }
1450 #endif
1451
1452   if (primed || !PL_envgv) return;
1453   MUTEX_LOCK(&primenv_mutex);
1454   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1455   envhv = GvHVn(PL_envgv);
1456   /* Perform a dummy fetch as an lval to insure that the hash table is
1457    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1458   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1459
1460   for (i = 0; env_tables[i]; i++) {
1461      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1462          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1463      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1464   }
1465   if (have_sym || have_lnm) {
1466     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1467     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1468     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1469     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1470   }
1471
1472   for (i--; i >= 0; i--) {
1473     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1474       char *start;
1475       int j;
1476       for (j = 0; environ[j]; j++) {
1477         if (!(start = strchr(environ[j],'='))) {
1478           if (ckWARN(WARN_INTERNAL))
1479             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1480         }
1481         else {
1482           start++;
1483           sv = newSVpv(start,0);
1484           SvTAINTED_on(sv);
1485           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1486         }
1487       }
1488       continue;
1489     }
1490     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1491              !str$case_blind_compare(&tmpdsc,&clisym)) {
1492       strcpy(cmd,"Show Symbol/Global *");
1493       cmddsc.dsc$w_length = 20;
1494       if (env_tables[i]->dsc$w_length == 12 &&
1495           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1496           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1497       flags = defflags | CLI$M_NOLOGNAM;
1498     }
1499     else {
1500       strcpy(cmd,"Show Logical *");
1501       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1502         strcat(cmd," /Table=");
1503         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1504         cmddsc.dsc$w_length = strlen(cmd);
1505       }
1506       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1507       flags = defflags | CLI$M_NOCLISYM;
1508     }
1509
1510     /* Create a new subprocess to execute each command, to exclude the
1511      * remote possibility that someone could subvert a mbx or file used
1512      * to write multiple commands to a single subprocess.
1513      */
1514     do {
1515       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1516                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1517       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1518       defflags &= ~CLI$M_TRUSTED;
1519     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1520     _ckvmssts(retsts);
1521     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1522     if (seenhv) SvREFCNT_dec(seenhv);
1523     seenhv = newHV();
1524     while (1) {
1525       char *cp1, *cp2, *key;
1526       unsigned long int sts, iosb[2], retlen, keylen;
1527       register U32 hash;
1528
1529       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1530       if (sts & 1) sts = iosb[0] & 0xffff;
1531       if (sts == SS$_ENDOFFILE) {
1532         int wakect = 0;
1533         while (substs == 0) { sys$hiber(); wakect++;}
1534         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1535         _ckvmssts(substs);
1536         break;
1537       }
1538       _ckvmssts(sts);
1539       retlen = iosb[0] >> 16;
1540       if (!retlen) continue;  /* blank line */
1541       buf[retlen] = '\0';
1542       if (iosb[1] != subpid) {
1543         if (iosb[1]) {
1544           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1545         }
1546         continue;
1547       }
1548       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1549         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1550
1551       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1552       if (*cp1 == '(' || /* Logical name table name */
1553           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1554       if (*cp1 == '"') cp1++;
1555       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1556       key = cp1;  keylen = cp2 - cp1;
1557       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1558       while (*cp2 && *cp2 != '=') cp2++;
1559       while (*cp2 && *cp2 == '=') cp2++;
1560       while (*cp2 && *cp2 == ' ') cp2++;
1561       if (*cp2 == '"') {  /* String translation; may embed "" */
1562         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1563         cp2++;  cp1--; /* Skip "" surrounding translation */
1564       }
1565       else {  /* Numeric translation */
1566         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1567         cp1--;  /* stop on last non-space char */
1568       }
1569       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1570         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1571         continue;
1572       }
1573       PERL_HASH(hash,key,keylen);
1574
1575       if (cp1 == cp2 && *cp2 == '.') {
1576         /* A single dot usually means an unprintable character, such as a null
1577          * to indicate a zero-length value.  Get the actual value to make sure.
1578          */
1579         char lnm[LNM$C_NAMLENGTH+1];
1580         char eqv[MAX_DCL_SYMBOL+1];
1581         int trnlen;
1582         strncpy(lnm, key, keylen);
1583         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1584         sv = newSVpvn(eqv, strlen(eqv));
1585       }
1586       else {
1587         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1588       }
1589
1590       SvTAINTED_on(sv);
1591       hv_store(envhv,key,keylen,sv,hash);
1592       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1593     }
1594     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1595       /* get the PPFs for this process, not the subprocess */
1596       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1597       char eqv[LNM$C_NAMLENGTH+1];
1598       int trnlen, i;
1599       for (i = 0; ppfs[i]; i++) {
1600         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1601         sv = newSVpv(eqv,trnlen);
1602         SvTAINTED_on(sv);
1603         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1604       }
1605     }
1606   }
1607   primed = 1;
1608   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1609   if (buf) Safefree(buf);
1610   if (seenhv) SvREFCNT_dec(seenhv);
1611   MUTEX_UNLOCK(&primenv_mutex);
1612   return;
1613
1614 }  /* end of prime_env_iter */
1615 /*}}}*/
1616
1617
1618 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1619 /* Define or delete an element in the same "environment" as
1620  * vmstrnenv().  If an element is to be deleted, it's removed from
1621  * the first place it's found.  If it's to be set, it's set in the
1622  * place designated by the first element of the table vector.
1623  * Like setenv() returns 0 for success, non-zero on error.
1624  */
1625 int
1626 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1627 {
1628     const char *cp1;
1629     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1630     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1631     int nseg = 0, j;
1632     unsigned long int retsts, usermode = PSL$C_USER;
1633     struct itmlst_3 *ile, *ilist;
1634     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1635                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1636                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1637     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1638     $DESCRIPTOR(local,"_LOCAL");
1639
1640     if (!lnm) {
1641         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1642         return SS$_IVLOGNAM;
1643     }
1644
1645     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1646       *cp2 = _toupper(*cp1);
1647       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1648         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1649         return SS$_IVLOGNAM;
1650       }
1651     }
1652     lnmdsc.dsc$w_length = cp1 - lnm;
1653     if (!tabvec || !*tabvec) tabvec = env_tables;
1654
1655     if (!eqv) {  /* we're deleting n element */
1656       for (curtab = 0; tabvec[curtab]; curtab++) {
1657         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1658         int i;
1659           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1660             if ((cp1 = strchr(environ[i],'=')) &&
1661                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1662                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1663 #ifdef HAS_SETENV
1664               return setenv(lnm,"",1) ? vaxc$errno : 0;
1665             }
1666           }
1667           ivenv = 1; retsts = SS$_NOLOGNAM;
1668 #else
1669               if (ckWARN(WARN_INTERNAL))
1670                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1671               ivenv = 1; retsts = SS$_NOSUCHPGM;
1672               break;
1673             }
1674           }
1675 #endif
1676         }
1677         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1678                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1679           unsigned int symtype;
1680           if (tabvec[curtab]->dsc$w_length == 12 &&
1681               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1682               !str$case_blind_compare(&tmpdsc,&local))
1683             symtype = LIB$K_CLI_LOCAL_SYM;
1684           else symtype = LIB$K_CLI_GLOBAL_SYM;
1685           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1686           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1687           if (retsts == LIB$_NOSUCHSYM) continue;
1688           break;
1689         }
1690         else if (!ivlnm) {
1691           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1692           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1693           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1694           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1695           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1696         }
1697       }
1698     }
1699     else {  /* we're defining a value */
1700       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1701 #ifdef HAS_SETENV
1702         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1703 #else
1704         if (ckWARN(WARN_INTERNAL))
1705           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1706         retsts = SS$_NOSUCHPGM;
1707 #endif
1708       }
1709       else {
1710         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1711         eqvdsc.dsc$w_length  = strlen(eqv);
1712         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1713             !str$case_blind_compare(&tmpdsc,&clisym)) {
1714           unsigned int symtype;
1715           if (tabvec[0]->dsc$w_length == 12 &&
1716               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1717                !str$case_blind_compare(&tmpdsc,&local))
1718             symtype = LIB$K_CLI_LOCAL_SYM;
1719           else symtype = LIB$K_CLI_GLOBAL_SYM;
1720           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1721         }
1722         else {
1723           if (!*eqv) eqvdsc.dsc$w_length = 1;
1724           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1725
1726             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1727             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1728               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1729                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1730               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1731               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1732             }
1733
1734             Newx(ilist,nseg+1,struct itmlst_3);
1735             ile = ilist;
1736             if (!ile) {
1737               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1738               return SS$_INSFMEM;
1739             }
1740             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1741
1742             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1743               ile->itmcode = LNM$_STRING;
1744               ile->bufadr = c;
1745               if ((j+1) == nseg) {
1746                 ile->buflen = strlen(c);
1747                 /* in case we are truncating one that's too long */
1748                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1749               }
1750               else {
1751                 ile->buflen = LNM$C_NAMLENGTH;
1752               }
1753             }
1754
1755             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1756             Safefree (ilist);
1757           }
1758           else {
1759             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1760           }
1761         }
1762       }
1763     }
1764     if (!(retsts & 1)) {
1765       switch (retsts) {
1766         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1767         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1768           set_errno(EVMSERR); break;
1769         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1770         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1771           set_errno(EINVAL); break;
1772         case SS$_NOPRIV:
1773           set_errno(EACCES); break;
1774         default:
1775           _ckvmssts(retsts);
1776           set_errno(EVMSERR);
1777        }
1778        set_vaxc_errno(retsts);
1779        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1780     }
1781     else {
1782       /* We reset error values on success because Perl does an hv_fetch()
1783        * before each hv_store(), and if the thing we're setting didn't
1784        * previously exist, we've got a leftover error message.  (Of course,
1785        * this fails in the face of
1786        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1787        * in that the error reported in $! isn't spurious,
1788        * but it's right more often than not.)
1789        */
1790       set_errno(0); set_vaxc_errno(retsts);
1791       return 0;
1792     }
1793
1794 }  /* end of vmssetenv() */
1795 /*}}}*/
1796
1797 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1798 /* This has to be a function since there's a prototype for it in proto.h */
1799 void
1800 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1801 {
1802     if (lnm && *lnm) {
1803       int len = strlen(lnm);
1804       if  (len == 7) {
1805         char uplnm[8];
1806         int i;
1807         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1808         if (!strcmp(uplnm,"DEFAULT")) {
1809           if (eqv && *eqv) my_chdir(eqv);
1810           return;
1811         }
1812     }
1813 #ifndef RTL_USES_UTC
1814     if (len == 6 || len == 2) {
1815       char uplnm[7];
1816       int i;
1817       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1818       uplnm[len] = '\0';
1819       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1820       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1821     }
1822 #endif
1823   }
1824   (void) vmssetenv(lnm,eqv,NULL);
1825 }
1826 /*}}}*/
1827
1828 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1829 /*  vmssetuserlnm
1830  *  sets a user-mode logical in the process logical name table
1831  *  used for redirection of sys$error
1832  *
1833  *  Fix-me: The pTHX is not needed for this routine, however doio.c
1834  *          is calling it with one instead of using a macro.
1835  *          A macro needs to be added to vmsish.h and doio.c updated to use it.
1836  *
1837  */
1838 void
1839 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1840 {
1841     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1842     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1843     unsigned long int iss, attr = LNM$M_CONFINE;
1844     unsigned char acmode = PSL$C_USER;
1845     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1846                                  {0, 0, 0, 0}};
1847     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1848     d_name.dsc$w_length = strlen(name);
1849
1850     lnmlst[0].buflen = strlen(eqv);
1851     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1852
1853     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1854     if (!(iss&1)) lib$signal(iss);
1855 }
1856 /*}}}*/
1857
1858
1859 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1860 /* my_crypt - VMS password hashing
1861  * my_crypt() provides an interface compatible with the Unix crypt()
1862  * C library function, and uses sys$hash_password() to perform VMS
1863  * password hashing.  The quadword hashed password value is returned
1864  * as a NUL-terminated 8 character string.  my_crypt() does not change
1865  * the case of its string arguments; in order to match the behavior
1866  * of LOGINOUT et al., alphabetic characters in both arguments must
1867  *  be upcased by the caller.
1868  *
1869  * - fix me to call ACM services when available
1870  */
1871 char *
1872 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1873 {
1874 #   ifndef UAI$C_PREFERRED_ALGORITHM
1875 #     define UAI$C_PREFERRED_ALGORITHM 127
1876 #   endif
1877     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1878     unsigned short int salt = 0;
1879     unsigned long int sts;
1880     struct const_dsc {
1881         unsigned short int dsc$w_length;
1882         unsigned char      dsc$b_type;
1883         unsigned char      dsc$b_class;
1884         const char *       dsc$a_pointer;
1885     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1886        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1887     struct itmlst_3 uailst[3] = {
1888         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1889         { sizeof salt, UAI$_SALT,    &salt, 0},
1890         { 0,           0,            NULL,  NULL}};
1891     static char hash[9];
1892
1893     usrdsc.dsc$w_length = strlen(usrname);
1894     usrdsc.dsc$a_pointer = usrname;
1895     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1896       switch (sts) {
1897         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1898           set_errno(EACCES);
1899           break;
1900         case RMS$_RNF:
1901           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1902           break;
1903         default:
1904           set_errno(EVMSERR);
1905       }
1906       set_vaxc_errno(sts);
1907       if (sts != RMS$_RNF) return NULL;
1908     }
1909
1910     txtdsc.dsc$w_length = strlen(textpasswd);
1911     txtdsc.dsc$a_pointer = textpasswd;
1912     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1913       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1914     }
1915
1916     return (char *) hash;
1917
1918 }  /* end of my_crypt() */
1919 /*}}}*/
1920
1921
1922 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1923 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1924 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1925
1926 /* fixup barenames that are directories for internal use.
1927  * There have been problems with the consistent handling of UNIX
1928  * style directory names when routines are presented with a name that
1929  * has no directory delimitors at all.  So this routine will eventually
1930  * fix the issue.
1931  */
1932 static char * fixup_bare_dirnames(const char * name)
1933 {
1934   if (decc_disable_to_vms_logname_translation) {
1935 /* fix me */
1936   }
1937   return NULL;
1938 }
1939
1940 /* 8.3, remove() is now broken on symbolic links */
1941 static int rms_erase(const char * vmsname);
1942
1943
1944 /* mp_do_kill_file
1945  * A little hack to get around a bug in some implemenation of remove()
1946  * that do not know how to delete a directory
1947  *
1948  * Delete any file to which user has control access, regardless of whether
1949  * delete access is explicitly allowed.
1950  * Limitations: User must have write access to parent directory.
1951  *              Does not block signals or ASTs; if interrupted in midstream
1952  *              may leave file with an altered ACL.
1953  * HANDLE WITH CARE!
1954  */
1955 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1956 static int
1957 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1958 {
1959     char *vmsname;
1960     char *rslt;
1961     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1962     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1963     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1964     struct myacedef {
1965       unsigned char myace$b_length;
1966       unsigned char myace$b_type;
1967       unsigned short int myace$w_flags;
1968       unsigned long int myace$l_access;
1969       unsigned long int myace$l_ident;
1970     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1971                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1972       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1973      struct itmlst_3
1974        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1975                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1976        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1977        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1978        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1979        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1980
1981     /* Expand the input spec using RMS, since the CRTL remove() and
1982      * system services won't do this by themselves, so we may miss
1983      * a file "hiding" behind a logical name or search list. */
1984     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1985     if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1986
1987     rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
1988     if (rslt == NULL) {
1989         PerlMem_free(vmsname);
1990         return -1;
1991       }
1992
1993     /* Erase the file */
1994     rmsts = rms_erase(vmsname);
1995
1996     /* Did it succeed */
1997     if ($VMS_STATUS_SUCCESS(rmsts)) {
1998         PerlMem_free(vmsname);
1999         return 0;
2000       }
2001
2002     /* If not, can changing protections help? */
2003     if (rmsts != RMS$_PRV) {
2004       set_vaxc_errno(rmsts);
2005       PerlMem_free(vmsname);
2006       return -1;
2007     }
2008
2009     /* No, so we get our own UIC to use as a rights identifier,
2010      * and the insert an ACE at the head of the ACL which allows us
2011      * to delete the file.
2012      */
2013     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
2014     fildsc.dsc$w_length = strlen(vmsname);
2015     fildsc.dsc$a_pointer = vmsname;
2016     cxt = 0;
2017     newace.myace$l_ident = oldace.myace$l_ident;
2018     rmsts = -1;
2019     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
2020       switch (aclsts) {
2021         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
2022           set_errno(ENOENT); break;
2023         case RMS$_DIR:
2024           set_errno(ENOTDIR); break;
2025         case RMS$_DEV:
2026           set_errno(ENODEV); break;
2027         case RMS$_SYN: case SS$_INVFILFOROP:
2028           set_errno(EINVAL); break;
2029         case RMS$_PRV:
2030           set_errno(EACCES); break;
2031         default:
2032           _ckvmssts_noperl(aclsts);
2033       }
2034       set_vaxc_errno(aclsts);
2035       PerlMem_free(vmsname);
2036       return -1;
2037     }
2038     /* Grab any existing ACEs with this identifier in case we fail */
2039     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
2040     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
2041                     || fndsts == SS$_NOMOREACE ) {
2042       /* Add the new ACE . . . */
2043       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
2044         goto yourroom;
2045
2046       rmsts = rms_erase(vmsname);
2047       if ($VMS_STATUS_SUCCESS(rmsts)) {
2048         rmsts = 0;
2049         }
2050         else {
2051         rmsts = -1;
2052         /* We blew it - dir with files in it, no write priv for
2053          * parent directory, etc.  Put things back the way they were. */
2054         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
2055           goto yourroom;
2056         if (fndsts & 1) {
2057           addlst[0].bufadr = &oldace;
2058           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2059             goto yourroom;
2060         }
2061       }
2062     }
2063
2064     yourroom:
2065     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2066     /* We just deleted it, so of course it's not there.  Some versions of
2067      * VMS seem to return success on the unlock operation anyhow (after all
2068      * the unlock is successful), but others don't.
2069      */
2070     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2071     if (aclsts & 1) aclsts = fndsts;
2072     if (!(aclsts & 1)) {
2073       set_errno(EVMSERR);
2074       set_vaxc_errno(aclsts);
2075     }
2076
2077     PerlMem_free(vmsname);
2078     return rmsts;
2079
2080 }  /* end of kill_file() */
2081 /*}}}*/
2082
2083
2084 /*{{{int do_rmdir(char *name)*/
2085 int
2086 Perl_do_rmdir(pTHX_ const char *name)
2087 {
2088     char * dirfile;
2089     int retval;
2090     Stat_t st;
2091
2092     /* lstat returns a VMS fileified specification of the name */
2093     /* that is looked up, and also lets verifies that this is a directory */
2094
2095     retval = flex_lstat(name, &st);
2096     if (retval != 0) {
2097         char * ret_spec;
2098
2099         /* Due to a historical feature, flex_stat/lstat can not see some */
2100         /* Unix format file names that the rest of the CRTL can see */
2101         /* Fixing that feature will cause some perl tests to fail */
2102         /* So try this one more time. */
2103
2104         retval = lstat(name, &st.crtl_stat);
2105         if (retval != 0)
2106             return -1;
2107
2108         /* force it to a file spec for the kill file to work. */
2109         ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
2110         if (ret_spec == NULL) {
2111             errno = EIO;
2112             return -1;
2113         }
2114     }
2115
2116     if (!S_ISDIR(st.st_mode)) {
2117         errno = ENOTDIR;
2118         retval = -1;
2119     }
2120     else {
2121         dirfile = st.st_devnam;
2122
2123         /* It may be possible for flex_stat to find a file and vmsify() to */
2124         /* fail with ODS-2 specifications.  mp_do_kill_file can not deal */
2125         /* with that case, so fail it */
2126         if (dirfile[0] == 0) {
2127             errno = EIO;
2128             return -1;
2129         }
2130
2131         retval = mp_do_kill_file(aTHX_ dirfile, 1);
2132     }
2133
2134     return retval;
2135
2136 }  /* end of do_rmdir */
2137 /*}}}*/
2138
2139 /* kill_file
2140  * Delete any file to which user has control access, regardless of whether
2141  * delete access is explicitly allowed.
2142  * Limitations: User must have write access to parent directory.
2143  *              Does not block signals or ASTs; if interrupted in midstream
2144  *              may leave file with an altered ACL.
2145  * HANDLE WITH CARE!
2146  */
2147 /*{{{int kill_file(char *name)*/
2148 int
2149 Perl_kill_file(pTHX_ const char *name)
2150 {
2151     char * vmsfile;
2152     Stat_t st;
2153     int rmsts;
2154
2155     /* Convert the filename to VMS format and see if it is a directory */
2156     /* flex_lstat returns a vmsified file specification */
2157     rmsts = flex_lstat(name, &st);
2158     if (rmsts != 0) {
2159
2160         /* Due to a historical feature, flex_stat/lstat can not see some */
2161         /* Unix format file names that the rest of the CRTL can see when */
2162         /* ODS-2 file specifications are in use. */
2163         /* Fixing that feature will cause some perl tests to fail */
2164         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2165         st.st_mode = 0;
2166         vmsfile = (char *) name; /* cast ok */
2167
2168     } else {
2169         vmsfile = st.st_devnam;
2170         if (vmsfile[0] == 0) {
2171             /* It may be possible for flex_stat to find a file and vmsify() */
2172             /* to fail with ODS-2 specifications.  mp_do_kill_file can not */
2173             /* deal with that case, so fail it */
2174             errno = EIO;
2175             return -1;
2176         }
2177     }
2178
2179     /* Remove() is allowed to delete directories, according to the X/Open
2180      * specifications.
2181      * This may need special handling to work with the ACL hacks.
2182      */
2183     if (S_ISDIR(st.st_mode)) {
2184         rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
2185         return rmsts;
2186     }
2187
2188     rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2189
2190     /* Need to delete all versions ? */
2191     if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
2192         int i = 0;
2193
2194         /* Just use lstat() here as do not need st_dev */
2195         /* and we know that the file is in VMS format or that */
2196         /* because of a historical bug, flex_stat can not see the file */
2197         while (lstat(vmsfile, (stat_t *)&st) == 0) {
2198             rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2199             if (rmsts != 0)
2200                 break;
2201             i++;
2202
2203             /* Make sure that we do not loop forever */
2204             if (i > 32767) {
2205                 errno = EIO;
2206                 rmsts = -1;
2207                 break;
2208             }
2209         }
2210     }
2211
2212     return rmsts;
2213
2214 }  /* end of kill_file() */
2215 /*}}}*/
2216
2217
2218 /*{{{int my_mkdir(char *,Mode_t)*/
2219 int
2220 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2221 {
2222   STRLEN dirlen = strlen(dir);
2223
2224   /* zero length string sometimes gives ACCVIO */
2225   if (dirlen == 0) return -1;
2226
2227   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2228    * null file name/type.  However, it's commonplace under Unix,
2229    * so we'll allow it for a gain in portability.
2230    */
2231   if (dir[dirlen-1] == '/') {
2232     char *newdir = savepvn(dir,dirlen-1);
2233     int ret = mkdir(newdir,mode);
2234     Safefree(newdir);
2235     return ret;
2236   }
2237   else return mkdir(dir,mode);
2238 }  /* end of my_mkdir */
2239 /*}}}*/
2240
2241 /*{{{int my_chdir(char *)*/
2242 int
2243 Perl_my_chdir(pTHX_ const char *dir)
2244 {
2245   STRLEN dirlen = strlen(dir);
2246
2247   /* zero length string sometimes gives ACCVIO */
2248   if (dirlen == 0) return -1;
2249   const char *dir1;
2250
2251   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2252    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2253    * so that existing scripts do not need to be changed.
2254    */
2255   dir1 = dir;
2256   while ((dirlen > 0) && (*dir1 == ' ')) {
2257     dir1++;
2258     dirlen--;
2259   }
2260
2261   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2262    * that implies
2263    * null file name/type.  However, it's commonplace under Unix,
2264    * so we'll allow it for a gain in portability.
2265    *
2266    *  '/' is valid when SYS$POSIX_ROOT or POSIX compliant pathnames are active.
2267    */
2268   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2269       char *newdir;
2270       int ret;
2271       newdir = PerlMem_malloc(dirlen);
2272       if (newdir ==NULL)
2273           _ckvmssts_noperl(SS$_INSFMEM);
2274       strncpy(newdir, dir1, dirlen-1);
2275       newdir[dirlen-1] = '\0';
2276       ret = chdir(newdir);
2277       PerlMem_free(newdir);
2278       return ret;
2279   }
2280   else return chdir(dir1);
2281 }  /* end of my_chdir */
2282 /*}}}*/
2283
2284
2285 /*{{{int my_chmod(char *, mode_t)*/
2286 int
2287 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2288 {
2289   Stat_t st;
2290   int ret = -1;
2291   char * changefile;
2292   STRLEN speclen = strlen(file_spec);
2293
2294   /* zero length string sometimes gives ACCVIO */
2295   if (speclen == 0) return -1;
2296
2297   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2298    * that implies null file name/type.  However, it's commonplace under Unix,
2299    * so we'll allow it for a gain in portability.
2300    *
2301    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2302    * in VMS file.dir notation.
2303    */
2304   changefile = (char *) file_spec; /* cast ok */
2305   ret = flex_lstat(file_spec, &st);
2306   if (ret != 0) {
2307
2308         /* Due to a historical feature, flex_stat/lstat can not see some */
2309         /* Unix format file names that the rest of the CRTL can see when */
2310         /* ODS-2 file specifications are in use. */
2311         /* Fixing that feature will cause some perl tests to fail */
2312         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2313         st.st_mode = 0;
2314
2315   } else {
2316       /* It may be possible to get here with nothing in st_devname */
2317       /* chmod still may work though */
2318       if (st.st_devnam[0] != 0) {
2319           changefile = st.st_devnam;
2320       }
2321   }
2322   ret = chmod(changefile, mode);
2323   return ret;
2324 }  /* end of my_chmod */
2325 /*}}}*/
2326
2327
2328 /*{{{FILE *my_tmpfile()*/
2329 FILE *
2330 my_tmpfile(void)
2331 {
2332   FILE *fp;
2333   char *cp;
2334
2335   if ((fp = tmpfile())) return fp;
2336
2337   cp = PerlMem_malloc(L_tmpnam+24);
2338   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2339
2340   if (decc_filename_unix_only == 0)
2341     strcpy(cp,"Sys$Scratch:");
2342   else
2343     strcpy(cp,"/tmp/");
2344   tmpnam(cp+strlen(cp));
2345   strcat(cp,".Perltmp");
2346   fp = fopen(cp,"w+","fop=dlt");
2347   PerlMem_free(cp);
2348   return fp;
2349 }
2350 /*}}}*/
2351
2352
2353 #ifndef HOMEGROWN_POSIX_SIGNALS
2354 /*
2355  * The C RTL's sigaction fails to check for invalid signal numbers so we
2356  * help it out a bit.  The docs are correct, but the actual routine doesn't
2357  * do what the docs say it will.
2358  */
2359 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2360 int
2361 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2362                    struct sigaction* oact)
2363 {
2364   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2365         SETERRNO(EINVAL, SS$_INVARG);
2366         return -1;
2367   }
2368   return sigaction(sig, act, oact);
2369 }
2370 /*}}}*/
2371 #endif
2372
2373 #ifdef KILL_BY_SIGPRC
2374 #include <errnodef.h>
2375
2376 /* We implement our own kill() using the undocumented system service
2377    sys$sigprc for one of two reasons:
2378
2379    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2380    target process to do a sys$exit, which usually can't be handled
2381    gracefully...certainly not by Perl and the %SIG{} mechanism.
2382
2383    2.) If the kill() in the CRTL can't be called from a signal
2384    handler without disappearing into the ether, i.e., the signal
2385    it purportedly sends is never trapped. Still true as of VMS 7.3.
2386
2387    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2388    in the target process rather than calling sys$exit.
2389
2390    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2391    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2392    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2393    with condition codes C$_SIG0+nsig*8, catching the exception on the
2394    target process and resignaling with appropriate arguments.
2395
2396    But we don't have that VMS 7.0+ exception handler, so if you
2397    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2398
2399    Also note that SIGTERM is listed in the docs as being "unimplemented",
2400    yet always seems to be signaled with a VMS condition code of 4 (and
2401    correctly handled for that code).  So we hardwire it in.
2402
2403    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2404    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2405    than signalling with an unrecognized (and unhandled by CRTL) code.
2406 */
2407
2408 #define _MY_SIG_MAX 28
2409
2410 static unsigned int
2411 Perl_sig_to_vmscondition_int(int sig)
2412 {
2413     static unsigned int sig_code[_MY_SIG_MAX+1] =
2414     {
2415         0,                  /*  0 ZERO     */
2416         SS$_HANGUP,         /*  1 SIGHUP   */
2417         SS$_CONTROLC,       /*  2 SIGINT   */
2418         SS$_CONTROLY,       /*  3 SIGQUIT  */
2419         SS$_RADRMOD,        /*  4 SIGILL   */
2420         SS$_BREAK,          /*  5 SIGTRAP  */
2421         SS$_OPCCUS,         /*  6 SIGABRT  */
2422         SS$_COMPAT,         /*  7 SIGEMT   */
2423 #ifdef __VAX
2424         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2425 #else
2426         SS$_HPARITH,        /*  8 SIGFPE AXP */
2427 #endif
2428         SS$_ABORT,          /*  9 SIGKILL  */
2429         SS$_ACCVIO,         /* 10 SIGBUS   */
2430         SS$_ACCVIO,         /* 11 SIGSEGV  */
2431         SS$_BADPARAM,       /* 12 SIGSYS   */
2432         SS$_NOMBX,          /* 13 SIGPIPE  */
2433         SS$_ASTFLT,         /* 14 SIGALRM  */
2434         4,                  /* 15 SIGTERM  */
2435         0,                  /* 16 SIGUSR1  */
2436         0,                  /* 17 SIGUSR2  */
2437         0,                  /* 18 */
2438         0,                  /* 19 */
2439         0,                  /* 20 SIGCHLD  */
2440         0,                  /* 21 SIGCONT  */
2441         0,                  /* 22 SIGSTOP  */
2442         0,                  /* 23 SIGTSTP  */
2443         0,                  /* 24 SIGTTIN  */
2444         0,                  /* 25 SIGTTOU  */
2445         0,                  /* 26 */
2446         0,                  /* 27 */
2447         0                   /* 28 SIGWINCH  */
2448     };
2449
2450 #if __VMS_VER >= 60200000
2451     static int initted = 0;
2452     if (!initted) {
2453         initted = 1;
2454         sig_code[16] = C$_SIGUSR1;
2455         sig_code[17] = C$_SIGUSR2;
2456 #if __CRTL_VER >= 70000000
2457         sig_code[20] = C$_SIGCHLD;
2458 #endif
2459 #if __CRTL_VER >= 70300000
2460         sig_code[28] = C$_SIGWINCH;
2461 #endif
2462     }
2463 #endif
2464
2465     if (sig < _SIG_MIN) return 0;
2466     if (sig > _MY_SIG_MAX) return 0;
2467     return sig_code[sig];
2468 }
2469
2470 unsigned int
2471 Perl_sig_to_vmscondition(int sig)
2472 {
2473 #ifdef SS$_DEBUG
2474     if (vms_debug_on_exception != 0)
2475         lib$signal(SS$_DEBUG);
2476 #endif
2477     return Perl_sig_to_vmscondition_int(sig);
2478 }
2479
2480
2481 int
2482 Perl_my_kill(int pid, int sig)
2483 {
2484     dTHX;
2485     int iss;
2486     unsigned int code;
2487     int sys$sigprc(unsigned int *pidadr,
2488                      struct dsc$descriptor_s *prcname,
2489                      unsigned int code);
2490
2491      /* sig 0 means validate the PID */
2492     /*------------------------------*/
2493     if (sig == 0) {
2494         const unsigned long int jpicode = JPI$_PID;
2495         pid_t ret_pid;
2496         int status;
2497         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2498         if ($VMS_STATUS_SUCCESS(status))
2499            return 0;
2500         switch (status) {
2501         case SS$_NOSUCHNODE:
2502         case SS$_UNREACHABLE:
2503         case SS$_NONEXPR:
2504            errno = ESRCH;
2505            break;
2506         case SS$_NOPRIV:
2507            errno = EPERM;
2508            break;
2509         default:
2510            errno = EVMSERR;
2511         }
2512         vaxc$errno=status;
2513         return -1;
2514     }
2515
2516     code = Perl_sig_to_vmscondition_int(sig);
2517
2518     if (!code) {
2519         SETERRNO(EINVAL, SS$_BADPARAM);
2520         return -1;
2521     }
2522
2523     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2524      * signals are to be sent to multiple processes.
2525      *  pid = 0 - all processes in group except ones that the system exempts
2526      *  pid = -1 - all processes except ones that the system exempts
2527      *  pid = -n - all processes in group (abs(n)) except ...
2528      * For now, just report as not supported.
2529      */
2530
2531     if (pid <= 0) {
2532         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2533         return -1;
2534     }
2535
2536     iss = sys$sigprc((unsigned int *)&pid,0,code);
2537     if (iss&1) return 0;
2538
2539     switch (iss) {
2540       case SS$_NOPRIV:
2541         set_errno(EPERM);  break;
2542       case SS$_NONEXPR:
2543       case SS$_NOSUCHNODE:
2544       case SS$_UNREACHABLE:
2545         set_errno(ESRCH);  break;
2546       case SS$_INSFMEM:
2547         set_errno(ENOMEM); break;
2548       default:
2549         _ckvmssts_noperl(iss);
2550         set_errno(EVMSERR);
2551     }
2552     set_vaxc_errno(iss);
2553
2554     return -1;
2555 }
2556 #endif
2557
2558 /* Routine to convert a VMS status code to a UNIX status code.
2559 ** More tricky than it appears because of conflicting conventions with
2560 ** existing code.
2561 **
2562 ** VMS status codes are a bit mask, with the least significant bit set for
2563 ** success.
2564 **
2565 ** Special UNIX status of EVMSERR indicates that no translation is currently
2566 ** available, and programs should check the VMS status code.
2567 **
2568 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2569 ** decoding.
2570 */
2571
2572 #ifndef C_FACILITY_NO
2573 #define C_FACILITY_NO 0x350000
2574 #endif
2575 #ifndef DCL_IVVERB
2576 #define DCL_IVVERB 0x38090
2577 #endif
2578
2579 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2580 {
2581 int facility;
2582 int fac_sp;
2583 int msg_no;
2584 int msg_status;
2585 int unix_status;
2586
2587   /* Assume the best or the worst */
2588   if (vms_status & STS$M_SUCCESS)
2589     unix_status = 0;
2590   else
2591     unix_status = EVMSERR;
2592
2593   msg_status = vms_status & ~STS$M_CONTROL;
2594
2595   facility = vms_status & STS$M_FAC_NO;
2596   fac_sp = vms_status & STS$M_FAC_SP;
2597   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2598
2599   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2600     switch(msg_no) {
2601     case SS$_NORMAL:
2602         unix_status = 0;
2603         break;
2604     case SS$_ACCVIO:
2605         unix_status = EFAULT;
2606         break;
2607     case SS$_DEVOFFLINE:
2608         unix_status = EBUSY;
2609         break;
2610     case SS$_CLEARED:
2611         unix_status = ENOTCONN;
2612         break;
2613     case SS$_IVCHAN:
2614     case SS$_IVLOGNAM:
2615     case SS$_BADPARAM:
2616     case SS$_IVLOGTAB:
2617     case SS$_NOLOGNAM:
2618     case SS$_NOLOGTAB:
2619     case SS$_INVFILFOROP:
2620     case SS$_INVARG:
2621     case SS$_NOSUCHID:
2622     case SS$_IVIDENT:
2623         unix_status = EINVAL;
2624         break;
2625     case SS$_UNSUPPORTED:
2626         unix_status = ENOTSUP;
2627         break;
2628     case SS$_FILACCERR:
2629     case SS$_NOGRPPRV:
2630     case SS$_NOSYSPRV:
2631         unix_status = EACCES;
2632         break;
2633     case SS$_DEVICEFULL:
2634         unix_status = ENOSPC;
2635         break;
2636     case SS$_NOSUCHDEV:
2637         unix_status = ENODEV;
2638         break;
2639     case SS$_NOSUCHFILE:
2640     case SS$_NOSUCHOBJECT:
2641         unix_status = ENOENT;
2642         break;
2643     case SS$_ABORT:                                 /* Fatal case */
2644     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2645     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2646         unix_status = EINTR;
2647         break;
2648     case SS$_BUFFEROVF:
2649         unix_status = E2BIG;
2650         break;
2651     case SS$_INSFMEM:
2652         unix_status = ENOMEM;
2653         break;
2654     case SS$_NOPRIV:
2655         unix_status = EPERM;
2656         break;
2657     case SS$_NOSUCHNODE:
2658     case SS$_UNREACHABLE:
2659         unix_status = ESRCH;
2660         break;
2661     case SS$_NONEXPR:
2662         unix_status = ECHILD;
2663         break;
2664     default:
2665         if ((facility == 0) && (msg_no < 8)) {
2666           /* These are not real VMS status codes so assume that they are
2667           ** already UNIX status codes
2668           */
2669           unix_status = msg_no;
2670           break;
2671         }
2672     }
2673   }
2674   else {
2675     /* Translate a POSIX exit code to a UNIX exit code */
2676     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2677         unix_status = (msg_no & 0x07F8) >> 3;
2678     }
2679     else {
2680
2681          /* Documented traditional behavior for handling VMS child exits */
2682         /*--------------------------------------------------------------*/
2683         if (child_flag != 0) {
2684
2685              /* Success / Informational return 0 */
2686             /*----------------------------------*/
2687             if (msg_no & STS$K_SUCCESS)
2688                 return 0;
2689
2690              /* Warning returns 1 */
2691             /*-------------------*/
2692             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2693                 return 1;
2694
2695              /* Everything else pass through the severity bits */
2696             /*------------------------------------------------*/
2697             return (msg_no & STS$M_SEVERITY);
2698         }
2699
2700          /* Normal VMS status to ERRNO mapping attempt */
2701         /*--------------------------------------------*/
2702         switch(msg_status) {
2703         /* case RMS$_EOF: */ /* End of File */
2704         case RMS$_FNF:  /* File Not Found */
2705         case RMS$_DNF:  /* Dir Not Found */
2706                 unix_status = ENOENT;
2707                 break;
2708         case RMS$_RNF:  /* Record Not Found */
2709                 unix_status = ESRCH;
2710                 break;
2711         case RMS$_DIR:
2712                 unix_status = ENOTDIR;
2713                 break;
2714         case RMS$_DEV:
2715                 unix_status = ENODEV;
2716                 break;
2717         case RMS$_IFI:
2718         case RMS$_FAC:
2719         case RMS$_ISI:
2720                 unix_status = EBADF;
2721                 break;
2722         case RMS$_FEX:
2723                 unix_status = EEXIST;
2724                 break;
2725         case RMS$_SYN:
2726         case RMS$_FNM:
2727         case LIB$_INVSTRDES:
2728         case LIB$_INVARG:
2729         case LIB$_NOSUCHSYM:
2730         case LIB$_INVSYMNAM:
2731         case DCL_IVVERB:
2732                 unix_status = EINVAL;
2733                 break;
2734         case CLI$_BUFOVF:
2735         case RMS$_RTB:
2736         case CLI$_TKNOVF:
2737         case CLI$_RSLOVF:
2738                 unix_status = E2BIG;
2739                 break;
2740         case RMS$_PRV:  /* No privilege */
2741         case RMS$_ACC:  /* ACP file access failed */
2742         case RMS$_WLK:  /* Device write locked */
2743                 unix_status = EACCES;
2744                 break;
2745         case RMS$_MKD:  /* Failed to mark for delete */
2746                 unix_status = EPERM;
2747                 break;
2748         /* case RMS$_NMF: */  /* No more files */
2749         }
2750     }
2751   }
2752
2753   return unix_status;
2754 }
2755
2756 /* Try to guess at what VMS error status should go with a UNIX errno
2757  * value.  This is hard to do as there could be many possible VMS
2758  * error statuses that caused the errno value to be set.
2759  */
2760
2761 int Perl_unix_status_to_vms(int unix_status)
2762 {
2763 int test_unix_status;
2764
2765      /* Trivial cases first */
2766     /*---------------------*/
2767     if (unix_status == EVMSERR)
2768         return vaxc$errno;
2769
2770      /* Is vaxc$errno sane? */
2771     /*---------------------*/
2772     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2773     if (test_unix_status == unix_status)
2774         return vaxc$errno;
2775
2776      /* If way out of range, must be VMS code already */
2777     /*-----------------------------------------------*/
2778     if (unix_status > EVMSERR)
2779         return unix_status;
2780
2781      /* If out of range, punt */
2782     /*-----------------------*/
2783     if (unix_status > __ERRNO_MAX)
2784         return SS$_ABORT;
2785
2786
2787      /* Ok, now we have to do it the hard way. */
2788     /*----------------------------------------*/
2789     switch(unix_status) {
2790     case 0:     return SS$_NORMAL;
2791     case EPERM: return SS$_NOPRIV;
2792     case ENOENT: return SS$_NOSUCHOBJECT;
2793     case ESRCH: return SS$_UNREACHABLE;
2794     case EINTR: return SS$_ABORT;
2795     /* case EIO: */
2796     /* case ENXIO:  */
2797     case E2BIG: return SS$_BUFFEROVF;
2798     /* case ENOEXEC */
2799     case EBADF: return RMS$_IFI;
2800     case ECHILD: return SS$_NONEXPR;
2801     /* case EAGAIN */
2802     case ENOMEM: return SS$_INSFMEM;
2803     case EACCES: return SS$_FILACCERR;
2804     case EFAULT: return SS$_ACCVIO;
2805     /* case ENOTBLK */
2806     case EBUSY: return SS$_DEVOFFLINE;
2807     case EEXIST: return RMS$_FEX;
2808     /* case EXDEV */
2809     case ENODEV: return SS$_NOSUCHDEV;
2810     case ENOTDIR: return RMS$_DIR;
2811     /* case EISDIR */
2812     case EINVAL: return SS$_INVARG;
2813     /* case ENFILE */
2814     /* case EMFILE */
2815     /* case ENOTTY */
2816     /* case ETXTBSY */
2817     /* case EFBIG */
2818     case ENOSPC: return SS$_DEVICEFULL;
2819     case ESPIPE: return LIB$_INVARG;
2820     /* case EROFS: */
2821     /* case EMLINK: */
2822     /* case EPIPE: */
2823     /* case EDOM */
2824     case ERANGE: return LIB$_INVARG;
2825     /* case EWOULDBLOCK */
2826     /* case EINPROGRESS */
2827     /* case EALREADY */
2828     /* case ENOTSOCK */
2829     /* case EDESTADDRREQ */
2830     /* case EMSGSIZE */
2831     /* case EPROTOTYPE */
2832     /* case ENOPROTOOPT */
2833     /* case EPROTONOSUPPORT */
2834     /* case ESOCKTNOSUPPORT */
2835     /* case EOPNOTSUPP */
2836     /* case EPFNOSUPPORT */
2837     /* case EAFNOSUPPORT */
2838     /* case EADDRINUSE */
2839     /* case EADDRNOTAVAIL */
2840     /* case ENETDOWN */
2841     /* case ENETUNREACH */
2842     /* case ENETRESET */
2843     /* case ECONNABORTED */
2844     /* case ECONNRESET */
2845     /* case ENOBUFS */
2846     /* case EISCONN */
2847     case ENOTCONN: return SS$_CLEARED;
2848     /* case ESHUTDOWN */
2849     /* case ETOOMANYREFS */
2850     /* case ETIMEDOUT */
2851     /* case ECONNREFUSED */
2852     /* case ELOOP */
2853     /* case ENAMETOOLONG */
2854     /* case EHOSTDOWN */
2855     /* case EHOSTUNREACH */
2856     /* case ENOTEMPTY */
2857     /* case EPROCLIM */
2858     /* case EUSERS  */
2859     /* case EDQUOT  */
2860     /* case ENOMSG  */
2861     /* case EIDRM */
2862     /* case EALIGN */
2863     /* case ESTALE */
2864     /* case EREMOTE */
2865     /* case ENOLCK */
2866     /* case ENOSYS */
2867     /* case EFTYPE */
2868     /* case ECANCELED */
2869     /* case EFAIL */
2870     /* case EINPROG */
2871     case ENOTSUP:
2872         return SS$_UNSUPPORTED;
2873     /* case EDEADLK */
2874     /* case ENWAIT */
2875     /* case EILSEQ */
2876     /* case EBADCAT */
2877     /* case EBADMSG */
2878     /* case EABANDONED */
2879     default:
2880         return SS$_ABORT; /* punt */
2881     }
2882
2883   return SS$_ABORT; /* Should not get here */
2884 }
2885
2886
2887 /* default piping mailbox size */
2888 #define PERL_BUFSIZ        512
2889
2890
2891 static void
2892 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2893 {
2894   unsigned long int mbxbufsiz;
2895   static unsigned long int syssize = 0;
2896   unsigned long int dviitm = DVI$_DEVNAM;
2897   char csize[LNM$C_NAMLENGTH+1];
2898   int sts;
2899
2900   if (!syssize) {
2901     unsigned long syiitm = SYI$_MAXBUF;
2902     /*
2903      * Get the SYSGEN parameter MAXBUF
2904      *
2905      * If the logical 'PERL_MBX_SIZE' is defined
2906      * use the value of the logical instead of PERL_BUFSIZ, but
2907      * keep the size between 128 and MAXBUF.
2908      *
2909      */
2910     _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2911   }
2912
2913   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2914       mbxbufsiz = atoi(csize);
2915   } else {
2916       mbxbufsiz = PERL_BUFSIZ;
2917   }
2918   if (mbxbufsiz < 128) mbxbufsiz = 128;
2919   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2920
2921   _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2922
2923   sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2924   _ckvmssts_noperl(sts);
2925   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2926
2927 }  /* end of create_mbx() */
2928
2929
2930 /*{{{  my_popen and my_pclose*/
2931
2932 typedef struct _iosb           IOSB;
2933 typedef struct _iosb*         pIOSB;
2934 typedef struct _pipe           Pipe;
2935 typedef struct _pipe*         pPipe;
2936 typedef struct pipe_details    Info;
2937 typedef struct pipe_details*  pInfo;
2938 typedef struct _srqp            RQE;
2939 typedef struct _srqp*          pRQE;
2940 typedef struct _tochildbuf      CBuf;
2941 typedef struct _tochildbuf*    pCBuf;
2942
2943 struct _iosb {
2944     unsigned short status;
2945     unsigned short count;
2946     unsigned long  dvispec;
2947 };
2948
2949 #pragma member_alignment save
2950 #pragma nomember_alignment quadword
2951 struct _srqp {          /* VMS self-relative queue entry */
2952     unsigned long qptr[2];
2953 };
2954 #pragma member_alignment restore
2955 static RQE  RQE_ZERO = {0,0};
2956
2957 struct _tochildbuf {
2958     RQE             q;
2959     int             eof;
2960     unsigned short  size;
2961     char            *buf;
2962 };
2963
2964 struct _pipe {
2965     RQE            free;
2966     RQE            wait;
2967     int            fd_out;
2968     unsigned short chan_in;
2969     unsigned short chan_out;
2970     char          *buf;
2971     unsigned int   bufsize;
2972     IOSB           iosb;
2973     IOSB           iosb2;
2974     int           *pipe_done;
2975     int            retry;
2976     int            type;
2977     int            shut_on_empty;
2978     int            need_wake;
2979     pPipe         *home;
2980     pInfo          info;
2981     pCBuf          curr;
2982     pCBuf          curr2;
2983 #if defined(PERL_IMPLICIT_CONTEXT)
2984     void            *thx;           /* Either a thread or an interpreter */
2985                                     /* pointer, depending on how we're built */
2986 #endif
2987 };
2988
2989
2990 struct pipe_details
2991 {
2992     pInfo           next;
2993     PerlIO *fp;  /* file pointer to pipe mailbox */
2994     int useFILE; /* using stdio, not perlio */
2995     int pid;   /* PID of subprocess */
2996     int mode;  /* == 'r' if pipe open for reading */
2997     int done;  /* subprocess has completed */
2998     int waiting; /* waiting for completion/closure */
2999     int             closing;        /* my_pclose is closing this pipe */
3000     unsigned long   completion;     /* termination status of subprocess */
3001     pPipe           in;             /* pipe in to sub */
3002     pPipe           out;            /* pipe out of sub */
3003     pPipe           err;            /* pipe of sub's sys$error */
3004     int             in_done;        /* true when in pipe finished */
3005     int             out_done;
3006     int             err_done;
3007     unsigned short  xchan;          /* channel to debug xterm */
3008     unsigned short  xchan_valid;    /* channel is assigned */
3009 };
3010
3011 struct exit_control_block
3012 {
3013     struct exit_control_block *flink;
3014     unsigned long int   (*exit_routine)();
3015     unsigned long int arg_count;
3016     unsigned long int *status_address;
3017     unsigned long int exit_status;
3018 };
3019
3020 typedef struct _closed_pipes    Xpipe;
3021 typedef struct _closed_pipes*  pXpipe;
3022
3023 struct _closed_pipes {
3024     int             pid;            /* PID of subprocess */
3025     unsigned long   completion;     /* termination status of subprocess */
3026 };
3027 #define NKEEPCLOSED 50
3028 static Xpipe closed_list[NKEEPCLOSED];
3029 static int   closed_index = 0;
3030 static int   closed_num = 0;
3031
3032 #define RETRY_DELAY     "0 ::0.20"
3033 #define MAX_RETRY              50
3034
3035 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
3036 static unsigned long mypid;
3037 static unsigned long delaytime[2];
3038
3039 static pInfo open_pipes = NULL;
3040 static $DESCRIPTOR(nl_desc, "NL:");
3041
3042 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
3043
3044
3045
3046 static unsigned long int
3047 pipe_exit_routine()
3048 {
3049     pInfo info;
3050     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
3051     int sts, did_stuff, need_eof, j;
3052
3053    /*
3054     * Flush any pending i/o, but since we are in process run-down, be
3055     * careful about referencing PerlIO structures that may already have
3056     * been deallocated.  We may not even have an interpreter anymore.
3057     */
3058     info = open_pipes;
3059     while (info) {
3060         if (info->fp) {
3061 #if defined(PERL_IMPLICIT_CONTEXT)
3062            /* We need to use the Perl context of the thread that created */
3063            /* the pipe. */
3064            pTHX;
3065            if (info->err)
3066                aTHX = info->err->thx;
3067            else if (info->out)
3068                aTHX = info->out->thx;
3069            else if (info->in)
3070                aTHX = info->in->thx;
3071 #endif
3072            if (!info->useFILE
3073 #if defined(USE_ITHREADS)
3074              && my_perl
3075 #endif
3076              && PL_perlio_fd_refcnt)
3077                PerlIO_flush(info->fp);
3078            else
3079                fflush((FILE *)info->fp);
3080         }
3081         info = info->next;
3082     }
3083
3084     /*
3085      next we try sending an EOF...ignore if doesn't work, make sure we
3086      don't hang
3087     */
3088     did_stuff = 0;
3089     info = open_pipes;
3090
3091     while (info) {
3092       int need_eof;
3093       _ckvmssts_noperl(sys$setast(0));
3094       if (info->in && !info->in->shut_on_empty) {
3095         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3096                                  0, 0, 0, 0, 0, 0));
3097         info->waiting = 1;
3098         did_stuff = 1;
3099       }
3100       _ckvmssts_noperl(sys$setast(1));
3101       info = info->next;
3102     }
3103
3104     /* wait for EOF to have effect, up to ~ 30 sec [default] */
3105
3106     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3107         int nwait = 0;
3108
3109         info = open_pipes;
3110         while (info) {
3111           _ckvmssts_noperl(sys$setast(0));
3112           if (info->waiting && info->done)
3113                 info->waiting = 0;
3114           nwait += info->waiting;
3115           _ckvmssts_noperl(sys$setast(1));
3116           info = info->next;
3117         }
3118         if (!nwait) break;
3119         sleep(1);
3120     }
3121
3122     did_stuff = 0;
3123     info = open_pipes;
3124     while (info) {
3125       _ckvmssts_noperl(sys$setast(0));
3126       if (!info->done) { /* Tap them gently on the shoulder . . .*/
3127         sts = sys$forcex(&info->pid,0,&abort);
3128         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3129         did_stuff = 1;
3130       }
3131       _ckvmssts_noperl(sys$setast(1));
3132       info = info->next;
3133     }
3134
3135     /* again, wait for effect */
3136
3137     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3138         int nwait = 0;
3139
3140         info = open_pipes;
3141         while (info) {
3142           _ckvmssts_noperl(sys$setast(0));
3143           if (info->waiting && info->done)
3144                 info->waiting = 0;
3145           nwait += info->waiting;
3146           _ckvmssts_noperl(sys$setast(1));
3147           info = info->next;
3148         }
3149         if (!nwait) break;
3150         sleep(1);
3151     }
3152
3153     info = open_pipes;
3154     while (info) {
3155       _ckvmssts_noperl(sys$setast(0));
3156       if (!info->done) {  /* We tried to be nice . . . */
3157         sts = sys$delprc(&info->pid,0);
3158         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3159         info->done = 1;  /* sys$delprc is as done as we're going to get. */
3160       }
3161       _ckvmssts_noperl(sys$setast(1));
3162       info = info->next;
3163     }
3164
3165     while(open_pipes) {
3166
3167 #if defined(PERL_IMPLICIT_CONTEXT)
3168       /* We need to use the Perl context of the thread that created */
3169       /* the pipe. */
3170       pTHX;
3171       if (open_pipes->err)
3172           aTHX = open_pipes->err->thx;
3173       else if (open_pipes->out)
3174           aTHX = open_pipes->out->thx;
3175       else if (open_pipes->in)
3176           aTHX = open_pipes->in->thx;
3177 #endif
3178       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3179       else if (!(sts & 1)) retsts = sts;
3180     }
3181     return retsts;
3182 }
3183
3184 static struct exit_control_block pipe_exitblock =
3185        {(struct exit_control_block *) 0,
3186         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3187
3188 static void pipe_mbxtofd_ast(pPipe p);
3189 static void pipe_tochild1_ast(pPipe p);
3190 static void pipe_tochild2_ast(pPipe p);
3191
3192 static void
3193 popen_completion_ast(pInfo info)
3194 {
3195   pInfo i = open_pipes;
3196   int iss;
3197   int sts;
3198   pXpipe x;
3199
3200   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3201   closed_list[closed_index].pid = info->pid;
3202   closed_list[closed_index].completion = info->completion;
3203   closed_index++;
3204   if (closed_index == NKEEPCLOSED)
3205     closed_index = 0;
3206   closed_num++;
3207
3208   while (i) {
3209     if (i == info) break;
3210     i = i->next;
3211   }
3212   if (!i) return;       /* unlinked, probably freed too */
3213
3214   info->done = TRUE;
3215
3216 /*
3217     Writing to subprocess ...
3218             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3219
3220             chan_out may be waiting for "done" flag, or hung waiting
3221             for i/o completion to child...cancel the i/o.  This will
3222             put it into "snarf mode" (done but no EOF yet) that discards
3223             input.
3224
3225     Output from subprocess (stdout, stderr) needs to be flushed and
3226     shut down.   We try sending an EOF, but if the mbx is full the pipe
3227     routine should still catch the "shut_on_empty" flag, telling it to
3228     use immediate-style reads so that "mbx empty" -> EOF.
3229
3230
3231 */
3232   if (info->in && !info->in_done) {               /* only for mode=w */
3233         if (info->in->shut_on_empty && info->in->need_wake) {
3234             info->in->need_wake = FALSE;
3235             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3236         } else {
3237             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3238         }
3239   }
3240
3241   if (info->out && !info->out_done) {             /* were we also piping output? */
3242       info->out->shut_on_empty = TRUE;
3243       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3244       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3245       _ckvmssts_noperl(iss);
3246   }
3247
3248   if (info->err && !info->err_done) {        /* we were piping stderr */
3249         info->err->shut_on_empty = TRUE;
3250         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3251         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3252         _ckvmssts_noperl(iss);
3253   }
3254   _ckvmssts_noperl(sys$setef(pipe_ef));
3255
3256 }
3257
3258 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3259 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3260
3261 /*
3262     we actually differ from vmstrnenv since we use this to
3263     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3264     are pointing to the same thing
3265 */
3266
3267 static unsigned short
3268 popen_translate(pTHX_ char *logical, char *result)
3269 {
3270     int iss;
3271     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3272     $DESCRIPTOR(d_log,"");
3273     struct _il3 {
3274         unsigned short length;
3275         unsigned short code;
3276         char *         buffer_addr;
3277         unsigned short *retlenaddr;
3278     } itmlst[2];
3279     unsigned short l, ifi;
3280
3281     d_log.dsc$a_pointer = logical;
3282     d_log.dsc$w_length  = strlen(logical);
3283
3284     itmlst[0].code = LNM$_STRING;
3285     itmlst[0].length = 255;
3286     itmlst[0].buffer_addr = result;
3287     itmlst[0].retlenaddr = &l;
3288
3289     itmlst[1].code = 0;
3290     itmlst[1].length = 0;
3291     itmlst[1].buffer_addr = 0;
3292     itmlst[1].retlenaddr = 0;
3293
3294     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3295     if (iss == SS$_NOLOGNAM) {
3296         iss = SS$_NORMAL;
3297         l = 0;
3298     }
3299     if (!(iss&1)) lib$signal(iss);
3300     result[l] = '\0';
3301 /*
3302     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
3303     strip it off and return the ifi, if any
3304 */
3305     ifi  = 0;
3306     if (result[0] == 0x1b && result[1] == 0x00) {
3307         memmove(&ifi,result+2,2);
3308         strcpy(result,result+4);
3309     }
3310     return ifi;     /* this is the RMS internal file id */
3311 }
3312
3313 static void pipe_infromchild_ast(pPipe p);
3314
3315 /*
3316     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3317     inside an AST routine without worrying about reentrancy and which Perl
3318     memory allocator is being used.
3319
3320     We read data and queue up the buffers, then spit them out one at a
3321     time to the output mailbox when the output mailbox is ready for one.
3322
3323 */
3324 #define INITIAL_TOCHILDQUEUE  2
3325
3326 static pPipe
3327 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3328 {
3329     pPipe p;
3330     pCBuf b;
3331     char mbx1[64], mbx2[64];
3332     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3333                                       DSC$K_CLASS_S, mbx1},
3334                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3335                                       DSC$K_CLASS_S, mbx2};
3336     unsigned int dviitm = DVI$_DEVBUFSIZ;
3337     int j, n;
3338
3339     n = sizeof(Pipe);
3340     _ckvmssts_noperl(lib$get_vm(&n, &p));
3341
3342     create_mbx(&p->chan_in , &d_mbx1);
3343     create_mbx(&p->chan_out, &d_mbx2);
3344     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3345
3346     p->buf           = 0;
3347     p->shut_on_empty = FALSE;
3348     p->need_wake     = FALSE;
3349     p->type          = 0;
3350     p->retry         = 0;
3351     p->iosb.status   = SS$_NORMAL;
3352     p->iosb2.status  = SS$_NORMAL;
3353     p->free          = RQE_ZERO;
3354     p->wait          = RQE_ZERO;
3355     p->curr          = 0;
3356     p->curr2         = 0;
3357     p->info          = 0;
3358 #ifdef PERL_IMPLICIT_CONTEXT
3359     p->thx           = aTHX;
3360 #endif
3361
3362     n = sizeof(CBuf) + p->bufsize;
3363
3364     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3365         _ckvmssts_noperl(lib$get_vm(&n, &b));
3366         b->buf = (char *) b + sizeof(CBuf);
3367         _ckvmssts_noperl(lib$insqhi(b, &p->free));
3368     }
3369
3370     pipe_tochild2_ast(p);
3371     pipe_tochild1_ast(p);
3372     strcpy(wmbx, mbx1);
3373     strcpy(rmbx, mbx2);
3374     return p;
3375 }
3376
3377 /*  reads the MBX Perl is writing, and queues */
3378
3379 static void
3380 pipe_tochild1_ast(pPipe p)
3381 {
3382     pCBuf b = p->curr;
3383     int iss = p->iosb.status;
3384     int eof = (iss == SS$_ENDOFFILE);
3385     int sts;
3386 #ifdef PERL_IMPLICIT_CONTEXT
3387     pTHX = p->thx;
3388 #endif
3389
3390     if (p->retry) {
3391         if (eof) {
3392             p->shut_on_empty = TRUE;
3393             b->eof     = TRUE;
3394             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3395         } else  {
3396             _ckvmssts_noperl(iss);
3397         }
3398
3399         b->eof  = eof;
3400         b->size = p->iosb.count;
3401         _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3402         if (p->need_wake) {
3403             p->need_wake = FALSE;
3404             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3405         }
3406     } else {
3407         p->retry = 1;   /* initial call */
3408     }
3409
3410     if (eof) {                  /* flush the free queue, return when done */
3411         int n = sizeof(CBuf) + p->bufsize;
3412         while (1) {
3413             iss = lib$remqti(&p->free, &b);
3414             if (iss == LIB$_QUEWASEMP) return;
3415             _ckvmssts_noperl(iss);
3416             _ckvmssts_noperl(lib$free_vm(&n, &b));
3417         }
3418     }
3419
3420     iss = lib$remqti(&p->free, &b);
3421     if (iss == LIB$_QUEWASEMP) {
3422         int n = sizeof(CBuf) + p->bufsize;
3423         _ckvmssts_noperl(lib$get_vm(&n, &b));
3424         b->buf = (char *) b + sizeof(CBuf);
3425     } else {
3426        _ckvmssts_noperl(iss);
3427     }
3428
3429     p->curr = b;
3430     iss = sys$qio(0,p->chan_in,
3431              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3432              &p->iosb,
3433              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3434     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3435     _ckvmssts_noperl(iss);
3436 }
3437
3438
3439 /* writes queued buffers to output, waits for each to complete before
3440    doing the next */
3441
3442 static void
3443 pipe_tochild2_ast(pPipe p)
3444 {
3445     pCBuf b = p->curr2;
3446     int iss = p->iosb2.status;
3447     int n = sizeof(CBuf) + p->bufsize;
3448     int done = (p->info && p->info->done) ||
3449               iss == SS$_CANCEL || iss == SS$_ABORT;
3450 #if defined(PERL_IMPLICIT_CONTEXT)
3451     pTHX = p->thx;
3452 #endif
3453
3454     do {
3455         if (p->type) {         /* type=1 has old buffer, dispose */
3456             if (p->shut_on_empty) {
3457                 _ckvmssts_noperl(lib$free_vm(&n, &b));
3458             } else {
3459                 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3460             }
3461             p->type = 0;
3462         }
3463
3464         iss = lib$remqti(&p->wait, &b);
3465         if (iss == LIB$_QUEWASEMP) {
3466             if (p->shut_on_empty) {
3467                 if (done) {
3468                     _ckvmssts_noperl(sys$dassgn(p->chan_out));
3469                     *p->pipe_done = TRUE;
3470                     _ckvmssts_noperl(sys$setef(pipe_ef));
3471                 } else {
3472                     _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3473                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3474                 }
3475                 return;
3476             }
3477             p->need_wake = TRUE;
3478             return;
3479         }
3480         _ckvmssts_noperl(iss);
3481         p->type = 1;
3482     } while (done);
3483
3484
3485     p->curr2 = b;
3486     if (b->eof) {
3487         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3488             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3489     } else {
3490         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3491             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3492     }
3493
3494     return;
3495
3496 }
3497
3498
3499 static pPipe
3500 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3501 {
3502     pPipe p;
3503     char mbx1[64], mbx2[64];
3504     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3505                                       DSC$K_CLASS_S, mbx1},
3506                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3507                                       DSC$K_CLASS_S, mbx2};
3508     unsigned int dviitm = DVI$_DEVBUFSIZ;
3509
3510     int n = sizeof(Pipe);
3511     _ckvmssts_noperl(lib$get_vm(&n, &p));
3512     create_mbx(&p->chan_in , &d_mbx1);
3513     create_mbx(&p->chan_out, &d_mbx2);
3514
3515     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3516     n = p->bufsize * sizeof(char);
3517     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3518     p->shut_on_empty = FALSE;
3519     p->info   = 0;
3520     p->type   = 0;
3521     p->iosb.status = SS$_NORMAL;
3522 #if defined(PERL_IMPLICIT_CONTEXT)
3523     p->thx = aTHX;
3524 #endif
3525     pipe_infromchild_ast(p);
3526
3527     strcpy(wmbx, mbx1);
3528     strcpy(rmbx, mbx2);
3529     return p;
3530 }
3531
3532 static void
3533 pipe_infromchild_ast(pPipe p)
3534 {
3535     int iss = p->iosb.status;
3536     int eof = (iss == SS$_ENDOFFILE);
3537     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3538     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3539 #if defined(PERL_IMPLICIT_CONTEXT)
3540     pTHX = p->thx;
3541 #endif
3542
3543     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3544         _ckvmssts_noperl(sys$dassgn(p->chan_out));
3545         p->chan_out = 0;
3546     }
3547
3548     /* read completed:
3549             input shutdown if EOF from self (done or shut_on_empty)
3550             output shutdown if closing flag set (my_pclose)
3551             send data/eof from child or eof from self
3552             otherwise, re-read (snarf of data from child)
3553     */
3554
3555     if (p->type == 1) {
3556         p->type = 0;
3557         if (myeof && p->chan_in) {                  /* input shutdown */
3558             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3559             p->chan_in = 0;
3560         }
3561
3562         if (p->chan_out) {
3563             if (myeof || kideof) {      /* pass EOF to parent */
3564                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3565                                          pipe_infromchild_ast, p,
3566                                          0, 0, 0, 0, 0, 0));
3567                 return;
3568             } else if (eof) {       /* eat EOF --- fall through to read*/
3569
3570             } else {                /* transmit data */
3571                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3572                                          pipe_infromchild_ast,p,
3573                                          p->buf, p->iosb.count, 0, 0, 0, 0));
3574                 return;
3575             }
3576         }
3577     }
3578
3579     /*  everything shut? flag as done */
3580
3581     if (!p->chan_in && !p->chan_out) {
3582         *p->pipe_done = TRUE;
3583         _ckvmssts_noperl(sys$setef(pipe_ef));
3584         return;
3585     }
3586
3587     /* write completed (or read, if snarfing from child)
3588             if still have input active,
3589                queue read...immediate mode if shut_on_empty so we get EOF if empty
3590             otherwise,
3591                check if Perl reading, generate EOFs as needed
3592     */
3593
3594     if (p->type == 0) {
3595         p->type = 1;
3596         if (p->chan_in) {
3597             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3598                           pipe_infromchild_ast,p,
3599                           p->buf, p->bufsize, 0, 0, 0, 0);
3600             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3601             _ckvmssts_noperl(iss);
3602         } else {           /* send EOFs for extra reads */
3603             p->iosb.status = SS$_ENDOFFILE;
3604             p->iosb.dvispec = 0;
3605             _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3606                                      0, 0, 0,
3607                                      pipe_infromchild_ast, p, 0, 0, 0, 0));
3608         }
3609     }
3610 }
3611
3612 static pPipe
3613 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3614 {
3615     pPipe p;
3616     char mbx[64];
3617     unsigned long dviitm = DVI$_DEVBUFSIZ;
3618     struct stat s;
3619     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3620                                       DSC$K_CLASS_S, mbx};
3621     int n = sizeof(Pipe);
3622
3623     /* things like terminals and mbx's don't need this filter */
3624     if (fd && fstat(fd,&s) == 0) {
3625         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3626         char device[65];
3627         unsigned short dev_len;
3628         struct dsc$descriptor_s d_dev;
3629         char * cptr;
3630         struct item_list_3 items[3];
3631         int status;
3632         unsigned short dvi_iosb[4];
3633
3634         cptr = getname(fd, out, 1);
3635         if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3636         d_dev.dsc$a_pointer = out;
3637         d_dev.dsc$w_length = strlen(out);
3638         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3639         d_dev.dsc$b_class = DSC$K_CLASS_S;
3640
3641         items[0].len = 4;
3642         items[0].code = DVI$_DEVCHAR;
3643         items[0].bufadr = &devchar;
3644         items[0].retadr = NULL;
3645         items[1].len = 64;
3646         items[1].code = DVI$_FULLDEVNAM;
3647         items[1].bufadr = device;
3648         items[1].retadr = &dev_len;
3649         items[2].len = 0;
3650         items[2].code = 0;
3651
3652         status = sys$getdviw
3653                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3654         _ckvmssts_noperl(status);
3655         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3656             device[dev_len] = 0;
3657
3658             if (!(devchar & DEV$M_DIR)) {
3659                 strcpy(out, device);
3660                 return 0;
3661             }
3662         }
3663     }
3664
3665     _ckvmssts_noperl(lib$get_vm(&n, &p));
3666     p->fd_out = dup(fd);
3667     create_mbx(&p->chan_in, &d_mbx);
3668     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3669     n = (p->bufsize+1) * sizeof(char);
3670     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3671     p->shut_on_empty = FALSE;
3672     p->retry = 0;
3673     p->info  = 0;
3674     strcpy(out, mbx);
3675
3676     _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3677                              pipe_mbxtofd_ast, p,
3678                              p->buf, p->bufsize, 0, 0, 0, 0));
3679
3680     return p;
3681 }
3682
3683 static void
3684 pipe_mbxtofd_ast(pPipe p)
3685 {
3686     int iss = p->iosb.status;
3687     int done = p->info->done;
3688     int iss2;
3689     int eof = (iss == SS$_ENDOFFILE);
3690     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3691     int err = !(iss&1) && !eof;
3692 #if defined(PERL_IMPLICIT_CONTEXT)
3693     pTHX = p->thx;
3694 #endif
3695
3696     if (done && myeof) {               /* end piping */
3697         close(p->fd_out);
3698         sys$dassgn(p->chan_in);
3699         *p->pipe_done = TRUE;
3700         _ckvmssts_noperl(sys$setef(pipe_ef));
3701         return;
3702     }
3703
3704     if (!err && !eof) {             /* good data to send to file */
3705         p->buf[p->iosb.count] = '\n';
3706         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3707         if (iss2 < 0) {
3708             p->retry++;
3709             if (p->retry < MAX_RETRY) {
3710                 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3711                 return;
3712             }
3713         }
3714         p->retry = 0;
3715     } else if (err) {
3716         _ckvmssts_noperl(iss);
3717     }
3718
3719
3720     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3721           pipe_mbxtofd_ast, p,
3722           p->buf, p->bufsize, 0, 0, 0, 0);
3723     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3724     _ckvmssts_noperl(iss);
3725 }
3726
3727
3728 typedef struct _pipeloc     PLOC;
3729 typedef struct _pipeloc*   pPLOC;
3730
3731 struct _pipeloc {
3732     pPLOC   next;
3733     char    dir[NAM$C_MAXRSS+1];
3734 };
3735 static pPLOC  head_PLOC = 0;
3736
3737 void
3738 free_pipelocs(pTHX_ void *head)
3739 {
3740     pPLOC p, pnext;
3741     pPLOC *pHead = (pPLOC *)head;
3742
3743     p = *pHead;
3744     while (p) {
3745         pnext = p->next;
3746         PerlMem_free(p);
3747         p = pnext;
3748     }
3749     *pHead = 0;
3750 }
3751
3752 static void
3753 store_pipelocs(pTHX)
3754 {
3755     int    i;
3756     pPLOC  p;
3757     AV    *av = 0;
3758     SV    *dirsv;
3759     GV    *gv;
3760     char  *dir, *x;
3761     char  *unixdir;
3762     char  temp[NAM$C_MAXRSS+1];
3763     STRLEN n_a;
3764
3765     if (head_PLOC)
3766         free_pipelocs(aTHX_ &head_PLOC);
3767
3768 /*  the . directory from @INC comes last */
3769
3770     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3771     if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3772     p->next = head_PLOC;
3773     head_PLOC = p;
3774     strcpy(p->dir,"./");
3775
3776 /*  get the directory from $^X */
3777
3778     unixdir = PerlMem_malloc(VMS_MAXRSS);
3779     if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3780
3781 #ifdef PERL_IMPLICIT_CONTEXT
3782     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3783 #else
3784     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3785 #endif
3786         strcpy(temp, PL_origargv[0]);
3787         x = strrchr(temp,']');
3788         if (x == NULL) {
3789         x = strrchr(temp,'>');
3790           if (x == NULL) {
3791             /* It could be a UNIX path */
3792             x = strrchr(temp,'/');
3793           }
3794         }
3795         if (x)
3796           x[1] = '\0';
3797         else {
3798           /* Got a bare name, so use default directory */
3799           temp[0] = '.';
3800           temp[1] = '\0';
3801         }
3802
3803         if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3804             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3805             if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3806             p->next = head_PLOC;
3807             head_PLOC = p;
3808             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3809             p->dir[NAM$C_MAXRSS] = '\0';
3810         }
3811     }
3812
3813 /*  reverse order of @INC entries, skip "." since entered above */
3814
3815 #ifdef PERL_IMPLICIT_CONTEXT
3816     if (aTHX)
3817 #endif
3818     if (PL_incgv) av = GvAVn(PL_incgv);
3819
3820     for (i = 0; av && i <= AvFILL(av); i++) {
3821         dirsv = *av_fetch(av,i,TRUE);
3822
3823         if (SvROK(dirsv)) continue;
3824         dir = SvPVx(dirsv,n_a);
3825         if (strcmp(dir,".") == 0) continue;
3826         if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3827             continue;
3828
3829         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3830         p->next = head_PLOC;
3831         head_PLOC = p;
3832         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3833         p->dir[NAM$C_MAXRSS] = '\0';
3834     }
3835
3836 /* most likely spot (ARCHLIB) put first in the list */
3837
3838 #ifdef ARCHLIB_EXP
3839     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3840         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3841         if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3842         p->next = head_PLOC;
3843         head_PLOC = p;
3844         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3845         p->dir[NAM$C_MAXRSS] = '\0';
3846     }
3847 #endif
3848     PerlMem_free(unixdir);
3849 }
3850
3851 static I32
3852 Perl_cando_by_name_int
3853    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3854 #if !defined(PERL_IMPLICIT_CONTEXT)
3855 #define cando_by_name_int               Perl_cando_by_name_int
3856 #else
3857 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3858 #endif
3859
3860 static char *
3861 find_vmspipe(pTHX)
3862 {
3863     static int   vmspipe_file_status = 0;
3864     static char  vmspipe_file[NAM$C_MAXRSS+1];
3865
3866     /* already found? Check and use ... need read+execute permission */
3867
3868     if (vmspipe_file_status == 1) {
3869         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3870          && cando_by_name_int
3871            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3872             return vmspipe_file;
3873         }
3874         vmspipe_file_status = 0;
3875     }
3876
3877     /* scan through stored @INC, $^X */
3878
3879     if (vmspipe_file_status == 0) {
3880         char file[NAM$C_MAXRSS+1];
3881         pPLOC  p = head_PLOC;
3882
3883         while (p) {
3884             char * exp_res;
3885             int dirlen;
3886             strcpy(file, p->dir);
3887             dirlen = strlen(file);
3888             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3889             file[NAM$C_MAXRSS] = '\0';
3890             p = p->next;
3891
3892             exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3893             if (!exp_res) continue;
3894
3895             if (cando_by_name_int
3896                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3897              && cando_by_name_int
3898                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3899                 vmspipe_file_status = 1;
3900                 return vmspipe_file;
3901             }
3902         }
3903         vmspipe_file_status = -1;   /* failed, use tempfiles */
3904     }
3905
3906     return 0;
3907 }
3908
3909 static FILE *
3910 vmspipe_tempfile(pTHX)
3911 {
3912     char file[NAM$C_MAXRSS+1];
3913     FILE *fp;
3914     static int index = 0;
3915     Stat_t s0, s1;
3916     int cmp_result;
3917
3918     /* create a tempfile */
3919
3920     /* we can't go from   W, shr=get to  R, shr=get without
3921        an intermediate vulnerable state, so don't bother trying...
3922
3923        and lib$spawn doesn't shr=put, so have to close the write
3924
3925        So... match up the creation date/time and the FID to
3926        make sure we're dealing with the same file
3927
3928     */
3929
3930     index++;
3931     if (!decc_filename_unix_only) {
3932       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3933       fp = fopen(file,"w");
3934       if (!fp) {
3935         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3936         fp = fopen(file,"w");
3937         if (!fp) {
3938             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3939             fp = fopen(file,"w");
3940         }
3941       }
3942      }
3943      else {
3944       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3945       fp = fopen(file,"w");
3946       if (!fp) {
3947         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3948         fp = fopen(file,"w");
3949         if (!fp) {
3950           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3951           fp = fopen(file,"w");
3952         }
3953       }
3954     }
3955     if (!fp) return 0;  /* we're hosed */
3956
3957     fprintf(fp,"$! 'f$verify(0)'\n");
3958     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3959     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3960     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3961     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3962     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3963     fprintf(fp,"$ perl_del    = \"delete\"\n");
3964     fprintf(fp,"$ pif         = \"if\"\n");
3965     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3966     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3967     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3968     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3969     fprintf(fp,"$!  --- build command line to get max possible length\n");
3970     fprintf(fp,"$c=perl_popen_cmd0\n");
3971     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3972     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3973     fprintf(fp,"$x=perl_popen_cmd3\n");
3974     fprintf(fp,"$c=c+x\n");
3975     fprintf(fp,"$ perl_on\n");
3976     fprintf(fp,"$ 'c'\n");
3977     fprintf(fp,"$ perl_status = $STATUS\n");
3978     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3979     fprintf(fp,"$ perl_exit 'perl_status'\n");
3980     fsync(fileno(fp));
3981
3982     fgetname(fp, file, 1);
3983     fstat(fileno(fp), &s0.crtl_stat);
3984     fclose(fp);
3985
3986     if (decc_filename_unix_only)
3987         int_tounixspec(file, file, NULL);
3988     fp = fopen(file,"r","shr=get");
3989     if (!fp) return 0;
3990     fstat(fileno(fp), &s1.crtl_stat);
3991
3992     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3993     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3994         fclose(fp);
3995         return 0;
3996     }
3997
3998     return fp;
3999 }
4000
4001
4002 static int vms_is_syscommand_xterm(void)
4003 {
4004     const static struct dsc$descriptor_s syscommand_dsc =
4005       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
4006
4007     const static struct dsc$descriptor_s decwdisplay_dsc =
4008       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
4009
4010     struct item_list_3 items[2];
4011     unsigned short dvi_iosb[4];
4012     unsigned long devchar;
4013     unsigned long devclass;
4014     int status;
4015
4016     /* Very simple check to guess if sys$command is a decterm? */
4017     /* First see if the DECW$DISPLAY: device exists */
4018     items[0].len = 4;
4019     items[0].code = DVI$_DEVCHAR;
4020     items[0].bufadr = &devchar;
4021     items[0].retadr = NULL;
4022     items[1].len = 0;
4023     items[1].code = 0;
4024
4025     status = sys$getdviw
4026         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
4027
4028     if ($VMS_STATUS_SUCCESS(status)) {
4029         status = dvi_iosb[0];
4030     }
4031
4032     if (!$VMS_STATUS_SUCCESS(status)) {
4033         SETERRNO(EVMSERR, status);
4034         return -1;
4035     }
4036
4037     /* If it does, then for now assume that we are on a workstation */
4038     /* Now verify that SYS$COMMAND is a terminal */
4039     /* for creating the debugger DECTerm */
4040
4041     items[0].len = 4;
4042     items[0].code = DVI$_DEVCLASS;
4043     items[0].bufadr = &devclass;
4044     items[0].retadr = NULL;
4045     items[1].len = 0;
4046     items[1].code = 0;
4047
4048     status = sys$getdviw
4049         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
4050
4051     if ($VMS_STATUS_SUCCESS(status)) {
4052         status = dvi_iosb[0];
4053     }
4054
4055     if (!$VMS_STATUS_SUCCESS(status)) {
4056         SETERRNO(EVMSERR, status);
4057         return -1;
4058     }
4059     else {
4060         if (devclass == DC$_TERM) {
4061             return 0;
4062         }
4063     }
4064     return -1;
4065 }
4066
4067 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
4068 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
4069 {
4070     int status;
4071     int ret_stat;
4072     char * ret_char;
4073     char device_name[65];
4074     unsigned short device_name_len;
4075     struct dsc$descriptor_s customization_dsc;
4076     struct dsc$descriptor_s device_name_dsc;
4077     const char * cptr;
4078     char * tptr;
4079     char customization[200];
4080     char title[40];
4081     pInfo info = NULL;
4082     char mbx1[64];
4083     unsigned short p_chan;
4084     int n;
4085     unsigned short iosb[4];
4086     struct item_list_3 items[2];
4087     const char * cust_str =
4088         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
4089     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
4090                                           DSC$K_CLASS_S, mbx1};
4091
4092      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
4093     /*---------------------------------------*/
4094     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
4095
4096
4097     /* Make sure that this is from the Perl debugger */
4098     ret_char = strstr(cmd," xterm ");
4099     if (ret_char == NULL)
4100         return NULL;
4101     cptr = ret_char + 7;
4102     ret_char = strstr(cmd,"tty");
4103     if (ret_char == NULL)
4104         return NULL;
4105     ret_char = strstr(cmd,"sleep");
4106     if (ret_char == NULL)
4107         return NULL;
4108
4109     if (decw_term_port == 0) {
4110         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
4111         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
4112         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
4113
4114        status = lib$find_image_symbol
4115                                (&filename1_dsc,
4116                                 &decw_term_port_dsc,
4117                                 (void *)&decw_term_port,
4118                                 NULL,
4119                                 0);
4120
4121         /* Try again with the other image name */
4122         if (!$VMS_STATUS_SUCCESS(status)) {
4123
4124            status = lib$find_image_symbol
4125                                (&filename2_dsc,
4126                                 &decw_term_port_dsc,
4127                                 (void *)&decw_term_port,
4128                                 NULL,
4129                                 0);
4130
4131         }
4132
4133     }
4134
4135
4136     /* No decw$term_port, give it up */
4137     if (!$VMS_STATUS_SUCCESS(status))
4138         return NULL;
4139
4140     /* Are we on a workstation? */
4141     /* to do: capture the rows / columns and pass their properties */
4142     ret_stat = vms_is_syscommand_xterm();
4143     if (ret_stat < 0)
4144         return NULL;
4145
4146     /* Make the title: */
4147     ret_char = strstr(cptr,"-title");
4148     if (ret_char != NULL) {
4149         while ((*cptr != 0) && (*cptr != '\"')) {
4150             cptr++;
4151         }
4152         if (*cptr == '\"')
4153             cptr++;
4154         n = 0;
4155         while ((*cptr != 0) && (*cptr != '\"')) {
4156             title[n] = *cptr;
4157             n++;
4158             if (n == 39) {
4159                 title[39] == 0;
4160                 break;
4161             }
4162             cptr++;
4163         }
4164         title[n] = 0;
4165     }
4166     else {
4167             /* Default title */
4168             strcpy(title,"Perl Debug DECTerm");
4169     }
4170     sprintf(customization, cust_str, title);
4171
4172     customization_dsc.dsc$a_pointer = customization;
4173     customization_dsc.dsc$w_length = strlen(customization);
4174     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4175     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
4176
4177     device_name_dsc.dsc$a_pointer = device_name;
4178     device_name_dsc.dsc$w_length = sizeof device_name -1;
4179     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4180     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
4181
4182     device_name_len = 0;
4183
4184     /* Try to create the window */
4185      status = (*decw_term_port)
4186        (NULL,
4187         NULL,
4188         &customization_dsc,
4189         &device_name_dsc,
4190         &device_name_len,
4191         NULL,
4192         NULL,
4193         NULL);
4194     if (!$VMS_STATUS_SUCCESS(status)) {
4195         SETERRNO(EVMSERR, status);
4196         return NULL;
4197     }
4198
4199     device_name[device_name_len] = '\0';
4200
4201     /* Need to set this up to look like a pipe for cleanup */
4202     n = sizeof(Info);
4203     status = lib$get_vm(&n, &info);
4204     if (!$VMS_STATUS_SUCCESS(status)) {
4205         SETERRNO(ENOMEM, status);
4206         return NULL;
4207     }
4208
4209     info->mode = *mode;
4210     info->done = FALSE;
4211     info->completion = 0;
4212     info->closing    = FALSE;
4213     info->in         = 0;
4214     info->out        = 0;
4215     info->err        = 0;
4216     info->fp         = NULL;
4217     info->useFILE    = 0;
4218     info->waiting    = 0;
4219     info->in_done    = TRUE;
4220     info->out_done   = TRUE;
4221     info->err_done   = TRUE;
4222
4223     /* Assign a channel on this so that it will persist, and not login */
4224     /* We stash this channel in the info structure for reference. */
4225     /* The created xterm self destructs when the last channel is removed */
4226     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4227     /* So leave this assigned. */
4228     device_name_dsc.dsc$w_length = device_name_len;
4229     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4230     if (!$VMS_STATUS_SUCCESS(status)) {
4231         SETERRNO(EVMSERR, status);
4232         return NULL;
4233     }
4234     info->xchan_valid = 1;
4235
4236     /* Now create a mailbox to be read by the application */
4237
4238     create_mbx(&p_chan, &d_mbx1);
4239
4240     /* write the name of the created terminal to the mailbox */
4241     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4242             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4243
4244     if (!$VMS_STATUS_SUCCESS(status)) {
4245         SETERRNO(EVMSERR, status);
4246         return NULL;
4247     }
4248
4249     info->fp  = PerlIO_open(mbx1, mode);
4250
4251     /* Done with this channel */
4252     sys$dassgn(p_chan);
4253
4254     /* If any errors, then clean up */
4255     if (!info->fp) {
4256         n = sizeof(Info);
4257         _ckvmssts_noperl(lib$free_vm(&n, &info));
4258         return NULL;
4259         }
4260
4261     /* All done */
4262     return info->fp;
4263 }
4264
4265 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4266
4267 static PerlIO *
4268 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4269 {
4270     static int handler_set_up = FALSE;
4271     PerlIO * ret_fp;
4272     unsigned long int sts, flags = CLI$M_NOWAIT;
4273     /* The use of a GLOBAL table (as was done previously) rendered
4274      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4275      * environment.  Hence we've switched to LOCAL symbol table.
4276      */
4277     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4278     int j, wait = 0, n;
4279     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4280     char *in, *out, *err, mbx[512];
4281     FILE *tpipe = 0;
4282     char tfilebuf[NAM$C_MAXRSS+1];
4283     pInfo info = NULL;
4284     char cmd_sym_name[20];
4285     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4286                                       DSC$K_CLASS_S, symbol};
4287     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4288                                       DSC$K_CLASS_S, 0};
4289     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4290                                       DSC$K_CLASS_S, cmd_sym_name};
4291     struct dsc$descriptor_s *vmscmd;
4292     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4293     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4294     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4295
4296     /* Check here for Xterm create request.  This means looking for
4297      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4298      *  is possible to create an xterm.
4299      */
4300     if (*in_mode == 'r') {
4301         PerlIO * xterm_fd;
4302
4303 #if defined(PERL_IMPLICIT_CONTEXT)
4304         /* Can not fork an xterm with a NULL context */
4305         /* This probably could never happen */
4306         xterm_fd = NULL;
4307         if (aTHX != NULL)
4308 #endif
4309         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4310         if (xterm_fd != NULL)
4311             return xterm_fd;
4312     }
4313
4314     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4315
4316     /* once-per-program initialization...
4317        note that the SETAST calls and the dual test of pipe_ef
4318        makes sure that only the FIRST thread through here does
4319        the initialization...all other threads wait until it's
4320        done.
4321
4322        Yeah, uglier than a pthread call, it's got all the stuff inline
4323        rather than in a separate routine.
4324     */
4325
4326     if (!pipe_ef) {
4327         _ckvmssts_noperl(sys$setast(0));
4328         if (!pipe_ef) {
4329             unsigned long int pidcode = JPI$_PID;
4330             $DESCRIPTOR(d_delay, RETRY_DELAY);
4331             _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4332             _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4333             _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4334         }
4335         if (!handler_set_up) {
4336           _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4337           handler_set_up = TRUE;
4338         }
4339         _ckvmssts_noperl(sys$setast(1));
4340     }
4341
4342     /* see if we can find a VMSPIPE.COM */
4343
4344     tfilebuf[0] = '@';
4345     vmspipe = find_vmspipe(aTHX);
4346     if (vmspipe) {
4347         strcpy(tfilebuf+1,vmspipe);
4348     } else {        /* uh, oh...we're in tempfile hell */
4349         tpipe = vmspipe_tempfile(aTHX);
4350         if (!tpipe) {       /* a fish popular in Boston */
4351             if (ckWARN(WARN_PIPE)) {
4352                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4353             }
4354         return NULL;
4355         }
4356         fgetname(tpipe,tfilebuf+1,1);
4357     }
4358     vmspipedsc.dsc$a_pointer = tfilebuf;
4359     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4360
4361     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4362     if (!(sts & 1)) {
4363       switch (sts) {
4364         case RMS$_FNF:  case RMS$_DNF:
4365           set_errno(ENOENT); break;
4366         case RMS$_DIR:
4367           set_errno(ENOTDIR); break;
4368         case RMS$_DEV:
4369           set_errno(ENODEV); break;
4370         case RMS$_PRV:
4371           set_errno(EACCES); break;
4372         case RMS$_SYN:
4373           set_errno(EINVAL); break;
4374         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4375           set_errno(E2BIG); break;
4376         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4377           _ckvmssts_noperl(sts); /* fall through */
4378         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4379           set_errno(EVMSERR);
4380       }
4381       set_vaxc_errno(sts);
4382       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4383         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4384       }
4385       *psts = sts;
4386       return NULL;
4387     }
4388     n = sizeof(Info);
4389     _ckvmssts_noperl(lib$get_vm(&n, &info));
4390
4391     strcpy(mode,in_mode);
4392     info->mode = *mode;
4393     info->done = FALSE;
4394     info->completion = 0;
4395     info->closing    = FALSE;
4396     info->in         = 0;
4397     info->out        = 0;
4398     info->err        = 0;
4399     info->fp         = NULL;
4400     info->useFILE    = 0;
4401     info->waiting    = 0;
4402     info->in_done    = TRUE;
4403     info->out_done   = TRUE;
4404     info->err_done   = TRUE;
4405     info->xchan      = 0;
4406     info->xchan_valid = 0;
4407
4408     in = PerlMem_malloc(VMS_MAXRSS);
4409     if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4410     out = PerlMem_malloc(VMS_MAXRSS);
4411     if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4412     err = PerlMem_malloc(VMS_MAXRSS);
4413     if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4414
4415     in[0] = out[0] = err[0] = '\0';
4416
4417     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4418         info->useFILE = 1;
4419         strcpy(p,p+1);
4420     }
4421     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4422         wait = 1;
4423         strcpy(p,p+1);
4424     }
4425
4426     if (*mode == 'r') {             /* piping from subroutine */
4427
4428         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4429         if (info->out) {
4430             info->out->pipe_done = &info->out_done;
4431             info->out_done = FALSE;
4432             info->out->info = info;
4433         }
4434         if (!info->useFILE) {
4435             info->fp  = PerlIO_open(mbx, mode);
4436         } else {
4437             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4438             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4439         }
4440
4441         if (!info->fp && info->out) {
4442             sys$cancel(info->out->chan_out);
4443
4444             while (!info->out_done) {
4445                 int done;
4446                 _ckvmssts_noperl(sys$setast(0));
4447                 done = info->out_done;
4448                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4449                 _ckvmssts_noperl(sys$setast(1));
4450                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4451             }
4452
4453             if (info->out->buf) {
4454                 n = info->out->bufsize * sizeof(char);
4455                 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4456             }
4457             n = sizeof(Pipe);
4458             _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4459             n = sizeof(Info);
4460             _ckvmssts_noperl(lib$free_vm(&n, &info));
4461             *psts = RMS$_FNF;
4462             return NULL;
4463         }
4464
4465         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4466         if (info->err) {
4467             info->err->pipe_done = &info->err_done;
4468             info->err_done = FALSE;
4469             info->err->info = info;
4470         }
4471
4472     } else if (*mode == 'w') {      /* piping to subroutine */
4473
4474         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4475         if (info->out) {
4476             info->out->pipe_done = &info->out_done;
4477             info->out_done = FALSE;
4478             info->out->info = info;
4479         }
4480
4481         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4482         if (info->err) {
4483             info->err->pipe_done = &info->err_done;
4484             info->err_done = FALSE;
4485             info->err->info = info;
4486         }
4487
4488         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4489         if (!info->useFILE) {
4490             info->fp  = PerlIO_open(mbx, mode);
4491         } else {
4492             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4493             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4494         }
4495
4496         if (info->in) {
4497             info->in->pipe_done = &info->in_done;
4498             info->in_done = FALSE;
4499             info->in->info = info;
4500         }
4501
4502         /* error cleanup */
4503         if (!info->fp && info->in) {
4504             info->done = TRUE;
4505             _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4506                                       0, 0, 0, 0, 0, 0, 0, 0));
4507
4508             while (!info->in_done) {
4509                 int done;
4510                 _ckvmssts_noperl(sys$setast(0));
4511                 done = info->in_done;
4512                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4513                 _ckvmssts_noperl(sys$setast(1));
4514                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4515             }
4516
4517             if (info->in->buf) {
4518                 n = info->in->bufsize * sizeof(char);
4519                 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4520             }
4521             n = sizeof(Pipe);
4522             _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4523             n = sizeof(Info);
4524             _ckvmssts_noperl(lib$free_vm(&n, &info));
4525             *psts = RMS$_FNF;
4526             return NULL;
4527         }
4528
4529
4530     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4531         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4532         if (info->out) {
4533             info->out->pipe_done = &info->out_done;
4534             info->out_done = FALSE;
4535             info->out->info = info;
4536         }
4537
4538         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4539         if (info->err) {
4540             info->err->pipe_done = &info->err_done;
4541             info->err_done = FALSE;
4542             info->err->info = info;
4543         }
4544     }
4545
4546     symbol[MAX_DCL_SYMBOL] = '\0';
4547
4548     strncpy(symbol, in, MAX_DCL_SYMBOL);
4549     d_symbol.dsc$w_length = strlen(symbol);
4550     _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4551
4552     strncpy(symbol, err, MAX_DCL_SYMBOL);
4553     d_symbol.dsc$w_length = strlen(symbol);
4554     _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4555
4556     strncpy(symbol, out, MAX_DCL_SYMBOL);
4557     d_symbol.dsc$w_length = strlen(symbol);
4558     _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4559
4560     /* Done with the names for the pipes */
4561     PerlMem_free(err);
4562     PerlMem_free(out);
4563     PerlMem_free(in);
4564
4565     p = vmscmd->dsc$a_pointer;
4566     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4567     if (*p == '$') p++;                         /* remove leading $ */
4568     while (*p == ' ' || *p == '\t') p++;
4569
4570     for (j = 0; j < 4; j++) {
4571         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4572         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4573
4574     strncpy(symbol, p, MAX_DCL_SYMBOL);
4575     d_symbol.dsc$w_length = strlen(symbol);
4576     _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4577
4578         if (strlen(p) > MAX_DCL_SYMBOL) {
4579             p += MAX_DCL_SYMBOL;
4580         } else {
4581             p += strlen(p);
4582         }
4583     }
4584     _ckvmssts_noperl(sys$setast(0));
4585     info->next=open_pipes;  /* prepend to list */
4586     open_pipes=info;
4587     _ckvmssts_noperl(sys$setast(1));
4588     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4589      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4590      * have SYS$COMMAND if we need it.
4591      */
4592     _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4593                       0, &info->pid, &info->completion,
4594                       0, popen_completion_ast,info,0,0,0));
4595
4596     /* if we were using a tempfile, close it now */
4597
4598     if (tpipe) fclose(tpipe);
4599
4600     /* once the subprocess is spawned, it has copied the symbols and
4601        we can get rid of ours */
4602
4603     for (j = 0; j < 4; j++) {
4604         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4605         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4606     _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4607     }
4608     _ckvmssts_noperl(lib$delete_symbol(&d_sym_in,  &table));
4609     _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4610     _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4611     vms_execfree(vmscmd);
4612
4613 #ifdef PERL_IMPLICIT_CONTEXT
4614     if (aTHX)
4615 #endif
4616     PL_forkprocess = info->pid;
4617
4618     ret_fp = info->fp;
4619     if (wait) {
4620          dSAVEDERRNO;
4621          int done = 0;
4622          while (!done) {
4623              _ckvmssts_noperl(sys$setast(0));
4624              done = info->done;
4625              if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4626              _ckvmssts_noperl(sys$setast(1));
4627              if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4628          }
4629         *psts = info->completion;
4630 /* Caller thinks it is open and tries to close it. */
4631 /* This causes some problems, as it changes the error status */
4632 /*        my_pclose(info->fp); */
4633
4634          /* If we did not have a file pointer open, then we have to */
4635          /* clean up here or eventually we will run out of something */
4636          SAVE_ERRNO;
4637          if (info->fp == NULL) {
4638              my_pclose_pinfo(aTHX_ info);
4639          }
4640          RESTORE_ERRNO;
4641
4642     } else {
4643         *psts = info->pid;
4644     }
4645     return ret_fp;
4646 }  /* end of safe_popen */
4647
4648
4649 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4650 PerlIO *
4651 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4652 {
4653     int sts;
4654     TAINT_ENV();
4655     TAINT_PROPER("popen");
4656     PERL_FLUSHALL_FOR_CHILD;
4657     return safe_popen(aTHX_ cmd,mode,&sts);
4658 }
4659
4660 /*}}}*/
4661
4662
4663 /* Routine to close and cleanup a pipe info structure */
4664
4665 static I32 my_pclose_pinfo(pTHX_ pInfo info) {
4666
4667     unsigned long int retsts;
4668     int done, iss, n;
4669     int status;
4670     pInfo next, last;
4671
4672     /* If we were writing to a subprocess, insure that someone reading from
4673      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4674      * produce an EOF record in the mailbox.
4675      *
4676      *  well, at least sometimes it *does*, so we have to watch out for
4677      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4678      */
4679      if (info->fp) {
4680         if (!info->useFILE
4681 #if defined(USE_ITHREADS)
4682           && my_perl
4683 #endif
4684           && PL_perlio_fd_refcnt)
4685             PerlIO_flush(info->fp);
4686         else
4687             fflush((FILE *)info->fp);
4688     }
4689
4690     _ckvmssts(sys$setast(0));
4691      info->closing = TRUE;
4692      done = info->done && info->in_done && info->out_done && info->err_done;
4693      /* hanging on write to Perl's input? cancel it */
4694      if (info->mode == 'r' && info->out && !info->out_done) {
4695         if (info->out->chan_out) {
4696             _ckvmssts(sys$cancel(info->out->chan_out));
4697             if (!info->out->chan_in) {   /* EOF generation, need AST */
4698                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4699             }
4700         }
4701      }
4702      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4703          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4704                            0, 0, 0, 0, 0, 0));
4705     _ckvmssts(sys$setast(1));
4706     if (info->fp) {
4707      if (!info->useFILE
4708 #if defined(USE_ITHREADS)
4709          && my_perl
4710 #endif
4711          && PL_perlio_fd_refcnt)
4712         PerlIO_close(info->fp);
4713      else
4714         fclose((FILE *)info->fp);
4715     }
4716      /*
4717         we have to wait until subprocess completes, but ALSO wait until all
4718         the i/o completes...otherwise we'll be freeing the "info" structure
4719         that the i/o ASTs could still be using...
4720      */
4721
4722      while (!done) {
4723          _ckvmssts(sys$setast(0));
4724          done = info->done && info->in_done && info->out_done && info->err_done;
4725          if (!done) _ckvmssts(sys$clref(pipe_ef));
4726          _ckvmssts(sys$setast(1));
4727          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4728      }
4729      retsts = info->completion;
4730
4731     /* remove from list of open pipes */
4732     _ckvmssts(sys$setast(0));
4733     last = NULL;
4734     for (next = open_pipes; next != NULL; last = next, next = next->next) {
4735         if (next == info)
4736             break;
4737     }
4738
4739     if (last)
4740         last->next = info->next;
4741     else
4742         open_pipes = info->next;
4743     _ckvmssts(sys$setast(1));
4744
4745     /* free buffers and structures */
4746
4747     if (info->in) {
4748         if (info->in->buf) {
4749             n = info->in->bufsize * sizeof(char);
4750             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4751         }
4752         n = sizeof(Pipe);
4753         _ckvmssts(lib$free_vm(&n, &info->in));
4754     }
4755     if (info->out) {
4756         if (info->out->buf) {
4757             n = info->out->bufsize * sizeof(char);
4758             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4759         }
4760         n = sizeof(Pipe);
4761         _ckvmssts(lib$free_vm(&n, &info->out));
4762     }
4763     if (info->err) {
4764         if (info->err->buf) {
4765             n = info->err->bufsize * sizeof(char);
4766             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4767         }
4768         n = sizeof(Pipe);
4769         _ckvmssts(lib$free_vm(&n, &info->err));
4770     }
4771     n = sizeof(Info);
4772     _ckvmssts(lib$free_vm(&n, &info));
4773
4774     return retsts;
4775 }
4776
4777
4778 /*{{{  I32 my_pclose(PerlIO *fp)*/
4779 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4780 {
4781     pInfo info, last = NULL;
4782     I32 ret_status;
4783
4784     /* Fixme - need ast and mutex protection here */
4785     for (info = open_pipes; info != NULL; last = info, info = info->next)
4786         if (info->fp == fp) break;
4787
4788     if (info == NULL) {  /* no such pipe open */
4789       set_errno(ECHILD); /* quoth POSIX */
4790       set_vaxc_errno(SS$_NONEXPR);
4791       return -1;
4792     }
4793
4794     ret_status = my_pclose_pinfo(aTHX_ info);
4795
4796     return ret_status;
4797
4798 }  /* end of my_pclose() */
4799
4800 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4801   /* Roll our own prototype because we want this regardless of whether
4802    * _VMS_WAIT is defined.
4803    */
4804   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4805 #endif
4806 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4807    created with popen(); otherwise partially emulate waitpid() unless
4808    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4809    Also check processes not considered by the CRTL waitpid().
4810  */
4811 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4812 Pid_t
4813 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4814 {
4815     pInfo info;
4816     int done;
4817     int sts;
4818     int j;
4819
4820     if (statusp) *statusp = 0;
4821
4822     for (info = open_pipes; info != NULL; info = info->next)
4823         if (info->pid == pid) break;
4824
4825     if (info != NULL) {  /* we know about this child */
4826       while (!info->done) {
4827           _ckvmssts(sys$setast(0));
4828           done = info->done;
4829           if (!done) _ckvmssts(sys$clref(pipe_ef));
4830           _ckvmssts(sys$setast(1));
4831           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4832       }
4833
4834       if (statusp) *statusp = info->completion;
4835       return pid;
4836     }
4837
4838     /* child that already terminated? */
4839
4840     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4841         if (closed_list[j].pid == pid) {
4842             if (statusp) *statusp = closed_list[j].completion;
4843             return pid;
4844         }
4845     }
4846
4847     /* fall through if this child is not one of our own pipe children */
4848
4849 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4850
4851       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4852        * in 7.2 did we get a version that fills in the VMS completion
4853        * status as Perl has always tried to do.
4854        */
4855
4856       sts = __vms_waitpid( pid, statusp, flags );
4857
4858       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4859          return sts;
4860
4861       /* If the real waitpid tells us the child does not exist, we
4862        * fall through here to implement waiting for a child that
4863        * was created by some means other than exec() (say, spawned
4864        * from DCL) or to wait for a process that is not a subprocess
4865        * of the current process.
4866        */
4867
4868 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4869
4870     {
4871       $DESCRIPTOR(intdsc,"0 00:00:01");
4872       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4873       unsigned long int pidcode = JPI$_PID, mypid;
4874       unsigned long int interval[2];
4875       unsigned int jpi_iosb[2];
4876       struct itmlst_3 jpilist[2] = {
4877           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4878           {                      0,         0,                 0, 0}
4879       };
4880
4881       if (pid <= 0) {
4882         /* Sorry folks, we don't presently implement rooting around for
4883            the first child we can find, and we definitely don't want to
4884            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4885          */
4886         set_errno(ENOTSUP);
4887         return -1;
4888       }
4889
4890       /* Get the owner of the child so I can warn if it's not mine. If the
4891        * process doesn't exist or I don't have the privs to look at it,
4892        * I can go home early.
4893        */
4894       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4895       if (sts & 1) sts = jpi_iosb[0];
4896       if (!(sts & 1)) {
4897         switch (sts) {
4898             case SS$_NONEXPR:
4899                 set_errno(ECHILD);
4900                 break;
4901             case SS$_NOPRIV:
4902                 set_errno(EACCES);
4903                 break;
4904             default:
4905                 _ckvmssts(sts);
4906         }
4907         set_vaxc_errno(sts);
4908         return -1;
4909       }
4910
4911       if (ckWARN(WARN_EXEC)) {
4912         /* remind folks they are asking for non-standard waitpid behavior */
4913         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4914         if (ownerpid != mypid)
4915           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4916                       "waitpid: process %x is not a child of process %x",
4917                       pid,mypid);
4918       }
4919
4920       /* simply check on it once a second until it's not there anymore. */
4921
4922       _ckvmssts(sys$bintim(&intdsc,interval));
4923       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4924             _ckvmssts(sys$schdwk(0,0,interval,0));
4925             _ckvmssts(sys$hiber());
4926       }
4927       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4928
4929       _ckvmssts(sts);
4930       return pid;
4931     }
4932 }  /* end of waitpid() */
4933 /*}}}*/
4934 /*}}}*/
4935 /*}}}*/
4936
4937 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4938 char *
4939 my_gconvert(double val, int ndig, int trail, char *buf)
4940 {
4941   static char __gcvtbuf[DBL_DIG+1];
4942   char *loc;
4943
4944   loc = buf ? buf : __gcvtbuf;
4945
4946 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4947   if (val < 1) {
4948     sprintf(loc,"%.*g",ndig,val);
4949     return loc;
4950   }
4951 #endif
4952
4953   if (val) {
4954     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4955     return gcvt(val,ndig,loc);
4956   }
4957   else {
4958     loc[0] = '0'; loc[1] = '\0';
4959     return loc;
4960   }
4961
4962 }
4963 /*}}}*/
4964
4965 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4966 static int rms_free_search_context(struct FAB * fab)
4967 {
4968 struct NAM * nam;
4969
4970     nam = fab->fab$l_nam;
4971     nam->nam$b_nop |= NAM$M_SYNCHK;
4972     nam->nam$l_rlf = NULL;
4973     fab->fab$b_dns = 0;
4974     return sys$parse(fab, NULL, NULL);
4975 }
4976
4977 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4978 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4979 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4980 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4981 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4982 #define rms_nam_esll(nam) nam.nam$b_esl
4983 #define rms_nam_esl(nam) nam.nam$b_esl
4984 #define rms_nam_name(nam) nam.nam$l_name
4985 #define rms_nam_namel(nam) nam.nam$l_name
4986 #define rms_nam_type(nam) nam.nam$l_type
4987 #define rms_nam_typel(nam) nam.nam$l_type
4988 #define rms_nam_ver(nam) nam.nam$l_ver
4989 #define rms_nam_verl(nam) nam.nam$l_ver
4990 #define rms_nam_rsll(nam) nam.nam$b_rsl
4991 #define rms_nam_rsl(nam) nam.nam$b_rsl
4992 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4993 #define rms_set_fna(fab, nam, name, size) \
4994         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4995 #define rms_get_fna(fab, nam) fab.fab$l_fna
4996 #define rms_set_dna(fab, nam, name, size) \
4997         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4998 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4999 #define rms_set_esa(nam, name, size) \
5000         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
5001 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
5002         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
5003 #define rms_set_rsa(nam, name, size) \
5004         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
5005 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
5006         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
5007 #define rms_nam_name_type_l_size(nam) \
5008         (nam.nam$b_name + nam.nam$b_type)
5009 #else
5010 static int rms_free_search_context(struct FAB * fab)
5011 {
5012 struct NAML * nam;
5013
5014     nam = fab->fab$l_naml;
5015     nam->naml$b_nop |= NAM$M_SYNCHK;
5016     nam->naml$l_rlf = NULL;
5017     nam->naml$l_long_defname_size = 0;
5018
5019     fab->fab$b_dns = 0;
5020     return sys$parse(fab, NULL, NULL);
5021 }
5022
5023 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
5024 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
5025 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
5026 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
5027 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
5028 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
5029 #define rms_nam_esl(nam) nam.naml$b_esl
5030 #define rms_nam_name(nam) nam.naml$l_name
5031 #define rms_nam_namel(nam) nam.naml$l_long_name
5032 #define rms_nam_type(nam) nam.naml$l_type
5033 #define rms_nam_typel(nam) nam.naml$l_long_type
5034 #define rms_nam_ver(nam) nam.naml$l_ver
5035 #define rms_nam_verl(nam) nam.naml$l_long_ver
5036 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
5037 #define rms_nam_rsl(nam) nam.naml$b_rsl
5038 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
5039 #define rms_set_fna(fab, nam, name, size) \
5040         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
5041         nam.naml$l_long_filename_size = size; \
5042         nam.naml$l_long_filename = name;}
5043 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
5044 #define rms_set_dna(fab, nam, name, size) \
5045         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
5046         nam.naml$l_long_defname_size = size; \
5047         nam.naml$l_long_defname = name; }
5048 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
5049 #define rms_set_esa(nam, name, size) \
5050         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
5051         nam.naml$l_long_expand_alloc = size; \
5052         nam.naml$l_long_expand = name; }
5053 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
5054         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
5055         nam.naml$l_long_expand = l_name; \
5056         nam.naml$l_long_expand_alloc = l_size; }
5057 #define rms_set_rsa(nam, name, size) \
5058         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
5059         nam.naml$l_long_result = name; \
5060         nam.naml$l_long_result_alloc = size; }
5061 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
5062         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
5063         nam.naml$l_long_result = l_name; \
5064         nam.naml$l_long_result_alloc = l_size; }
5065 #define rms_nam_name_type_l_size(nam) \
5066         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
5067 #endif
5068
5069
5070 /* rms_erase
5071  * The CRTL for 8.3 and later can create symbolic links in any mode,
5072  * however in 8.3 the unlink/remove/delete routines will only properly handle
5073  * them if one of the PCP modes is active.
5074  */
5075 static int rms_erase(const char * vmsname)
5076 {
5077   int status;
5078   struct FAB myfab = cc$rms_fab;
5079   rms_setup_nam(mynam);
5080
5081   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
5082   rms_bind_fab_nam(myfab, mynam);
5083
5084 #ifdef NAML$M_OPEN_SPECIAL
5085   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5086 #endif
5087
5088   status = sys$erase(&myfab, 0, 0);
5089
5090   return status;
5091 }
5092
5093
5094 static int
5095 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
5096                     const struct dsc$descriptor_s * vms_dst_dsc,
5097                     unsigned long flags)
5098 {
5099     /*  VMS and UNIX handle file permissions differently and the
5100      * the same ACL trick may be needed for renaming files,
5101      * especially if they are directories.
5102      */
5103
5104    /* todo: get kill_file and rename to share common code */
5105    /* I can not find online documentation for $change_acl
5106     * it appears to be replaced by $set_security some time ago */
5107
5108 const unsigned int access_mode = 0;
5109 $DESCRIPTOR(obj_file_dsc,"FILE");
5110 char *vmsname;
5111 char *rslt;
5112 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
5113 int aclsts, fndsts, rnsts = -1;
5114 unsigned int ctx = 0;
5115 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5116 struct dsc$descriptor_s * clean_dsc;
5117
5118 struct myacedef {
5119     unsigned char myace$b_length;
5120     unsigned char myace$b_type;
5121     unsigned short int myace$w_flags;
5122     unsigned long int myace$l_access;
5123     unsigned long int myace$l_ident;
5124 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
5125              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
5126              0},
5127              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
5128
5129 struct item_list_3
5130         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
5131                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
5132                       {0,0,0,0}},
5133         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
5134         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
5135                      {0,0,0,0}};
5136
5137
5138     /* Expand the input spec using RMS, since we do not want to put
5139      * ACLs on the target of a symbolic link */
5140     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
5141     if (vmsname == NULL)
5142         return SS$_INSFMEM;
5143
5144     rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
5145                         vmsname,
5146                         PERL_RMSEXPAND_M_SYMLINK);
5147     if (rslt == NULL) {
5148         PerlMem_free(vmsname);
5149         return SS$_INSFMEM;
5150     }
5151
5152     /* So we get our own UIC to use as a rights identifier,
5153      * and the insert an ACE at the head of the ACL which allows us
5154      * to delete the file.
5155      */
5156     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
5157
5158     fildsc.dsc$w_length = strlen(vmsname);
5159     fildsc.dsc$a_pointer = vmsname;
5160     ctx = 0;
5161     newace.myace$l_ident = oldace.myace$l_ident;
5162     rnsts = SS$_ABORT;
5163
5164     /* Grab any existing ACEs with this identifier in case we fail */
5165     clean_dsc = &fildsc;
5166     aclsts = fndsts = sys$get_security(&obj_file_dsc,
5167                                &fildsc,
5168                                NULL,
5169                                OSS$M_WLOCK,
5170                                findlst,
5171                                &ctx,
5172                                &access_mode);
5173
5174     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
5175         /* Add the new ACE . . . */
5176
5177         /* if the sys$get_security succeeded, then ctx is valid, and the
5178          * object/file descriptors will be ignored.  But otherwise they
5179          * are needed
5180          */
5181         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
5182                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
5183         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5184             set_errno(EVMSERR);
5185             set_vaxc_errno(aclsts);
5186             PerlMem_free(vmsname);
5187             return aclsts;
5188         }
5189
5190         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5191                                 NULL, NULL,
5192                                 &flags,
5193                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5194
5195         if ($VMS_STATUS_SUCCESS(rnsts)) {
5196             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5197         }
5198
5199         /* Put things back the way they were. */
5200         ctx = 0;
5201         aclsts = sys$get_security(&obj_file_dsc,
5202                                   clean_dsc,
5203                                   NULL,
5204                                   OSS$M_WLOCK,
5205                                   findlst,
5206                                   &ctx,
5207                                   &access_mode);
5208
5209         if ($VMS_STATUS_SUCCESS(aclsts)) {
5210         int sec_flags;
5211
5212             sec_flags = 0;
5213             if (!$VMS_STATUS_SUCCESS(fndsts))
5214                 sec_flags = OSS$M_RELCTX;
5215
5216             /* Get rid of the new ACE */
5217             aclsts = sys$set_security(NULL, NULL, NULL,
5218                                   sec_flags, dellst, &ctx, &access_mode);
5219
5220             /* If there was an old ACE, put it back */
5221             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5222                 addlst[0].bufadr = &oldace;
5223                 aclsts = sys$set_security(NULL, NULL, NULL,
5224                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
5225                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5226                     set_errno(EVMSERR);
5227                     set_vaxc_errno(aclsts);
5228                     rnsts = aclsts;
5229                 }
5230             } else {
5231             int aclsts2;
5232
5233                 /* Try to clear the lock on the ACL list */
5234                 aclsts2 = sys$set_security(NULL, NULL, NULL,
5235                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
5236
5237                 /* Rename errors are most important */
5238                 if (!$VMS_STATUS_SUCCESS(rnsts))
5239                     aclsts = rnsts;
5240                 set_errno(EVMSERR);
5241                 set_vaxc_errno(aclsts);
5242                 rnsts = aclsts;
5243             }
5244         }
5245         else {
5246             if (aclsts != SS$_ACLEMPTY)
5247                 rnsts = aclsts;
5248         }
5249     }
5250     else
5251         rnsts = fndsts;
5252
5253     PerlMem_free(vmsname);
5254     return rnsts;
5255 }
5256
5257
5258 /*{{{int rename(const char *, const char * */
5259 /* Not exactly what X/Open says to do, but doing it absolutely right
5260  * and efficiently would require a lot more work.  This should be close
5261  * enough to pass all but the most strict X/Open compliance test.
5262  */
5263 int
5264 Perl_rename(pTHX_ const char *src, const char * dst)
5265 {
5266 int retval;
5267 int pre_delete = 0;
5268 int src_sts;
5269 int dst_sts;
5270 Stat_t src_st;
5271 Stat_t dst_st;
5272
5273     /* Validate the source file */
5274     src_sts = flex_lstat(src, &src_st);
5275     if (src_sts != 0) {
5276
5277         /* No source file or other problem */
5278         return src_sts;
5279     }
5280     if (src_st.st_devnam[0] == 0)  {
5281         /* This may be possible so fail if it is seen. */
5282         errno = EIO;
5283         return -1;
5284     }
5285
5286     dst_sts = flex_lstat(dst, &dst_st);
5287     if (dst_sts == 0) {
5288
5289         if (dst_st.st_dev != src_st.st_dev) {
5290             /* Must be on the same device */
5291             errno = EXDEV;
5292             return -1;
5293         }
5294
5295         /* VMS_INO_T_COMPARE is true if the inodes are different
5296          * to match the output of memcmp
5297          */
5298
5299         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5300             /* That was easy, the files are the same! */
5301             return 0;
5302         }
5303
5304         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5305             /* If source is a directory, so must be dest */
5306                 errno = EISDIR;
5307                 return -1;
5308         }
5309
5310     }
5311
5312
5313     if ((dst_sts == 0) &&
5314         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5315
5316         /* We have issues here if vms_unlink_all_versions is set
5317          * If the destination exists, and is not a directory, then
5318          * we must delete in advance.
5319          *
5320          * If the src is a directory, then we must always pre-delete
5321          * the destination.
5322          *
5323          * If we successfully delete the dst in advance, and the rename fails
5324          * X/Open requires that errno be EIO.
5325          *
5326          */
5327
5328         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5329             int d_sts;
5330             d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam,
5331                                      S_ISDIR(dst_st.st_mode));
5332
5333            /* Need to delete all versions ? */
5334            if ((d_sts == 0) && (vms_unlink_all_versions == 1)) {
5335                 int i = 0;
5336
5337                 while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) {
5338                     d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 0);
5339                     if (d_sts != 0)
5340                         break;
5341                     i++;
5342
5343                     /* Make sure that we do not loop forever */
5344                     if (i > 32767) {
5345                         errno = EIO;
5346                         d_sts = -1;
5347                         break;
5348                     }
5349                 }
5350            }
5351
5352             if (d_sts != 0)
5353                 return d_sts;
5354
5355             /* We killed the destination, so only errno now is EIO */
5356             pre_delete = 1;
5357         }
5358     }
5359
5360     /* Originally the idea was to call the CRTL rename() and only
5361      * try the lib$rename_file if it failed.
5362      * It turns out that there are too many variants in what the
5363      * the CRTL rename might do, so only use lib$rename_file
5364      */
5365     retval = -1;
5366
5367     {
5368         /* Is the source and dest both in VMS format */
5369         /* if the source is a directory, then need to fileify */
5370         /*  and dest must be a directory or non-existant. */
5371
5372         char * vms_dst;
5373         int sts;
5374         char * ret_str;
5375         unsigned long flags;
5376         struct dsc$descriptor_s old_file_dsc;
5377         struct dsc$descriptor_s new_file_dsc;
5378
5379         /* We need to modify the src and dst depending
5380          * on if one or more of them are directories.
5381          */
5382
5383         vms_dst = PerlMem_malloc(VMS_MAXRSS);
5384         if (vms_dst == NULL)
5385             _ckvmssts_noperl(SS$_INSFMEM);
5386
5387         if (S_ISDIR(src_st.st_mode)) {
5388         char * ret_str;
5389         char * vms_dir_file;
5390
5391             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5392             if (vms_dir_file == NULL)
5393                 _ckvmssts_noperl(SS$_INSFMEM);
5394
5395             /* If the dest is a directory, we must remove it
5396             if (dst_sts == 0) {
5397                 int d_sts;
5398                 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1);
5399                 if (d_sts != 0) {
5400                     PerlMem_free(vms_dst);
5401                     errno = EIO;
5402                     return sts;
5403                 }
5404
5405                 pre_delete = 1;
5406             }
5407
5408            /* The dest must be a VMS file specification */
5409            ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5410            if (ret_str == NULL) {
5411                 PerlMem_free(vms_dst);
5412                 errno = EIO;
5413                 return -1;
5414            }
5415
5416             /* The source must be a file specification */
5417             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5418             if (vms_dir_file == NULL)
5419                 _ckvmssts_noperl(SS$_INSFMEM);
5420
5421             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5422             if (ret_str == NULL) {
5423                 PerlMem_free(vms_dst);
5424                 PerlMem_free(vms_dir_file);
5425                 errno = EIO;
5426                 return -1;
5427             }
5428             PerlMem_free(vms_dst);
5429             vms_dst = vms_dir_file;
5430
5431         } else {
5432             /* File to file or file to new dir */
5433
5434             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5435                 /* VMS pathify a dir target */
5436                 ret_str = int_tovmspath(dst, vms_dst, NULL);
5437                 if (ret_str == NULL) {
5438                     PerlMem_free(vms_dst);
5439                     errno = EIO;
5440                     return -1;
5441                 }
5442             } else {
5443                 char * v_spec, * r_spec, * d_spec, * n_spec;
5444                 char * e_spec, * vs_spec;
5445                 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5446
5447                 /* fileify a target VMS file specification */
5448                 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5449                 if (ret_str == NULL) {
5450                     PerlMem_free(vms_dst);
5451                     errno = EIO;
5452                     return -1;
5453                 }
5454
5455                 sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len,
5456                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5457                              &e_len, &vs_spec, &vs_len);
5458                 if (sts == 0) {
5459                      if (e_len == 0) {
5460                          /* Get rid of the version */
5461                          if (vs_len != 0) {
5462                              *vs_spec = '\0';
5463                          }
5464                          /* Need to specify a '.' so that the extension */
5465                          /* is not inherited */
5466                          strcat(vms_dst,".");
5467                      }
5468                 }
5469             }
5470         }
5471
5472         old_file_dsc.dsc$a_pointer = src_st.st_devnam;
5473         old_file_dsc.dsc$w_length = strlen(src_st.st_devnam);
5474         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5475         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5476
5477         new_file_dsc.dsc$a_pointer = vms_dst;
5478         new_file_dsc.dsc$w_length = strlen(vms_dst);
5479         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5480         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5481
5482         flags = 0;
5483 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5484         flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5485 #endif
5486
5487         sts = lib$rename_file(&old_file_dsc,
5488                               &new_file_dsc,
5489                               NULL, NULL,
5490                               &flags,
5491                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5492         if (!$VMS_STATUS_SUCCESS(sts)) {
5493
5494            /* We could have failed because VMS style permissions do not
5495             * permit renames that UNIX will allow.  Just like the hack
5496             * in for kill_file.
5497             */
5498            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5499         }
5500
5501         PerlMem_free(vms_dst);
5502         if (!$VMS_STATUS_SUCCESS(sts)) {
5503             errno = EIO;
5504             return -1;
5505         }
5506         retval = 0;
5507     }
5508
5509     if (vms_unlink_all_versions) {
5510         /* Now get rid of any previous versions of the source file that
5511          * might still exist
5512          */
5513         int i = 0;
5514         dSAVEDERRNO;
5515         SAVE_ERRNO;
5516         src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5517                                    S_ISDIR(src_st.st_mode));
5518         while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) {
5519              src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5520                                        S_ISDIR(src_st.st_mode));
5521              if (src_sts != 0)
5522                  break;
5523              i++;
5524
5525              /* Make sure that we do not loop forever */
5526              if (i > 32767) {
5527                  src_sts = -1;
5528                  break;
5529              }
5530         }
5531         RESTORE_ERRNO;
5532     }
5533
5534     /* We deleted the destination, so must force the error to be EIO */
5535     if ((retval != 0) && (pre_delete != 0))
5536         errno = EIO;
5537
5538     return retval;
5539 }
5540 /*}}}*/
5541
5542
5543 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5544 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5545  * to expand file specification.  Allows for a single default file
5546  * specification and a simple mask of options.  If outbuf is non-NULL,
5547  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5548  * the resultant file specification is placed.  If outbuf is NULL, the
5549  * resultant file specification is placed into a static buffer.
5550  * The third argument, if non-NULL, is taken to be a default file
5551  * specification string.  The fourth argument is unused at present.
5552  * rmesexpand() returns the address of the resultant string if
5553  * successful, and NULL on error.
5554  *
5555  * New functionality for previously unused opts value:
5556  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5557  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5558  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5559  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5560  */
5561 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5562
5563 static char *
5564 int_rmsexpand
5565    (const char *filespec,
5566     char *outbuf,
5567     const char *defspec,
5568     unsigned opts,
5569     int * fs_utf8,
5570     int * dfs_utf8)
5571 {
5572   char * ret_spec;
5573   const char * in_spec;
5574   char * spec_buf;
5575   const char * def_spec;
5576   char * vmsfspec, *vmsdefspec;
5577   char * esa;
5578   char * esal = NULL;
5579   char * outbufl;
5580   struct FAB myfab = cc$rms_fab;
5581   rms_setup_nam(mynam);
5582   STRLEN speclen;
5583   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5584   int sts;
5585
5586   /* temp hack until UTF8 is actually implemented */
5587   if (fs_utf8 != NULL)
5588     *fs_utf8 = 0;
5589
5590   if (!filespec || !*filespec) {
5591     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5592     return NULL;
5593   }
5594
5595   vmsfspec = NULL;
5596   vmsdefspec = NULL;
5597   outbufl = NULL;
5598
5599   in_spec = filespec;
5600   isunix = 0;
5601   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5602       char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5603       int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5604
5605       /* If this is a UNIX file spec, convert it to VMS */
5606       sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5607                            &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5608                            &e_len, &vs_spec, &vs_len);
5609       if (sts != 0) {
5610           isunix = 1;
5611           char * ret_spec;
5612
5613           vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5614           if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5615           ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5616           if (ret_spec == NULL) {
5617               PerlMem_free(vmsfspec);
5618               return NULL;
5619           }
5620           in_spec = (const char *)vmsfspec;
5621
5622           /* Unless we are forcing to VMS format, a UNIX input means
5623            * UNIX output, and that requires long names to be used
5624            */
5625           if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5626 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5627               opts |= PERL_RMSEXPAND_M_LONG;
5628 #endif
5629           else
5630               isunix = 0;
5631       }
5632
5633   }
5634
5635   rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
5636   rms_bind_fab_nam(myfab, mynam);
5637
5638   /* Process the default file specification if present */
5639   def_spec = defspec;
5640   if (defspec && *defspec) {
5641     int t_isunix;
5642     t_isunix = is_unix_filespec(defspec);
5643     if (t_isunix) {
5644       vmsdefspec = PerlMem_malloc(VMS_MAXRSS);
5645       if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5646       ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5647
5648       if (ret_spec == NULL) {
5649           /* Clean up and bail */
5650           PerlMem_free(vmsdefspec);
5651           if (vmsfspec != NULL)
5652               PerlMem_free(vmsfspec);
5653               return NULL;
5654           }
5655           def_spec = (const char *)vmsdefspec;
5656       }
5657       rms_set_dna(myfab, mynam,
5658                   (char *)def_spec, strlen(def_spec)); /* cast ok */
5659   }
5660
5661   /* Now we need the expansion buffers */
5662   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5663   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5664 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5665   esal = PerlMem_malloc(VMS_MAXRSS);
5666   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5667 #endif
5668   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5669
5670   /* If a NAML block is used RMS always writes to the long and short
5671    * addresses unless you suppress the short name.
5672    */
5673 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5674   outbufl = PerlMem_malloc(VMS_MAXRSS);
5675   if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5676 #endif
5677    rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5678
5679 #ifdef NAM$M_NO_SHORT_UPCASE
5680   if (decc_efs_case_preserve)
5681     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5682 #endif
5683
5684    /* We may not want to follow symbolic links */
5685 #ifdef NAML$M_OPEN_SPECIAL
5686   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5687     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5688 #endif
5689
5690   /* First attempt to parse as an existing file */
5691   retsts = sys$parse(&myfab,0,0);
5692   if (!(retsts & STS$K_SUCCESS)) {
5693
5694     /* Could not find the file, try as syntax only if error is not fatal */
5695     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5696     if (retsts == RMS$_DNF ||
5697         retsts == RMS$_DIR ||
5698         retsts == RMS$_DEV ||
5699         retsts == RMS$_PRV) {
5700       retsts = sys$parse(&myfab,0,0);
5701       if (retsts & STS$K_SUCCESS) goto int_expanded;
5702     }
5703
5704      /* Still could not parse the file specification */
5705     /*----------------------------------------------*/
5706     sts = rms_free_search_context(&myfab); /* Free search context */
5707     if (vmsdefspec != NULL)
5708         PerlMem_free(vmsdefspec);
5709     if (vmsfspec != NULL)
5710         PerlMem_free(vmsfspec);
5711     if (outbufl != NULL)
5712         PerlMem_free(outbufl);
5713     PerlMem_free(esa);
5714     if (esal != NULL)
5715         PerlMem_free(esal);
5716     set_vaxc_errno(retsts);
5717     if      (retsts == RMS$_PRV) set_errno(EACCES);
5718     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5719     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5720     else                         set_errno(EVMSERR);
5721     return NULL;
5722   }
5723   retsts = sys$search(&myfab,0,0);
5724   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5725     sts = rms_free_search_context(&myfab); /* Free search context */
5726     if (vmsdefspec != NULL)
5727         PerlMem_free(vmsdefspec);
5728     if (vmsfspec != NULL)
5729         PerlMem_free(vmsfspec);
5730     if (outbufl != NULL)
5731         PerlMem_free(outbufl);
5732     PerlMem_free(esa);
5733     if (esal != NULL)
5734         PerlMem_free(esal);
5735     set_vaxc_errno(retsts);
5736     if      (retsts == RMS$_PRV) set_errno(EACCES);
5737     else                         set_errno(EVMSERR);
5738     return NULL;
5739   }
5740
5741   /* If the input filespec contained any lowercase characters,
5742    * downcase the result for compatibility with Unix-minded code. */
5743 int_expanded:
5744   if (!decc_efs_case_preserve) {
5745     char * tbuf;
5746     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5747       if (islower(*tbuf)) { haslower = 1; break; }
5748   }
5749
5750    /* Is a long or a short name expected */
5751   /*------------------------------------*/
5752   spec_buf = NULL;
5753   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5754     if (rms_nam_rsll(mynam)) {
5755         spec_buf = outbufl;
5756         speclen = rms_nam_rsll(mynam);
5757     }
5758     else {
5759         spec_buf = esal; /* Not esa */
5760         speclen = rms_nam_esll(mynam);
5761     }
5762   }
5763   else {
5764     if (rms_nam_rsl(mynam)) {
5765         spec_buf = outbuf;
5766         speclen = rms_nam_rsl(mynam);
5767     }
5768     else {
5769         spec_buf = esa; /* Not esal */
5770         speclen = rms_nam_esl(mynam);
5771     }
5772   }
5773   spec_buf[speclen] = '\0';
5774
5775   /* Trim off null fields added by $PARSE
5776    * If type > 1 char, must have been specified in original or default spec
5777    * (not true for version; $SEARCH may have added version of existing file).
5778    */
5779   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5780   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5781     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5782              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5783   }
5784   else {
5785     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5786              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5787   }
5788   if (trimver || trimtype) {
5789     if (defspec && *defspec) {
5790       char *defesal = NULL;
5791       char *defesa = NULL;
5792       defesa = PerlMem_malloc(VMS_MAXRSS + 1);
5793       if (defesa != NULL) {
5794         struct FAB deffab = cc$rms_fab;
5795 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5796         defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5797         if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5798 #endif
5799         rms_setup_nam(defnam);
5800
5801         rms_bind_fab_nam(deffab, defnam);
5802
5803         /* Cast ok */
5804         rms_set_fna
5805             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5806
5807         /* RMS needs the esa/esal as a work area if wildcards are involved */
5808         rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5809
5810         rms_clear_nam_nop(defnam);
5811         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5812 #ifdef NAM$M_NO_SHORT_UPCASE
5813         if (decc_efs_case_preserve)
5814           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5815 #endif
5816 #ifdef NAML$M_OPEN_SPECIAL
5817         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5818           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5819 #endif
5820         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5821           if (trimver) {
5822              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5823           }
5824           if (trimtype) {
5825             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5826           }
5827         }
5828         if (defesal != NULL)
5829             PerlMem_free(defesal);
5830         PerlMem_free(defesa);
5831       } else {
5832           _ckvmssts_noperl(SS$_INSFMEM);
5833       }
5834     }
5835     if (trimver) {
5836       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5837         if (*(rms_nam_verl(mynam)) != '\"')
5838           speclen = rms_nam_verl(mynam) - spec_buf;
5839       }
5840       else {
5841         if (*(rms_nam_ver(mynam)) != '\"')
5842           speclen = rms_nam_ver(mynam) - spec_buf;
5843       }
5844     }
5845     if (trimtype) {
5846       /* If we didn't already trim version, copy down */
5847       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5848         if (speclen > rms_nam_verl(mynam) - spec_buf)
5849           memmove
5850            (rms_nam_typel(mynam),
5851             rms_nam_verl(mynam),
5852             speclen - (rms_nam_verl(mynam) - spec_buf));
5853           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5854       }
5855       else {
5856         if (speclen > rms_nam_ver(mynam) - spec_buf)
5857           memmove
5858            (rms_nam_type(mynam),
5859             rms_nam_ver(mynam),
5860             speclen - (rms_nam_ver(mynam) - spec_buf));
5861           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5862       }
5863     }
5864   }
5865
5866    /* Done with these copies of the input files */
5867   /*-------------------------------------------*/
5868   if (vmsfspec != NULL)
5869         PerlMem_free(vmsfspec);
5870   if (vmsdefspec != NULL)
5871         PerlMem_free(vmsdefspec);
5872
5873   /* If we just had a directory spec on input, $PARSE "helpfully"
5874    * adds an empty name and type for us */
5875 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5876   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5877     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5878         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5879         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5880       speclen = rms_nam_namel(mynam) - spec_buf;
5881   }
5882   else
5883 #endif
5884   {
5885     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5886         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5887         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5888       speclen = rms_nam_name(mynam) - spec_buf;
5889   }
5890
5891   /* Posix format specifications must have matching quotes */
5892   if (speclen < (VMS_MAXRSS - 1)) {
5893     if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5894       if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5895         spec_buf[speclen] = '\"';
5896         speclen++;
5897       }
5898     }
5899   }
5900   spec_buf[speclen] = '\0';
5901   if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
5902
5903   /* Have we been working with an expanded, but not resultant, spec? */
5904   /* Also, convert back to Unix syntax if necessary. */
5905   {
5906   int rsl;
5907
5908 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5909     if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5910       rsl = rms_nam_rsll(mynam);
5911     } else
5912 #endif
5913     {
5914       rsl = rms_nam_rsl(mynam);
5915     }
5916     if (!rsl) {
5917       /* rsl is not present, it means that spec_buf is either */
5918       /* esa or esal, and needs to be copied to outbuf */
5919       /* convert to Unix if desired */
5920       if (isunix) {
5921         ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5922       } else {
5923         /* VMS file specs are not in UTF-8 */
5924         if (fs_utf8 != NULL)
5925             *fs_utf8 = 0;
5926         strcpy(outbuf, spec_buf);
5927         ret_spec = outbuf;
5928       }
5929     }
5930     else {
5931       /* Now spec_buf is either outbuf or outbufl */
5932       /* We need the result into outbuf */
5933       if (isunix) {
5934            /* If we need this in UNIX, then we need another buffer */
5935            /* to keep things in order */
5936            char * src;
5937            char * new_src = NULL;
5938            if (spec_buf == outbuf) {
5939                new_src = PerlMem_malloc(VMS_MAXRSS);
5940                strcpy(new_src, spec_buf);
5941            } else {
5942                src = spec_buf;
5943            }
5944            ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5945            if (new_src) {
5946                PerlMem_free(new_src);
5947            }
5948       } else {
5949            /* VMS file specs are not in UTF-8 */
5950            if (fs_utf8 != NULL)
5951                *fs_utf8 = 0;
5952
5953            /* Copy the buffer if needed */
5954            if (outbuf != spec_buf)
5955                strcpy(outbuf, spec_buf);
5956            ret_spec = outbuf;
5957       }
5958     }
5959   }
5960
5961   /* Need to clean up the search context */
5962   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5963   sts = rms_free_search_context(&myfab); /* Free search context */
5964
5965   /* Clean up the extra buffers */
5966   if (esal != NULL)
5967       PerlMem_free(esal);
5968   PerlMem_free(esa);
5969   if (outbufl != NULL)
5970      PerlMem_free(outbufl);
5971
5972   /* Return the result */
5973   return ret_spec;
5974 }
5975
5976 /* Common simple case - Expand an already VMS spec */
5977 static char *
5978 int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5979     opts |= PERL_RMSEXPAND_M_VMS_IN;
5980     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5981 }
5982
5983 /* Common simple case - Expand to a VMS spec */
5984 static char *
5985 int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5986     opts |= PERL_RMSEXPAND_M_VMS;
5987     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5988 }
5989
5990
5991 /* Entry point used by perl routines */
5992 static char *
5993 mp_do_rmsexpand
5994    (pTHX_ const char *filespec,
5995     char *outbuf,
5996     int ts,
5997     const char *defspec,
5998     unsigned opts,
5999     int * fs_utf8,
6000     int * dfs_utf8)
6001 {
6002     static char __rmsexpand_retbuf[VMS_MAXRSS];
6003     char * expanded, *ret_spec, *ret_buf;
6004
6005     expanded = NULL;
6006     ret_buf = outbuf;
6007     if (ret_buf == NULL) {
6008         if (ts) {
6009             Newx(expanded, VMS_MAXRSS, char);
6010             if (expanded == NULL)
6011                 _ckvmssts(SS$_INSFMEM);
6012             ret_buf = expanded;
6013         } else {
6014             ret_buf = __rmsexpand_retbuf;
6015         }
6016     }
6017
6018
6019     ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
6020                              opts, fs_utf8,  dfs_utf8);
6021
6022     if (ret_spec == NULL) {
6023        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6024        if (expanded)
6025            Safefree(expanded);
6026     }
6027
6028     return ret_spec;
6029 }
6030 /*}}}*/
6031 /* External entry points */
6032 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
6033 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
6034 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
6035 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
6036 char *Perl_rmsexpand_utf8
6037   (pTHX_ const char *spec, char *buf, const char *def,
6038    unsigned opt, int * fs_utf8, int * dfs_utf8)
6039 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
6040 char *Perl_rmsexpand_utf8_ts
6041   (pTHX_ const char *spec, char *buf, const char *def,
6042    unsigned opt, int * fs_utf8, int * dfs_utf8)
6043 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
6044
6045
6046 /*
6047 ** The following routines are provided to make life easier when
6048 ** converting among VMS-style and Unix-style directory specifications.
6049 ** All will take input specifications in either VMS or Unix syntax. On
6050 ** failure, all return NULL.  If successful, the routines listed below
6051 ** return a pointer to a buffer containing the appropriately
6052 ** reformatted spec (and, therefore, subsequent calls to that routine
6053 ** will clobber the result), while the routines of the same names with
6054 ** a _ts suffix appended will return a pointer to a mallocd string
6055 ** containing the appropriately reformatted spec.
6056 ** In all cases, only explicit syntax is altered; no check is made that
6057 ** the resulting string is valid or that the directory in question
6058 ** actually exists.
6059 **
6060 **   fileify_dirspec() - convert a directory spec into the name of the
6061 **     directory file (i.e. what you can stat() to see if it's a dir).
6062 **     The style (VMS or Unix) of the result is the same as the style
6063 **     of the parameter passed in.
6064 **   pathify_dirspec() - convert a directory spec into a path (i.e.
6065 **     what you prepend to a filename to indicate what directory it's in).
6066 **     The style (VMS or Unix) of the result is the same as the style
6067 **     of the parameter passed in.
6068 **   tounixpath() - convert a directory spec into a Unix-style path.
6069 **   tovmspath() - convert a directory spec into a VMS-style path.
6070 **   tounixspec() - convert any file spec into a Unix-style file spec.
6071 **   tovmsspec() - convert any file spec into a VMS-style spec.
6072 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
6073 **
6074 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
6075 ** Permission is given to distribute this code as part of the Perl
6076 ** standard distribution under the terms of the GNU General Public
6077 ** License or the Perl Artistic License.  Copies of each may be
6078 ** found in the Perl standard distribution.
6079  */
6080
6081 /*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6082 static char *
6083 int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
6084 {
6085     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
6086     char *cp1, *cp2, *lastdir;
6087     char *trndir, *vmsdir;
6088     unsigned short int trnlnm_iter_count;
6089     int is_vms = 0;
6090     int is_unix = 0;
6091     int sts;
6092     if (utf8_fl != NULL)
6093         *utf8_fl = 0;
6094
6095     if (!dir || !*dir) {
6096       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6097     }
6098     dirlen = strlen(dir);
6099     while (dirlen && dir[dirlen-1] == '/') --dirlen;
6100     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
6101       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
6102         dir = "/sys$disk";
6103         dirlen = 9;
6104       }
6105       else
6106         dirlen = 1;
6107     }
6108     if (dirlen > (VMS_MAXRSS - 1)) {
6109       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
6110       return NULL;
6111     }
6112     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
6113     if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6114     if (!strpbrk(dir+1,"/]>:")  &&
6115         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
6116       strcpy(trndir,*dir == '/' ? dir + 1: dir);
6117       trnlnm_iter_count = 0;
6118       while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
6119         trnlnm_iter_count++;
6120         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6121       }
6122       dirlen = strlen(trndir);
6123     }
6124     else {
6125       strncpy(trndir,dir,dirlen);
6126       trndir[dirlen] = '\0';
6127     }
6128
6129     /* At this point we are done with *dir and use *trndir which is a
6130      * copy that can be modified.  *dir must not be modified.
6131      */
6132
6133     /* If we were handed a rooted logical name or spec, treat it like a
6134      * simple directory, so that
6135      *    $ Define myroot dev:[dir.]
6136      *    ... do_fileify_dirspec("myroot",buf,1) ...
6137      * does something useful.
6138      */
6139     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
6140       trndir[--dirlen] = '\0';
6141       trndir[dirlen-1] = ']';
6142     }
6143     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
6144       trndir[--dirlen] = '\0';
6145       trndir[dirlen-1] = '>';
6146     }
6147
6148     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
6149       /* If we've got an explicit filename, we can just shuffle the string. */
6150       if (*(cp1+1)) hasfilename = 1;
6151       /* Similarly, we can just back up a level if we've got multiple levels
6152          of explicit directories in a VMS spec which ends with directories. */
6153       else {
6154         for (cp2 = cp1; cp2 > trndir; cp2--) {
6155           if (*cp2 == '.') {
6156             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
6157 /* fix-me, can not scan EFS file specs backward like this */
6158               *cp2 = *cp1; *cp1 = '\0';
6159               hasfilename = 1;
6160               break;
6161             }
6162           }
6163           if (*cp2 == '[' || *cp2 == '<') break;
6164         }
6165       }
6166     }
6167
6168     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
6169     if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6170     cp1 = strpbrk(trndir,"]:>");
6171     if (hasfilename || !cp1) { /* filename present or not VMS */
6172
6173       if (decc_efs_charset && !cp1) {
6174
6175           /* EFS handling for UNIX mode */
6176
6177           /* Just remove the trailing '/' and we should be done */
6178           STRLEN trndir_len;
6179           trndir_len = strlen(trndir);
6180
6181           if (trndir_len > 1) {
6182               trndir_len--;
6183               if (trndir[trndir_len] == '/') {
6184                   trndir[trndir_len] = '\0';
6185               }
6186           }
6187           strcpy(buf, trndir);
6188           PerlMem_free(trndir);
6189           PerlMem_free(vmsdir);
6190           return buf;
6191       }
6192
6193       /* For non-EFS mode, this is left for backwards compatibility */
6194       /* For EFS mode, this is only done for VMS format filespecs as */
6195       /* Perl programs generally have problems when a UNIX format spec */
6196       /* returns a VMS format spec */
6197       if (trndir[0] == '.') {
6198         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
6199           PerlMem_free(trndir);
6200           PerlMem_free(vmsdir);
6201           return int_fileify_dirspec("[]", buf, NULL);
6202         }
6203         else if (trndir[1] == '.' &&
6204                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
6205           PerlMem_free(trndir);
6206           PerlMem_free(vmsdir);
6207           return int_fileify_dirspec("[-]", buf, NULL);
6208         }
6209       }
6210       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
6211         dirlen -= 1;                 /* to last element */
6212         lastdir = strrchr(trndir,'/');
6213       }
6214       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
6215         /* If we have "/." or "/..", VMSify it and let the VMS code
6216          * below expand it, rather than repeating the code to handle
6217          * relative components of a filespec here */
6218         do {
6219           if (*(cp1+2) == '.') cp1++;
6220           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
6221             char * ret_chr;
6222             if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
6223                 PerlMem_free(trndir);
6224                 PerlMem_free(vmsdir);
6225                 return NULL;
6226             }
6227             if (strchr(vmsdir,'/') != NULL) {
6228               /* If int_tovmsspec() returned it, it must have VMS syntax
6229                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
6230                * the time to check this here only so we avoid a recursion
6231                * loop; otherwise, gigo.
6232                */
6233               PerlMem_free(trndir);
6234               PerlMem_free(vmsdir);
6235               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
6236               return NULL;
6237             }
6238             if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6239                 PerlMem_free(trndir);
6240                 PerlMem_free(vmsdir);
6241                 return NULL;
6242             }
6243             ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6244             PerlMem_free(trndir);
6245             PerlMem_free(vmsdir);
6246             return ret_chr;
6247           }
6248           cp1++;
6249         } while ((cp1 = strstr(cp1,"/.")) != NULL);
6250         lastdir = strrchr(trndir,'/');
6251       }
6252       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
6253         char * ret_chr;
6254         /* Ditto for specs that end in an MFD -- let the VMS code
6255          * figure out whether it's a real device or a rooted logical. */
6256
6257         /* This should not happen any more.  Allowing the fake /000000
6258          * in a UNIX pathname causes all sorts of problems when trying
6259          * to run in UNIX emulation.  So the VMS to UNIX conversions
6260          * now remove the fake /000000 directories.
6261          */
6262
6263         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6264         if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6265             PerlMem_free(trndir);
6266             PerlMem_free(vmsdir);
6267             return NULL;
6268         }
6269         if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6270             PerlMem_free(trndir);
6271             PerlMem_free(vmsdir);
6272             return NULL;
6273         }
6274         ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6275         PerlMem_free(trndir);
6276         PerlMem_free(vmsdir);
6277         return ret_chr;
6278       }
6279       else {
6280
6281         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6282              !(lastdir = cp1 = strrchr(trndir,']')) &&
6283              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6284
6285         cp2 = strrchr(cp1,'.');
6286         if (cp2) {
6287             int e_len, vs_len = 0;
6288             int is_dir = 0;
6289             char * cp3;
6290             cp3 = strchr(cp2,';');
6291             e_len = strlen(cp2);
6292             if (cp3) {
6293                 vs_len = strlen(cp3);
6294                 e_len = e_len - vs_len;
6295             }
6296             is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6297             if (!is_dir) {
6298                 if (!decc_efs_charset) {
6299                     /* If this is not EFS, then not a directory */
6300                     PerlMem_free(trndir);
6301                     PerlMem_free(vmsdir);
6302                     set_errno(ENOTDIR);
6303                     set_vaxc_errno(RMS$_DIR);
6304                     return NULL;
6305                 }
6306             } else {
6307                 /* Ok, here we have an issue, technically if a .dir shows */
6308                 /* from inside a directory, then we should treat it as */
6309                 /* xxx^.dir.dir.  But we do not have that context at this */
6310                 /* point unless this is totally restructured, so we remove */
6311                 /* The .dir for now, and fix this better later */
6312                 dirlen = cp2 - trndir;
6313             }
6314         }
6315
6316       }
6317
6318       retlen = dirlen + 6;
6319       memcpy(buf, trndir, dirlen);
6320       buf[dirlen] = '\0';
6321
6322       /* We've picked up everything up to the directory file name.
6323          Now just add the type and version, and we're set. */
6324
6325       /* We should only add type for VMS syntax, but historically Perl
6326          has added it for UNIX style also */
6327
6328       /* Fix me - we should not be using the same routine for VMS and
6329          UNIX format files.  Things are too tangled so we need to lookup
6330          what syntax the output is */
6331
6332       is_unix = 0;
6333       is_vms = 0;
6334       lastdir = strrchr(trndir,'/');
6335       if (lastdir) {
6336           is_unix = 1;
6337       } else {
6338           lastdir = strpbrk(trndir,"]:>");
6339           if (lastdir) {
6340               is_vms = 1;
6341           }
6342       }
6343
6344       if ((is_vms == 0) && (is_unix == 0)) {
6345           /* We still do not  know? */
6346           is_unix = decc_filename_unix_report;
6347           if (is_unix == 0)
6348               is_vms = 1;
6349       }
6350
6351       if ((is_unix && !decc_efs_charset) || is_vms) {
6352
6353            /* It is a bug to add a .dir to a UNIX format directory spec */
6354            /* However Perl on VMS may have programs that expect this so */
6355            /* If not using EFS character specifications allow it. */
6356
6357            if ((!decc_efs_case_preserve) && vms_process_case_tolerant) {
6358                /* Traditionally Perl expects filenames in lower case */
6359                strcat(buf, ".dir");
6360            } else {
6361                /* VMS expects the .DIR to be in upper case */
6362                strcat(buf, ".DIR");
6363            }
6364
6365            /* It is also a bug to put a VMS format version on a UNIX file */
6366            /* specification.  Perl self tests are looking for this */
6367            if (is_vms || !(decc_efs_charset || decc_filename_unix_report))
6368                strcat(buf, ";1");
6369       }
6370       PerlMem_free(trndir);
6371       PerlMem_free(vmsdir);
6372       return buf;
6373     }
6374     else {  /* VMS-style directory spec */
6375
6376       char *esa, *esal, term, *cp;
6377       char *my_esa;
6378       int my_esa_len;
6379       unsigned long int sts, cmplen, haslower = 0;
6380       unsigned int nam_fnb;
6381       char * nam_type;
6382       struct FAB dirfab = cc$rms_fab;
6383       rms_setup_nam(savnam);
6384       rms_setup_nam(dirnam);
6385
6386       esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6387       if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6388       esal = NULL;
6389 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6390       esal = PerlMem_malloc(VMS_MAXRSS);
6391       if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6392 #endif
6393       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6394       rms_bind_fab_nam(dirfab, dirnam);
6395       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6396       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6397 #ifdef NAM$M_NO_SHORT_UPCASE
6398       if (decc_efs_case_preserve)
6399         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6400 #endif
6401
6402       for (cp = trndir; *cp; cp++)
6403         if (islower(*cp)) { haslower = 1; break; }
6404       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6405         if ((dirfab.fab$l_sts == RMS$_DIR) ||
6406             (dirfab.fab$l_sts == RMS$_DNF) ||
6407             (dirfab.fab$l_sts == RMS$_PRV)) {
6408             rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6409             sts = sys$parse(&dirfab);
6410         }
6411         if (!sts) {
6412           PerlMem_free(esa);
6413           if (esal != NULL)
6414               PerlMem_free(esal);
6415           PerlMem_free(trndir);
6416           PerlMem_free(vmsdir);
6417           set_errno(EVMSERR);
6418           set_vaxc_errno(dirfab.fab$l_sts);
6419           return NULL;
6420         }
6421       }
6422       else {
6423         savnam = dirnam;
6424         /* Does the file really exist? */
6425         if (sys$search(&dirfab)& STS$K_SUCCESS) {
6426           /* Yes; fake the fnb bits so we'll check type below */
6427           rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6428         }
6429         else { /* No; just work with potential name */
6430           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6431           else {
6432             int fab_sts;
6433             fab_sts = dirfab.fab$l_sts;
6434             sts = rms_free_search_context(&dirfab);
6435             PerlMem_free(esa);
6436             if (esal != NULL)
6437                 PerlMem_free(esal);
6438             PerlMem_free(trndir);
6439             PerlMem_free(vmsdir);
6440             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
6441             return NULL;
6442           }
6443         }
6444       }
6445
6446       /* Make sure we are using the right buffer */
6447       if (esal != NULL) {
6448         my_esa = esal;
6449         my_esa_len = rms_nam_esll(dirnam);
6450       } else {
6451         my_esa = esa;
6452         my_esa_len = rms_nam_esl(dirnam);
6453       }
6454       my_esa[my_esa_len] = '\0';
6455       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6456         cp1 = strchr(my_esa,']');
6457         if (!cp1) cp1 = strchr(my_esa,'>');
6458         if (cp1) {  /* Should always be true */
6459           my_esa_len -= cp1 - my_esa - 1;
6460           memmove(my_esa, cp1 + 1, my_esa_len);
6461         }
6462       }
6463       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6464         /* Yep; check version while we're at it, if it's there. */
6465         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6466         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6467           /* Something other than .DIR[;1].  Bzzt. */
6468           sts = rms_free_search_context(&dirfab);
6469           PerlMem_free(esa);
6470           if (esal != NULL)
6471              PerlMem_free(esal);
6472           PerlMem_free(trndir);
6473           PerlMem_free(vmsdir);
6474           set_errno(ENOTDIR);
6475           set_vaxc_errno(RMS$_DIR);
6476           return NULL;
6477         }
6478       }
6479
6480       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6481         /* They provided at least the name; we added the type, if necessary, */
6482         strcpy(buf, my_esa);
6483         sts = rms_free_search_context(&dirfab);
6484         PerlMem_free(trndir);
6485         PerlMem_free(esa);
6486         if (esal != NULL)
6487             PerlMem_free(esal);
6488         PerlMem_free(vmsdir);
6489         return buf;
6490       }
6491       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6492         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6493         *cp1 = '\0';
6494         my_esa_len -= 9;
6495       }
6496       if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6497       if (cp1 == NULL) { /* should never happen */
6498         sts = rms_free_search_context(&dirfab);
6499         PerlMem_free(trndir);
6500         PerlMem_free(esa);
6501         if (esal != NULL)
6502             PerlMem_free(esal);
6503         PerlMem_free(vmsdir);
6504         return NULL;
6505       }
6506       term = *cp1;
6507       *cp1 = '\0';
6508       retlen = strlen(my_esa);
6509       cp1 = strrchr(my_esa,'.');
6510       /* ODS-5 directory specifications can have extra "." in them. */
6511       /* Fix-me, can not scan EFS file specifications backwards */
6512       while (cp1 != NULL) {
6513         if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6514           break;
6515         else {
6516            cp1--;
6517            while ((cp1 > my_esa) && (*cp1 != '.'))
6518              cp1--;
6519         }
6520         if (cp1 == my_esa)
6521           cp1 = NULL;
6522       }
6523
6524       if ((cp1) != NULL) {
6525         /* There's more than one directory in the path.  Just roll back. */
6526         *cp1 = term;
6527         strcpy(buf, my_esa);
6528       }
6529       else {
6530         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6531           /* Go back and expand rooted logical name */
6532           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6533 #ifdef NAM$M_NO_SHORT_UPCASE
6534           if (decc_efs_case_preserve)
6535             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6536 #endif
6537           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6538             sts = rms_free_search_context(&dirfab);
6539             PerlMem_free(esa);
6540             if (esal != NULL)
6541                 PerlMem_free(esal);
6542             PerlMem_free(trndir);
6543             PerlMem_free(vmsdir);
6544             set_errno(EVMSERR);
6545             set_vaxc_errno(dirfab.fab$l_sts);
6546             return NULL;
6547           }
6548
6549           /* This changes the length of the string of course */
6550           if (esal != NULL) {
6551               my_esa_len = rms_nam_esll(dirnam);
6552           } else {
6553               my_esa_len = rms_nam_esl(dirnam);
6554           }
6555
6556           retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6557           cp1 = strstr(my_esa,"][");
6558           if (!cp1) cp1 = strstr(my_esa,"]<");
6559           dirlen = cp1 - my_esa;
6560           memcpy(buf, my_esa, dirlen);
6561           if (!strncmp(cp1+2,"000000]",7)) {
6562             buf[dirlen-1] = '\0';
6563             /* fix-me Not full ODS-5, just extra dots in directories for now */
6564             cp1 = buf + dirlen - 1;
6565             while (cp1 > buf)
6566             {
6567               if (*cp1 == '[')
6568                 break;
6569               if (*cp1 == '.') {
6570                 if (*(cp1-1) != '^')
6571                   break;
6572               }
6573               cp1--;
6574             }
6575             if (*cp1 == '.') *cp1 = ']';
6576             else {
6577               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6578               memmove(cp1+1,"000000]",7);
6579             }
6580           }
6581           else {
6582             memmove(buf+dirlen, cp1+2, retlen-dirlen);
6583             buf[retlen] = '\0';
6584             /* Convert last '.' to ']' */
6585             cp1 = buf+retlen-1;
6586             while (*cp != '[') {
6587               cp1--;
6588               if (*cp1 == '.') {
6589                 /* Do not trip on extra dots in ODS-5 directories */
6590                 if ((cp1 == buf) || (*(cp1-1) != '^'))
6591                 break;
6592               }
6593             }
6594             if (*cp1 == '.') *cp1 = ']';
6595             else {
6596               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6597               memmove(cp1+1,"000000]",7);
6598             }
6599           }
6600         }
6601         else {  /* This is a top-level dir.  Add the MFD to the path. */
6602           cp1 = my_esa;
6603           cp2 = buf;
6604           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6605           strcpy(cp2,":[000000]");
6606           cp1 += 2;
6607           strcpy(cp2+9,cp1);
6608         }
6609       }
6610       sts = rms_free_search_context(&dirfab);
6611       /* We've set up the string up through the filename.  Add the
6612          type and version, and we're done. */
6613       strcat(buf,".DIR;1");
6614
6615       /* $PARSE may have upcased filespec, so convert output to lower
6616        * case if input contained any lowercase characters. */
6617       if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
6618       PerlMem_free(trndir);
6619       PerlMem_free(esa);
6620       if (esal != NULL)
6621         PerlMem_free(esal);
6622       PerlMem_free(vmsdir);
6623       return buf;
6624     }
6625 }  /* end of int_fileify_dirspec() */
6626
6627
6628 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6629 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
6630 {
6631     static char __fileify_retbuf[VMS_MAXRSS];
6632     char * fileified, *ret_spec, *ret_buf;
6633
6634     fileified = NULL;
6635     ret_buf = buf;
6636     if (ret_buf == NULL) {
6637         if (ts) {
6638             Newx(fileified, VMS_MAXRSS, char);
6639             if (fileified == NULL)
6640                 _ckvmssts(SS$_INSFMEM);
6641             ret_buf = fileified;
6642         } else {
6643             ret_buf = __fileify_retbuf;
6644         }
6645     }
6646
6647     ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6648
6649     if (ret_spec == NULL) {
6650        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6651        if (fileified)
6652            Safefree(fileified);
6653     }
6654
6655     return ret_spec;
6656 }  /* end of do_fileify_dirspec() */
6657 /*}}}*/
6658
6659 /* External entry points */
6660 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6661 { return do_fileify_dirspec(dir,buf,0,NULL); }
6662 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6663 { return do_fileify_dirspec(dir,buf,1,NULL); }
6664 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6665 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6666 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6667 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6668
6669 static char * int_pathify_dirspec_simple(const char * dir, char * buf,
6670     char * v_spec, int v_len, char * r_spec, int r_len,
6671     char * d_spec, int d_len, char * n_spec, int n_len,
6672     char * e_spec, int e_len, char * vs_spec, int vs_len) {
6673
6674     /* VMS specification - Try to do this the simple way */
6675     if ((v_len + r_len > 0) || (d_len > 0)) {
6676         int is_dir;
6677
6678         /* No name or extension component, already a directory */
6679         if ((n_len + e_len + vs_len) == 0) {
6680             strcpy(buf, dir);
6681             return buf;
6682         }
6683
6684         /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6685         /* This results from catfile() being used instead of catdir() */
6686         /* So even though it should not work, we need to allow it */
6687
6688         /* If this is .DIR;1 then do a simple conversion */
6689         is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6690         if (is_dir || (e_len == 0) && (d_len > 0)) {
6691              int len;
6692              len = v_len + r_len + d_len - 1;
6693              char dclose = d_spec[d_len - 1];
6694              strncpy(buf, dir, len);
6695              buf[len] = '.';
6696              len++;
6697              strncpy(&buf[len], n_spec, n_len);
6698              len += n_len;
6699              buf[len] = dclose;
6700              buf[len + 1] = '\0';
6701              return buf;
6702         }
6703
6704 #ifdef HAS_SYMLINK
6705         else if (d_len > 0) {
6706             /* In the olden days, a directory needed to have a .DIR */
6707             /* extension to be a valid directory, but now it could  */
6708             /* be a symbolic link */
6709             int len;
6710             len = v_len + r_len + d_len - 1;
6711             char dclose = d_spec[d_len - 1];
6712             strncpy(buf, dir, len);
6713             buf[len] = '.';
6714             len++;
6715             strncpy(&buf[len], n_spec, n_len);
6716             len += n_len;
6717             if (e_len > 0) {
6718                 if (decc_efs_charset) {
6719                     buf[len] = '^';
6720                     len++;
6721                     strncpy(&buf[len], e_spec, e_len);
6722                     len += e_len;
6723                 } else {
6724                     set_vaxc_errno(RMS$_DIR);
6725                     set_errno(ENOTDIR);
6726                     return NULL;
6727                 }
6728             }
6729             buf[len] = dclose;
6730             buf[len + 1] = '\0';
6731             return buf;
6732         }
6733 #else
6734         else {
6735             set_vaxc_errno(RMS$_DIR);
6736             set_errno(ENOTDIR);
6737             return NULL;
6738         }
6739 #endif
6740     }
6741     set_vaxc_errno(RMS$_DIR);
6742     set_errno(ENOTDIR);
6743     return NULL;
6744 }
6745
6746
6747 /* Internal routine to make sure or convert a directory to be in a */
6748 /* path specification.  No utf8 flag because it is not changed or used */
6749 static char *int_pathify_dirspec(const char *dir, char *buf)
6750 {
6751     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6752     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6753     char * exp_spec, *ret_spec;
6754     char * trndir;
6755     unsigned short int trnlnm_iter_count;
6756     STRLEN trnlen;
6757     int need_to_lower;
6758
6759     if (vms_debug_fileify) {
6760         if (dir == NULL)
6761             fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6762         else
6763             fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6764     }
6765
6766     /* We may need to lower case the result if we translated  */
6767     /* a logical name or got the current working directory */
6768     need_to_lower = 0;
6769
6770     if (!dir || !*dir) {
6771       set_errno(EINVAL);
6772       set_vaxc_errno(SS$_BADPARAM);
6773       return NULL;
6774     }
6775
6776     trndir = PerlMem_malloc(VMS_MAXRSS);
6777     if (trndir == NULL)
6778         _ckvmssts_noperl(SS$_INSFMEM);
6779
6780     /* If no directory specified use the current default */
6781     if (*dir)
6782         strcpy(trndir, dir);
6783     else {
6784         getcwd(trndir, VMS_MAXRSS - 1);
6785         need_to_lower = 1;
6786     }
6787
6788     /* now deal with bare names that could be logical names */
6789     trnlnm_iter_count = 0;
6790     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6791            && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6792         trnlnm_iter_count++;
6793         need_to_lower = 1;
6794         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6795             break;
6796         trnlen = strlen(trndir);
6797
6798         /* Trap simple rooted lnms, and return lnm:[000000] */
6799         if (!strcmp(trndir+trnlen-2,".]")) {
6800             strcpy(buf, dir);
6801             strcat(buf, ":[000000]");
6802             PerlMem_free(trndir);
6803
6804             if (vms_debug_fileify) {
6805                 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6806             }
6807             return buf;
6808         }
6809     }
6810
6811     /* At this point we do not work with *dir, but the copy in  *trndir */
6812
6813     if (need_to_lower && !decc_efs_case_preserve) {
6814         /* Legacy mode, lower case the returned value */
6815         __mystrtolower(trndir);
6816     }
6817
6818
6819     /* Some special cases, '..', '.' */
6820     sts = 0;
6821     if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6822        /* Force UNIX filespec */
6823        sts = 1;
6824
6825     } else {
6826         /* Is this Unix or VMS format? */
6827         sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6828                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6829                              &e_len, &vs_spec, &vs_len);
6830         if (sts == 0) {
6831
6832             /* Just a filename? */
6833             if ((v_len + r_len + d_len) == 0) {
6834
6835                 /* Now we have a problem, this could be Unix or VMS */
6836                 /* We have to guess.  .DIR usually means VMS */
6837
6838                 /* In UNIX report mode, the .DIR extension is removed */
6839                 /* if one shows up, it is for a non-directory or a directory */
6840                 /* in EFS charset mode */
6841
6842                 /* So if we are in Unix report mode, assume that this */
6843                 /* is a relative Unix directory specification */
6844
6845                 sts = 1;
6846                 if (!decc_filename_unix_report && decc_efs_charset) {
6847                     int is_dir;
6848                     is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6849
6850                     if (is_dir) {
6851                         /* Traditional mode, assume .DIR is directory */
6852                         buf[0] = '[';
6853                         buf[1] = '.';
6854                         strncpy(&buf[2], n_spec, n_len);
6855                         buf[n_len + 2] = ']';
6856                         buf[n_len + 3] = '\0';
6857                         PerlMem_free(trndir);
6858                         if (vms_debug_fileify) {
6859                             fprintf(stderr,
6860                                     "int_pathify_dirspec: buf = %s\n",
6861                                     buf);
6862                         }
6863                         return buf;
6864                     }
6865                 }
6866             }
6867         }
6868     }
6869     if (sts == 0) {
6870         ret_spec = int_pathify_dirspec_simple(trndir, buf,
6871             v_spec, v_len, r_spec, r_len,
6872             d_spec, d_len, n_spec, n_len,
6873             e_spec, e_len, vs_spec, vs_len);
6874
6875         if (ret_spec != NULL) {
6876             PerlMem_free(trndir);
6877             if (vms_debug_fileify) {
6878                 fprintf(stderr,
6879                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6880             }
6881             return ret_spec;
6882         }
6883
6884         /* Simple way did not work, which means that a logical name */
6885         /* was present for the directory specification.             */
6886         /* Need to use an rmsexpand variant to decode it completely */
6887         exp_spec = PerlMem_malloc(VMS_MAXRSS);
6888         if (exp_spec == NULL)
6889             _ckvmssts_noperl(SS$_INSFMEM);
6890
6891         ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6892         if (ret_spec != NULL) {
6893             sts = vms_split_path(exp_spec, &v_spec, &v_len,
6894                                  &r_spec, &r_len, &d_spec, &d_len,
6895                                  &n_spec, &n_len, &e_spec,
6896                                  &e_len, &vs_spec, &vs_len);
6897             if (sts == 0) {
6898                 ret_spec = int_pathify_dirspec_simple(
6899                     exp_spec, buf, v_spec, v_len, r_spec, r_len,
6900                     d_spec, d_len, n_spec, n_len,
6901                     e_spec, e_len, vs_spec, vs_len);
6902
6903                 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6904                     /* Legacy mode, lower case the returned value */
6905                     __mystrtolower(ret_spec);
6906                 }
6907             } else {
6908                 set_vaxc_errno(RMS$_DIR);
6909                 set_errno(ENOTDIR);
6910                 ret_spec = NULL;
6911             }
6912         }
6913         PerlMem_free(exp_spec);
6914         PerlMem_free(trndir);
6915         if (vms_debug_fileify) {
6916             if (ret_spec == NULL)
6917                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6918             else
6919                 fprintf(stderr,
6920                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6921         }
6922         return ret_spec;
6923
6924     } else {
6925         /* Unix specification, Could be trivial conversion */
6926         STRLEN dir_len;
6927         dir_len = strlen(trndir);
6928
6929         /* If the extended file character set is in effect */
6930         /* then pathify is simple */
6931
6932         if (!decc_efs_charset) {
6933             /* Have to deal with traiing '.dir' or extra '.' */
6934             /* that should not be there in legacy mode, but is */
6935
6936             char * lastdot;
6937             char * lastslash;
6938             int is_dir;
6939
6940             lastslash = strrchr(trndir, '/');
6941             if (lastslash == NULL)
6942                 lastslash = trndir;
6943             else
6944                 lastslash++;
6945
6946             lastdot = NULL;
6947
6948             /* '..' or '.' are valid directory components */
6949             is_dir = 0;
6950             if (lastslash[0] == '.') {
6951                 if (lastslash[1] == '\0') {
6952                    is_dir = 1;
6953                 } else if (lastslash[1] == '.') {
6954                     if (lastslash[2] == '\0') {
6955                         is_dir = 1;
6956                     } else {
6957                         /* And finally allow '...' */
6958                         if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
6959                             is_dir = 1;
6960                         }
6961                     }
6962                 }
6963             }
6964
6965             if (!is_dir) {
6966                lastdot = strrchr(lastslash, '.');
6967             }
6968             if (lastdot != NULL) {
6969                 STRLEN e_len;
6970
6971                 /* '.dir' is discarded, and any other '.' is invalid */
6972                 e_len = strlen(lastdot);
6973
6974                 is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
6975
6976                 if (is_dir) {
6977                     dir_len = dir_len - 4;
6978
6979                 }
6980             }
6981         }
6982
6983         strcpy(buf, trndir);
6984         if (buf[dir_len - 1] != '/') {
6985             buf[dir_len] = '/';
6986             buf[dir_len + 1] = '\0';
6987         }
6988
6989         /* Under ODS-2 rules, '.' becomes '_', so fix it up */
6990         if (!decc_efs_charset) {
6991              int dir_start = 0;
6992              char * str = buf;
6993              if (str[0] == '.') {
6994                  char * dots = str;
6995                  int cnt = 1;
6996                  while ((dots[cnt] == '.') && (cnt < 3))
6997                      cnt++;
6998                  if (cnt <= 3) {
6999                      if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
7000                          dir_start = 1;
7001                          str += cnt;
7002                      }
7003                  }
7004              }
7005              for (; *str; ++str) {
7006                  while (*str == '/') {
7007                      dir_start = 1;
7008                      *str++;
7009                  }
7010                  if (dir_start) {
7011
7012                      /* Have to skip up to three dots which could be */
7013                      /* directories, 3 dots being a VMS extension for Perl */
7014                      char * dots = str;
7015                      int cnt = 0;
7016                      while ((dots[cnt] == '.') && (cnt < 3)) {
7017                          cnt++;
7018                      }
7019                      if (dots[cnt] == '\0')
7020                          break;
7021                      if ((cnt > 1) && (dots[cnt] != '/')) {
7022                          dir_start = 0;
7023                      } else {
7024                          str += cnt;
7025                      }
7026
7027                      /* too many dots? */
7028                      if ((cnt == 0) || (cnt > 3)) {
7029                          dir_start = 0;
7030                      }
7031                  }
7032                  if (!dir_start && (*str == '.')) {
7033                      *str = '_';
7034                  }
7035              }
7036         }
7037         PerlMem_free(trndir);
7038         ret_spec = buf;
7039         if (vms_debug_fileify) {
7040             if (ret_spec == NULL)
7041                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
7042             else
7043                 fprintf(stderr,
7044                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
7045         }
7046         return ret_spec;
7047     }
7048 }
7049
7050 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
7051 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
7052 {
7053     static char __pathify_retbuf[VMS_MAXRSS];
7054     char * pathified, *ret_spec, *ret_buf;
7055
7056     pathified = NULL;
7057     ret_buf = buf;
7058     if (ret_buf == NULL) {
7059         if (ts) {
7060             Newx(pathified, VMS_MAXRSS, char);
7061             if (pathified == NULL)
7062                 _ckvmssts(SS$_INSFMEM);
7063             ret_buf = pathified;
7064         } else {
7065             ret_buf = __pathify_retbuf;
7066         }
7067     }
7068
7069     ret_spec = int_pathify_dirspec(dir, ret_buf);
7070
7071     if (ret_spec == NULL) {
7072        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7073        if (pathified)
7074            Safefree(pathified);
7075     }
7076
7077     return ret_spec;
7078
7079 }  /* end of do_pathify_dirspec() */
7080
7081
7082 /* External entry points */
7083 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
7084 { return do_pathify_dirspec(dir,buf,0,NULL); }
7085 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
7086 { return do_pathify_dirspec(dir,buf,1,NULL); }
7087 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
7088 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
7089 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
7090 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
7091
7092 /* Internal tounixspec routine that does not use a thread context */
7093 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
7094 static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
7095 {
7096   char *dirend, *cp1, *cp3, *tmp;
7097   const char *cp2;
7098   int devlen, dirlen, retlen = VMS_MAXRSS;
7099   int expand = 1; /* guarantee room for leading and trailing slashes */
7100   unsigned short int trnlnm_iter_count;
7101   int cmp_rslt;
7102   if (utf8_fl != NULL)
7103     *utf8_fl = 0;
7104
7105   if (vms_debug_fileify) {
7106       if (spec == NULL)
7107           fprintf(stderr, "int_tounixspec: spec = NULL\n");
7108       else
7109           fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
7110   }
7111
7112
7113   if (spec == NULL) {
7114       set_errno(EINVAL);
7115       set_vaxc_errno(SS$_BADPARAM);
7116       return NULL;
7117   }
7118   if (strlen(spec) > (VMS_MAXRSS-1)) {
7119       set_errno(E2BIG);
7120       set_vaxc_errno(SS$_BUFFEROVF);
7121       return NULL;
7122   }
7123
7124   /* New VMS specific format needs translation
7125    * glob passes filenames with trailing '\n' and expects this preserved.
7126    */
7127   if (decc_posix_compliant_pathnames) {
7128     if (strncmp(spec, "\"^UP^", 5) == 0) {
7129       char * uspec;
7130       char *tunix;
7131       int tunix_len;
7132       int nl_flag;
7133
7134       tunix = PerlMem_malloc(VMS_MAXRSS);
7135       if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7136       strcpy(tunix, spec);
7137       tunix_len = strlen(tunix);
7138       nl_flag = 0;
7139       if (tunix[tunix_len - 1] == '\n') {
7140         tunix[tunix_len - 1] = '\"';
7141         tunix[tunix_len] = '\0';
7142         tunix_len--;
7143         nl_flag = 1;
7144       }
7145       uspec = decc$translate_vms(tunix);
7146       PerlMem_free(tunix);
7147       if ((int)uspec > 0) {
7148         strcpy(rslt,uspec);
7149         if (nl_flag) {
7150           strcat(rslt,"\n");
7151         }
7152         else {
7153           /* If we can not translate it, makemaker wants as-is */
7154           strcpy(rslt, spec);
7155         }
7156         return rslt;
7157       }
7158     }
7159   }
7160
7161   cmp_rslt = 0; /* Presume VMS */
7162   cp1 = strchr(spec, '/');
7163   if (cp1 == NULL)
7164     cmp_rslt = 0;
7165
7166     /* Look for EFS ^/ */
7167     if (decc_efs_charset) {
7168       while (cp1 != NULL) {
7169         cp2 = cp1 - 1;
7170         if (*cp2 != '^') {
7171           /* Found illegal VMS, assume UNIX */
7172           cmp_rslt = 1;
7173           break;
7174         }
7175       cp1++;
7176       cp1 = strchr(cp1, '/');
7177     }
7178   }
7179
7180   /* Look for "." and ".." */
7181   if (decc_filename_unix_report) {
7182     if (spec[0] == '.') {
7183       if ((spec[1] == '\0') || (spec[1] == '\n')) {
7184         cmp_rslt = 1;
7185       }
7186       else {
7187         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
7188           cmp_rslt = 1;
7189         }
7190       }
7191     }
7192   }
7193   /* This is already UNIX or at least nothing VMS understands */
7194   if (cmp_rslt) {
7195     strcpy(rslt,spec);
7196     if (vms_debug_fileify) {
7197         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7198     }
7199     return rslt;
7200   }
7201
7202   cp1 = rslt;
7203   cp2 = spec;
7204   dirend = strrchr(spec,']');
7205   if (dirend == NULL) dirend = strrchr(spec,'>');
7206   if (dirend == NULL) dirend = strchr(spec,':');
7207   if (dirend == NULL) {
7208     strcpy(rslt,spec);
7209     if (vms_debug_fileify) {
7210         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7211     }
7212     return rslt;
7213   }
7214
7215   /* Special case 1 - sys$posix_root = / */
7216 #if __CRTL_VER >= 70000000
7217   if (!decc_disable_posix_root) {
7218     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
7219       *cp1 = '/';
7220       cp1++;
7221       cp2 = cp2 + 15;
7222       }
7223   }
7224 #endif
7225
7226   /* Special case 2 - Convert NLA0: to /dev/null */
7227 #if __CRTL_VER < 70000000
7228   cmp_rslt = strncmp(spec,"NLA0:", 5);
7229   if (cmp_rslt != 0)
7230      cmp_rslt = strncmp(spec,"nla0:", 5);
7231 #else
7232   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
7233 #endif
7234   if (cmp_rslt == 0) {
7235     strcpy(rslt, "/dev/null");
7236     cp1 = cp1 + 9;
7237     cp2 = cp2 + 5;
7238     if (spec[6] != '\0') {
7239       cp1[9] == '/';
7240       cp1++;
7241       cp2++;
7242     }
7243   }
7244
7245    /* Also handle special case "SYS$SCRATCH:" */
7246 #if __CRTL_VER < 70000000
7247   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
7248   if (cmp_rslt != 0)
7249      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
7250 #else
7251   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
7252 #endif
7253   tmp = PerlMem_malloc(VMS_MAXRSS);
7254   if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7255   if (cmp_rslt == 0) {
7256   int islnm;
7257
7258     islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
7259     if (!islnm) {
7260       strcpy(rslt, "/tmp");
7261       cp1 = cp1 + 4;
7262       cp2 = cp2 + 12;
7263       if (spec[12] != '\0') {
7264         cp1[4] == '/';
7265         cp1++;
7266         cp2++;
7267       }
7268     }
7269   }
7270
7271   if (*cp2 != '[' && *cp2 != '<') {
7272     *(cp1++) = '/';
7273   }
7274   else {  /* the VMS spec begins with directories */
7275     cp2++;
7276     if (*cp2 == ']' || *cp2 == '>') {
7277       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
7278       PerlMem_free(tmp);
7279       return rslt;
7280     }
7281     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
7282       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
7283         PerlMem_free(tmp);
7284         if (vms_debug_fileify) {
7285             fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7286         }
7287         return NULL;
7288       }
7289       trnlnm_iter_count = 0;
7290       do {
7291         cp3 = tmp;
7292         while (*cp3 != ':' && *cp3) cp3++;
7293         *(cp3++) = '\0';
7294         if (strchr(cp3,']') != NULL) break;
7295         trnlnm_iter_count++;
7296         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7297       } while (vmstrnenv(tmp,tmp,0,fildev,0));
7298       cp1 = rslt;
7299       cp3 = tmp;
7300       *(cp1++) = '/';
7301       while (*cp3) {
7302         *(cp1++) = *(cp3++);
7303         if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7304             PerlMem_free(tmp);
7305             set_errno(ENAMETOOLONG);
7306             set_vaxc_errno(SS$_BUFFEROVF);
7307             if (vms_debug_fileify) {
7308                 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7309             }
7310             return NULL; /* No room */
7311         }
7312       }
7313       *(cp1++) = '/';
7314     }
7315     if ((*cp2 == '^')) {
7316         /* EFS file escape, pass the next character as is */
7317         /* Fix me: HEX encoding for Unicode not implemented */
7318         cp2++;
7319     }
7320     else if ( *cp2 == '.') {
7321       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7322         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7323         cp2 += 3;
7324       }
7325       else cp2++;
7326     }
7327   }
7328   PerlMem_free(tmp);
7329   for (; cp2 <= dirend; cp2++) {
7330     if ((*cp2 == '^')) {
7331         /* EFS file escape, pass the next character as is */
7332         /* Fix me: HEX encoding for Unicode not implemented */
7333         *(cp1++) = *(++cp2);
7334         /* An escaped dot stays as is -- don't convert to slash */
7335         if (*cp2 == '.') cp2++;
7336     }
7337     if (*cp2 == ':') {
7338       *(cp1++) = '/';
7339       if (*(cp2+1) == '[') cp2++;
7340     }
7341     else if (*cp2 == ']' || *cp2 == '>') {
7342       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7343     }
7344     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7345       *(cp1++) = '/';
7346       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7347         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7348                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7349         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7350             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7351       }
7352       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7353         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7354         cp2 += 2;
7355       }
7356     }
7357     else if (*cp2 == '-') {
7358       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7359         while (*cp2 == '-') {
7360           cp2++;
7361           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7362         }
7363         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7364                                                          /* filespecs like */
7365           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
7366           if (vms_debug_fileify) {
7367               fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7368           }
7369           return NULL;
7370         }
7371       }
7372       else *(cp1++) = *cp2;
7373     }
7374     else *(cp1++) = *cp2;
7375   }
7376   /* Translate the rest of the filename. */
7377   while (*cp2) {
7378       int dot_seen;
7379       dot_seen = 0;
7380       switch(*cp2) {
7381       /* Fixme - for compatibility with the CRTL we should be removing */
7382       /* spaces from the file specifications, but this may show that */
7383       /* some tests that were appearing to pass are not really passing */
7384       case '%':
7385           cp2++;
7386           *(cp1++) = '?';
7387           break;
7388       case '^':
7389           /* Fix me hex expansions not implemented */
7390           cp2++;  /* '^.' --> '.' and other. */
7391           if (*cp2) {
7392               if (*cp2 == '_') {
7393                   cp2++;
7394                   *(cp1++) = ' ';
7395               } else {
7396                   *(cp1++) = *(cp2++);
7397               }
7398           }
7399           break;
7400       case ';':
7401           if (decc_filename_unix_no_version) {
7402               /* Easy, drop the version */
7403               while (*cp2)
7404                   cp2++;
7405               break;
7406           } else {
7407               /* Punt - passing the version as a dot will probably */
7408               /* break perl in weird ways, but so did passing */
7409               /* through the ; as a version.  Follow the CRTL and */
7410               /* hope for the best. */
7411               cp2++;
7412               *(cp1++) = '.';
7413           }
7414           break;
7415       case '.':
7416           if (dot_seen) {
7417               /* We will need to fix this properly later */
7418               /* As Perl may be installed on an ODS-5 volume, but not */
7419               /* have the EFS_CHARSET enabled, it still may encounter */
7420               /* filenames with extra dots in them, and a precedent got */
7421               /* set which allowed them to work, that we will uphold here */
7422               /* If extra dots are present in a name and no ^ is on them */
7423               /* VMS assumes that the first one is the extension delimiter */
7424               /* the rest have an implied ^. */
7425
7426               /* this is also a conflict as the . is also a version */
7427               /* delimiter in VMS, */
7428
7429               *(cp1++) = *(cp2++);
7430               break;
7431           }
7432           dot_seen = 1;
7433           /* This is an extension */
7434           if (decc_readdir_dropdotnotype) {
7435               cp2++;
7436               if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7437                   /* Drop the dot for the extension */
7438                   break;
7439               } else {
7440                   *(cp1++) = '.';
7441               }
7442               break;
7443           }
7444       default:
7445           *(cp1++) = *(cp2++);
7446       }
7447   }
7448   *cp1 = '\0';
7449
7450   /* This still leaves /000000/ when working with a
7451    * VMS device root or concealed root.
7452    */
7453   {
7454   int ulen;
7455   char * zeros;
7456
7457       ulen = strlen(rslt);
7458
7459       /* Get rid of "000000/ in rooted filespecs */
7460       if (ulen > 7) {
7461         zeros = strstr(rslt, "/000000/");
7462         if (zeros != NULL) {
7463           int mlen;
7464           mlen = ulen - (zeros - rslt) - 7;
7465           memmove(zeros, &zeros[7], mlen);
7466           ulen = ulen - 7;
7467           rslt[ulen] = '\0';
7468         }
7469       }
7470   }
7471
7472   if (vms_debug_fileify) {
7473       fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7474   }
7475   return rslt;
7476
7477 }  /* end of int_tounixspec() */
7478
7479
7480 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7481 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7482 {
7483     static char __tounixspec_retbuf[VMS_MAXRSS];
7484     char * unixspec, *ret_spec, *ret_buf;
7485
7486     unixspec = NULL;
7487     ret_buf = buf;
7488     if (ret_buf == NULL) {
7489         if (ts) {
7490             Newx(unixspec, VMS_MAXRSS, char);
7491             if (unixspec == NULL)
7492                 _ckvmssts(SS$_INSFMEM);
7493             ret_buf = unixspec;
7494         } else {
7495             ret_buf = __tounixspec_retbuf;
7496         }
7497     }
7498
7499     ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7500
7501     if (ret_spec == NULL) {
7502        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7503        if (unixspec)
7504            Safefree(unixspec);
7505     }
7506
7507     return ret_spec;
7508
7509 }  /* end of do_tounixspec() */
7510 /*}}}*/
7511 /* External entry points */
7512 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
7513   { return do_tounixspec(spec,buf,0, NULL); }
7514 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7515   { return do_tounixspec(spec,buf,1, NULL); }
7516 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7517   { return do_tounixspec(spec,buf,0, utf8_fl); }
7518 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7519   { return do_tounixspec(spec,buf,1, utf8_fl); }
7520
7521 #if __CRTL_VER >= 70200000 && !defined(__VAX)
7522
7523 /*
7524  This procedure is used to identify if a path is based in either
7525  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7526  it returns the OpenVMS format directory for it.
7527
7528  It is expecting specifications of only '/' or '/xxxx/'
7529
7530  If a posix root does not exist, or 'xxxx' is not a directory
7531  in the posix root, it returns a failure.
7532
7533  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7534
7535  It is used only internally by posix_to_vmsspec_hardway().
7536  */
7537
7538 static int posix_root_to_vms
7539   (char *vmspath, int vmspath_len,
7540    const char *unixpath,
7541    const int * utf8_fl)
7542 {
7543 int sts;
7544 struct FAB myfab = cc$rms_fab;
7545 rms_setup_nam(mynam);
7546 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7547 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7548 char * esa, * esal, * rsa, * rsal;
7549 char *vms_delim;
7550 int dir_flag;
7551 int unixlen;
7552
7553     dir_flag = 0;
7554     vmspath[0] = '\0';
7555     unixlen = strlen(unixpath);
7556     if (unixlen == 0) {
7557       return RMS$_FNF;
7558     }
7559
7560 #if __CRTL_VER >= 80200000
7561   /* If not a posix spec already, convert it */
7562   if (decc_posix_compliant_pathnames) {
7563     if (strncmp(unixpath,"\"^UP^",5) != 0) {
7564       sprintf(vmspath,"\"^UP^%s\"",unixpath);
7565     }
7566     else {
7567       /* This is already a VMS specification, no conversion */
7568       unixlen--;
7569       strncpy(vmspath,unixpath, vmspath_len);
7570     }
7571   }
7572   else
7573 #endif
7574   {
7575   int path_len;
7576   int i,j;
7577
7578      /* Check to see if this is under the POSIX root */
7579      if (decc_disable_posix_root) {
7580         return RMS$_FNF;
7581      }
7582
7583      /* Skip leading / */
7584      if (unixpath[0] == '/') {
7585         unixpath++;
7586         unixlen--;
7587      }
7588
7589
7590      strcpy(vmspath,"SYS$POSIX_ROOT:");
7591
7592      /* If this is only the / , or blank, then... */
7593      if (unixpath[0] == '\0') {
7594         /* by definition, this is the answer */
7595         return SS$_NORMAL;
7596      }
7597
7598      /* Need to look up a directory */
7599      vmspath[15] = '[';
7600      vmspath[16] = '\0';
7601
7602      /* Copy and add '^' escape characters as needed */
7603      j = 16;
7604      i = 0;
7605      while (unixpath[i] != 0) {
7606      int k;
7607
7608         j += copy_expand_unix_filename_escape
7609             (&vmspath[j], &unixpath[i], &k, utf8_fl);
7610         i += k;
7611      }
7612
7613      path_len = strlen(vmspath);
7614      if (vmspath[path_len - 1] == '/')
7615         path_len--;
7616      vmspath[path_len] = ']';
7617      path_len++;
7618      vmspath[path_len] = '\0';
7619
7620   }
7621   vmspath[vmspath_len] = 0;
7622   if (unixpath[unixlen - 1] == '/')
7623   dir_flag = 1;
7624   esal = PerlMem_malloc(VMS_MAXRSS);
7625   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7626   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7627   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7628   rsal = PerlMem_malloc(VMS_MAXRSS);
7629   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7630   rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7631   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7632   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7633   rms_bind_fab_nam(myfab, mynam);
7634   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7635   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7636   if (decc_efs_case_preserve)
7637     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7638 #ifdef NAML$M_OPEN_SPECIAL
7639   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7640 #endif
7641
7642   /* Set up the remaining naml fields */
7643   sts = sys$parse(&myfab);
7644
7645   /* It failed! Try again as a UNIX filespec */
7646   if (!(sts & 1)) {
7647     PerlMem_free(esal);
7648     PerlMem_free(esa);
7649     PerlMem_free(rsal);
7650     PerlMem_free(rsa);
7651     return sts;
7652   }
7653
7654    /* get the Device ID and the FID */
7655    sts = sys$search(&myfab);
7656
7657    /* These are no longer needed */
7658    PerlMem_free(esa);
7659    PerlMem_free(rsal);
7660    PerlMem_free(rsa);
7661
7662    /* on any failure, returned the POSIX ^UP^ filespec */
7663    if (!(sts & 1)) {
7664       PerlMem_free(esal);
7665       return sts;
7666    }
7667    specdsc.dsc$a_pointer = vmspath;
7668    specdsc.dsc$w_length = vmspath_len;
7669
7670    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7671    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7672    sts = lib$fid_to_name
7673       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7674
7675   /* on any failure, returned the POSIX ^UP^ filespec */
7676   if (!(sts & 1)) {
7677      /* This can happen if user does not have permission to read directories */
7678      if (strncmp(unixpath,"\"^UP^",5) != 0)
7679        sprintf(vmspath,"\"^UP^%s\"",unixpath);
7680      else
7681        strcpy(vmspath, unixpath);
7682   }
7683   else {
7684     vmspath[specdsc.dsc$w_length] = 0;
7685
7686     /* Are we expecting a directory? */
7687     if (dir_flag != 0) {
7688     int i;
7689     char *eptr;
7690
7691       eptr = NULL;
7692
7693       i = specdsc.dsc$w_length - 1;
7694       while (i > 0) {
7695       int zercnt;
7696         zercnt = 0;
7697         /* Version must be '1' */
7698         if (vmspath[i--] != '1')
7699           break;
7700         /* Version delimiter is one of ".;" */
7701         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7702           break;
7703         i--;
7704         if (vmspath[i--] != 'R')
7705           break;
7706         if (vmspath[i--] != 'I')
7707           break;
7708         if (vmspath[i--] != 'D')
7709           break;
7710         if (vmspath[i--] != '.')
7711           break;
7712         eptr = &vmspath[i+1];
7713         while (i > 0) {
7714           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7715             if (vmspath[i-1] != '^') {
7716               if (zercnt != 6) {
7717                 *eptr = vmspath[i];
7718                 eptr[1] = '\0';
7719                 vmspath[i] = '.';
7720                 break;
7721               }
7722               else {
7723                 /* Get rid of 6 imaginary zero directory filename */
7724                 vmspath[i+1] = '\0';
7725               }
7726             }
7727           }
7728           if (vmspath[i] == '0')
7729             zercnt++;
7730           else
7731             zercnt = 10;
7732           i--;
7733         }
7734         break;
7735       }
7736     }
7737   }
7738   PerlMem_free(esal);
7739   return sts;
7740 }
7741
7742 /* /dev/mumble needs to be handled special.
7743    /dev/null becomes NLA0:, And there is the potential for other stuff
7744    like /dev/tty which may need to be mapped to something.
7745 */
7746
7747 static int
7748 slash_dev_special_to_vms
7749    (const char * unixptr,
7750     char * vmspath,
7751     int vmspath_len)
7752 {
7753 char * nextslash;
7754 int len;
7755 int cmp;
7756 int islnm;
7757
7758     unixptr += 4;
7759     nextslash = strchr(unixptr, '/');
7760     len = strlen(unixptr);
7761     if (nextslash != NULL)
7762         len = nextslash - unixptr;
7763     cmp = strncmp("null", unixptr, 5);
7764     if (cmp == 0) {
7765         if (vmspath_len >= 6) {
7766             strcpy(vmspath, "_NLA0:");
7767             return SS$_NORMAL;
7768         }
7769     }
7770 }
7771
7772
7773 /* The built in routines do not understand perl's special needs, so
7774     doing a manual conversion from UNIX to VMS
7775
7776     If the utf8_fl is not null and points to a non-zero value, then
7777     treat 8 bit characters as UTF-8.
7778
7779     The sequence starting with '$(' and ending with ')' will be passed
7780     through with out interpretation instead of being escaped.
7781
7782   */
7783 static int posix_to_vmsspec_hardway
7784   (char *vmspath, int vmspath_len,
7785    const char *unixpath,
7786    int dir_flag,
7787    int * utf8_fl) {
7788
7789 char *esa;
7790 const char *unixptr;
7791 const char *unixend;
7792 char *vmsptr;
7793 const char *lastslash;
7794 const char *lastdot;
7795 int unixlen;
7796 int vmslen;
7797 int dir_start;
7798 int dir_dot;
7799 int quoted;
7800 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7801 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7802
7803   if (utf8_fl != NULL)
7804     *utf8_fl = 0;
7805
7806   unixptr = unixpath;
7807   dir_dot = 0;
7808
7809   /* Ignore leading "/" characters */
7810   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7811     unixptr++;
7812   }
7813   unixlen = strlen(unixptr);
7814
7815   /* Do nothing with blank paths */
7816   if (unixlen == 0) {
7817     vmspath[0] = '\0';
7818     return SS$_NORMAL;
7819   }
7820
7821   quoted = 0;
7822   /* This could have a "^UP^ on the front */
7823   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7824     quoted = 1;
7825     unixptr+= 5;
7826     unixlen-= 5;
7827   }
7828
7829   lastslash = strrchr(unixptr,'/');
7830   lastdot = strrchr(unixptr,'.');
7831   unixend = strrchr(unixptr,'\"');
7832   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7833     unixend = unixptr + unixlen;
7834   }
7835
7836   /* last dot is last dot or past end of string */
7837   if (lastdot == NULL)
7838     lastdot = unixptr + unixlen;
7839
7840   /* if no directories, set last slash to beginning of string */
7841   if (lastslash == NULL) {
7842     lastslash = unixptr;
7843   }
7844   else {
7845     /* Watch out for trailing "." after last slash, still a directory */
7846     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7847       lastslash = unixptr + unixlen;
7848     }
7849
7850     /* Watch out for traiing ".." after last slash, still a directory */
7851     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7852       lastslash = unixptr + unixlen;
7853     }
7854
7855     /* dots in directories are aways escaped */
7856     if (lastdot < lastslash)
7857       lastdot = unixptr + unixlen;
7858   }
7859
7860   /* if (unixptr < lastslash) then we are in a directory */
7861
7862   dir_start = 0;
7863
7864   vmsptr = vmspath;
7865   vmslen = 0;
7866
7867   /* Start with the UNIX path */
7868   if (*unixptr != '/') {
7869     /* relative paths */
7870
7871     /* If allowing logical names on relative pathnames, then handle here */
7872     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7873         !decc_posix_compliant_pathnames) {
7874     char * nextslash;
7875     int seg_len;
7876     char * trn;
7877     int islnm;
7878
7879         /* Find the next slash */
7880         nextslash = strchr(unixptr,'/');
7881
7882         esa = PerlMem_malloc(vmspath_len);
7883         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7884
7885         trn = PerlMem_malloc(VMS_MAXRSS);
7886         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7887
7888         if (nextslash != NULL) {
7889
7890             seg_len = nextslash - unixptr;
7891             strncpy(esa, unixptr, seg_len);
7892             esa[seg_len] = 0;
7893         }
7894         else {
7895             strcpy(esa, unixptr);
7896             seg_len = strlen(unixptr);
7897         }
7898         /* trnlnm(section) */
7899         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7900
7901         if (islnm) {
7902             /* Now fix up the directory */
7903
7904             /* Split up the path to find the components */
7905             sts = vms_split_path
7906                   (trn,
7907                    &v_spec,
7908                    &v_len,
7909                    &r_spec,
7910                    &r_len,
7911                    &d_spec,
7912                    &d_len,
7913                    &n_spec,
7914                    &n_len,
7915                    &e_spec,
7916                    &e_len,
7917                    &vs_spec,
7918                    &vs_len);
7919
7920             while (sts == 0) {
7921             char * strt;
7922             int cmp;
7923
7924                 /* A logical name must be a directory  or the full
7925                    specification.  It is only a full specification if
7926                    it is the only component */
7927                 if ((unixptr[seg_len] == '\0') ||
7928                     (unixptr[seg_len+1] == '\0')) {
7929
7930                     /* Is a directory being required? */
7931                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7932                         /* Not a logical name */
7933                         break;
7934                     }
7935
7936
7937                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7938                         /* This must be a directory */
7939                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7940                             strcpy(vmsptr, esa);
7941                             vmslen=strlen(vmsptr);
7942                             vmsptr[vmslen] = ':';
7943                             vmslen++;
7944                             vmsptr[vmslen] = '\0';
7945                             return SS$_NORMAL;
7946                         }
7947                     }
7948
7949                 }
7950
7951
7952                 /* must be dev/directory - ignore version */
7953                 if ((n_len + e_len) != 0)
7954                     break;
7955
7956                 /* transfer the volume */
7957                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7958                     strncpy(vmsptr, v_spec, v_len);
7959                     vmsptr += v_len;
7960                     vmsptr[0] = '\0';
7961                     vmslen += v_len;
7962                 }
7963
7964                 /* unroot the rooted directory */
7965                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7966                     r_spec[0] = '[';
7967                     r_spec[r_len - 1] = ']';
7968
7969                     /* This should not be there, but nothing is perfect */
7970                     if (r_len > 9) {
7971                         cmp = strcmp(&r_spec[1], "000000.");
7972                         if (cmp == 0) {
7973                             r_spec += 7;
7974                             r_spec[7] = '[';
7975                             r_len -= 7;
7976                             if (r_len == 2)
7977                                 r_len = 0;
7978                         }
7979                     }
7980                     if (r_len > 0) {
7981                         strncpy(vmsptr, r_spec, r_len);
7982                         vmsptr += r_len;
7983                         vmslen += r_len;
7984                         vmsptr[0] = '\0';
7985                     }
7986                 }
7987                 /* Bring over the directory. */
7988                 if ((d_len > 0) &&
7989                     ((d_len + vmslen) < vmspath_len)) {
7990                     d_spec[0] = '[';
7991                     d_spec[d_len - 1] = ']';
7992                     if (d_len > 9) {
7993                         cmp = strcmp(&d_spec[1], "000000.");
7994                         if (cmp == 0) {
7995                             d_spec += 7;
7996                             d_spec[7] = '[';
7997                             d_len -= 7;
7998                             if (d_len == 2)
7999                                 d_len = 0;
8000                         }
8001                     }
8002
8003                     if (r_len > 0) {
8004                         /* Remove the redundant root */
8005                         if (r_len > 0) {
8006                             /* remove the ][ */
8007                             vmsptr--;
8008                             vmslen--;
8009                             d_spec++;
8010                             d_len--;
8011                         }
8012                         strncpy(vmsptr, d_spec, d_len);
8013                             vmsptr += d_len;
8014                             vmslen += d_len;
8015                             vmsptr[0] = '\0';
8016                     }
8017                 }
8018                 break;
8019             }
8020         }
8021
8022         PerlMem_free(esa);
8023         PerlMem_free(trn);
8024     }
8025
8026     if (lastslash > unixptr) {
8027     int dotdir_seen;
8028
8029       /* skip leading ./ */
8030       dotdir_seen = 0;
8031       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
8032         dotdir_seen = 1;
8033         unixptr++;
8034         unixptr++;
8035       }
8036
8037       /* Are we still in a directory? */
8038       if (unixptr <= lastslash) {
8039         *vmsptr++ = '[';
8040         vmslen = 1;
8041         dir_start = 1;
8042
8043         /* if not backing up, then it is relative forward. */
8044         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
8045               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
8046           *vmsptr++ = '.';
8047           vmslen++;
8048           dir_dot = 1;
8049           }
8050        }
8051        else {
8052          if (dotdir_seen) {
8053            /* Perl wants an empty directory here to tell the difference
8054             * between a DCL commmand and a filename
8055             */
8056           *vmsptr++ = '[';
8057           *vmsptr++ = ']';
8058           vmslen = 2;
8059         }
8060       }
8061     }
8062     else {
8063       /* Handle two special files . and .. */
8064       if (unixptr[0] == '.') {
8065         if (&unixptr[1] == unixend) {
8066           *vmsptr++ = '[';
8067           *vmsptr++ = ']';
8068           vmslen += 2;
8069           *vmsptr++ = '\0';
8070           return SS$_NORMAL;
8071         }
8072         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
8073           *vmsptr++ = '[';
8074           *vmsptr++ = '-';
8075           *vmsptr++ = ']';
8076           vmslen += 3;
8077           *vmsptr++ = '\0';
8078           return SS$_NORMAL;
8079         }
8080       }
8081     }
8082   }
8083   else {        /* Absolute PATH handling */
8084   int sts;
8085   char * nextslash;
8086   int seg_len;
8087     /* Need to find out where root is */
8088
8089     /* In theory, this procedure should never get an absolute POSIX pathname
8090      * that can not be found on the POSIX root.
8091      * In practice, that can not be relied on, and things will show up
8092      * here that are a VMS device name or concealed logical name instead.
8093      * So to make things work, this procedure must be tolerant.
8094      */
8095     esa = PerlMem_malloc(vmspath_len);
8096     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8097
8098     sts = SS$_NORMAL;
8099     nextslash = strchr(&unixptr[1],'/');
8100     seg_len = 0;
8101     if (nextslash != NULL) {
8102     int cmp;
8103       seg_len = nextslash - &unixptr[1];
8104       strncpy(vmspath, unixptr, seg_len + 1);
8105       vmspath[seg_len+1] = 0;
8106       cmp = 1;
8107       if (seg_len == 3) {
8108         cmp = strncmp(vmspath, "dev", 4);
8109         if (cmp == 0) {
8110             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
8111             if (sts = SS$_NORMAL)
8112                 return SS$_NORMAL;
8113         }
8114       }
8115       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
8116     }
8117
8118     if ($VMS_STATUS_SUCCESS(sts)) {
8119       /* This is verified to be a real path */
8120
8121       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
8122       if ($VMS_STATUS_SUCCESS(sts)) {
8123         strcpy(vmspath, esa);
8124         vmslen = strlen(vmspath);
8125         vmsptr = vmspath + vmslen;
8126         unixptr++;
8127         if (unixptr < lastslash) {
8128         char * rptr;
8129           vmsptr--;
8130           *vmsptr++ = '.';
8131           dir_start = 1;
8132           dir_dot = 1;
8133           if (vmslen > 7) {
8134           int cmp;
8135             rptr = vmsptr - 7;
8136             cmp = strcmp(rptr,"000000.");
8137             if (cmp == 0) {
8138               vmslen -= 7;
8139               vmsptr -= 7;
8140               vmsptr[1] = '\0';
8141             } /* removing 6 zeros */
8142           } /* vmslen < 7, no 6 zeros possible */
8143         } /* Not in a directory */
8144       } /* Posix root found */
8145       else {
8146         /* No posix root, fall back to default directory */
8147         strcpy(vmspath, "SYS$DISK:[");
8148         vmsptr = &vmspath[10];
8149         vmslen = 10;
8150         if (unixptr > lastslash) {
8151            *vmsptr = ']';
8152            vmsptr++;
8153            vmslen++;
8154         }
8155         else {
8156            dir_start = 1;
8157         }
8158       }
8159     } /* end of verified real path handling */
8160     else {
8161     int add_6zero;
8162     int islnm;
8163
8164       /* Ok, we have a device or a concealed root that is not in POSIX
8165        * or we have garbage.  Make the best of it.
8166        */
8167
8168       /* Posix to VMS destroyed this, so copy it again */
8169       strncpy(vmspath, &unixptr[1], seg_len);
8170       vmspath[seg_len] = 0;
8171       vmslen = seg_len;
8172       vmsptr = &vmsptr[vmslen];
8173       islnm = 0;
8174
8175       /* Now do we need to add the fake 6 zero directory to it? */
8176       add_6zero = 1;
8177       if ((*lastslash == '/') && (nextslash < lastslash)) {
8178         /* No there is another directory */
8179         add_6zero = 0;
8180       }
8181       else {
8182       int trnend;
8183       int cmp;
8184
8185         /* now we have foo:bar or foo:[000000]bar to decide from */
8186         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
8187
8188         if (!islnm && !decc_posix_compliant_pathnames) {
8189
8190             cmp = strncmp("bin", vmspath, 4);
8191             if (cmp == 0) {
8192                 /* bin => SYS$SYSTEM: */
8193                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
8194             }
8195             else {
8196                 /* tmp => SYS$SCRATCH: */
8197                 cmp = strncmp("tmp", vmspath, 4);
8198                 if (cmp == 0) {
8199                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
8200                 }
8201             }
8202         }
8203
8204         trnend = islnm ? islnm - 1 : 0;
8205
8206         /* if this was a logical name, ']' or '>' must be present */
8207         /* if not a logical name, then assume a device and hope. */
8208         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
8209
8210         /* if log name and trailing '.' then rooted - treat as device */
8211         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
8212
8213         /* Fix me, if not a logical name, a device lookup should be
8214          * done to see if the device is file structured.  If the device
8215          * is not file structured, the 6 zeros should not be put on.
8216          *
8217          * As it is, perl is occasionally looking for dev:[000000]tty.
8218          * which looks a little strange.
8219          *
8220          * Not that easy to detect as "/dev" may be file structured with
8221          * special device files.
8222          */
8223
8224         if ((add_6zero == 0) && (*nextslash == '/') &&
8225             (&nextslash[1] == unixend)) {
8226           /* No real directory present */
8227           add_6zero = 1;
8228         }
8229       }
8230
8231       /* Put the device delimiter on */
8232       *vmsptr++ = ':';
8233       vmslen++;
8234       unixptr = nextslash;
8235       unixptr++;
8236
8237       /* Start directory if needed */
8238       if (!islnm || add_6zero) {
8239         *vmsptr++ = '[';
8240         vmslen++;
8241         dir_start = 1;
8242       }
8243
8244       /* add fake 000000] if needed */
8245       if (add_6zero) {
8246         *vmsptr++ = '0';
8247         *vmsptr++ = '0';
8248         *vmsptr++ = '0';
8249         *vmsptr++ = '0';
8250         *vmsptr++ = '0';
8251         *vmsptr++ = '0';
8252         *vmsptr++ = ']';
8253         vmslen += 7;
8254         dir_start = 0;
8255       }
8256
8257     } /* non-POSIX translation */
8258     PerlMem_free(esa);
8259   } /* End of relative/absolute path handling */
8260
8261   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
8262   int dash_flag;
8263   int in_cnt;
8264   int out_cnt;
8265
8266     dash_flag = 0;
8267
8268     if (dir_start != 0) {
8269
8270       /* First characters in a directory are handled special */
8271       while ((*unixptr == '/') ||
8272              ((*unixptr == '.') &&
8273               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8274                 (&unixptr[1]==unixend)))) {
8275       int loop_flag;
8276
8277         loop_flag = 0;
8278
8279         /* Skip redundant / in specification */
8280         while ((*unixptr == '/') && (dir_start != 0)) {
8281           loop_flag = 1;
8282           unixptr++;
8283           if (unixptr == lastslash)
8284             break;
8285         }
8286         if (unixptr == lastslash)
8287           break;
8288
8289         /* Skip redundant ./ characters */
8290         while ((*unixptr == '.') &&
8291                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8292           loop_flag = 1;
8293           unixptr++;
8294           if (unixptr == lastslash)
8295             break;
8296           if (*unixptr == '/')
8297             unixptr++;
8298         }
8299         if (unixptr == lastslash)
8300           break;
8301
8302         /* Skip redundant ../ characters */
8303         while ((*unixptr == '.') && (unixptr[1] == '.') &&
8304              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8305           /* Set the backing up flag */
8306           loop_flag = 1;
8307           dir_dot = 0;
8308           dash_flag = 1;
8309           *vmsptr++ = '-';
8310           vmslen++;
8311           unixptr++; /* first . */
8312           unixptr++; /* second . */
8313           if (unixptr == lastslash)
8314             break;
8315           if (*unixptr == '/') /* The slash */
8316             unixptr++;
8317         }
8318         if (unixptr == lastslash)
8319           break;
8320
8321         /* To do: Perl expects /.../ to be translated to [...] on VMS */
8322         /* Not needed when VMS is pretending to be UNIX. */
8323
8324         /* Is this loop stuck because of too many dots? */
8325         if (loop_flag == 0) {
8326           /* Exit the loop and pass the rest through */
8327           break;
8328         }
8329       }
8330
8331       /* Are we done with directories yet? */
8332       if (unixptr >= lastslash) {
8333
8334         /* Watch out for trailing dots */
8335         if (dir_dot != 0) {
8336             vmslen --;
8337             vmsptr--;
8338         }
8339         *vmsptr++ = ']';
8340         vmslen++;
8341         dash_flag = 0;
8342         dir_start = 0;
8343         if (*unixptr == '/')
8344           unixptr++;
8345       }
8346       else {
8347         /* Have we stopped backing up? */
8348         if (dash_flag) {
8349           *vmsptr++ = '.';
8350           vmslen++;
8351           dash_flag = 0;
8352           /* dir_start continues to be = 1 */
8353         }
8354         if (*unixptr == '-') {
8355           *vmsptr++ = '^';
8356           *vmsptr++ = *unixptr++;
8357           vmslen += 2;
8358           dir_start = 0;
8359
8360           /* Now are we done with directories yet? */
8361           if (unixptr >= lastslash) {
8362
8363             /* Watch out for trailing dots */
8364             if (dir_dot != 0) {
8365               vmslen --;
8366               vmsptr--;
8367             }
8368
8369             *vmsptr++ = ']';
8370             vmslen++;
8371             dash_flag = 0;
8372             dir_start = 0;
8373           }
8374         }
8375       }
8376     }
8377
8378     /* All done? */
8379     if (unixptr >= unixend)
8380       break;
8381
8382     /* Normal characters - More EFS work probably needed */
8383     dir_start = 0;
8384     dir_dot = 0;
8385
8386     switch(*unixptr) {
8387     case '/':
8388         /* remove multiple / */
8389         while (unixptr[1] == '/') {
8390            unixptr++;
8391         }
8392         if (unixptr == lastslash) {
8393           /* Watch out for trailing dots */
8394           if (dir_dot != 0) {
8395             vmslen --;
8396             vmsptr--;
8397           }
8398           *vmsptr++ = ']';
8399         }
8400         else {
8401           dir_start = 1;
8402           *vmsptr++ = '.';
8403           dir_dot = 1;
8404
8405           /* To do: Perl expects /.../ to be translated to [...] on VMS */
8406           /* Not needed when VMS is pretending to be UNIX. */
8407
8408         }
8409         dash_flag = 0;
8410         if (unixptr != unixend)
8411           unixptr++;
8412         vmslen++;
8413         break;
8414     case '.':
8415         if ((unixptr < lastdot) || (unixptr < lastslash) ||
8416             (&unixptr[1] == unixend)) {
8417           *vmsptr++ = '^';
8418           *vmsptr++ = '.';
8419           vmslen += 2;
8420           unixptr++;
8421
8422           /* trailing dot ==> '^..' on VMS */
8423           if (unixptr == unixend) {
8424             *vmsptr++ = '.';
8425             vmslen++;
8426             unixptr++;
8427           }
8428           break;
8429         }
8430
8431         *vmsptr++ = *unixptr++;
8432         vmslen ++;
8433         break;
8434     case '"':
8435         if (quoted && (&unixptr[1] == unixend)) {
8436             unixptr++;
8437             break;
8438         }
8439         in_cnt = copy_expand_unix_filename_escape
8440                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8441         vmsptr += out_cnt;
8442         unixptr += in_cnt;
8443         break;
8444     case '~':
8445     case ';':
8446     case '\\':
8447     case '?':
8448     case ' ':
8449     default:
8450         in_cnt = copy_expand_unix_filename_escape
8451                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8452         vmsptr += out_cnt;
8453         unixptr += in_cnt;
8454         break;
8455     }
8456   }
8457
8458   /* Make sure directory is closed */
8459   if (unixptr == lastslash) {
8460     char *vmsptr2;
8461     vmsptr2 = vmsptr - 1;
8462
8463     if (*vmsptr2 != ']') {
8464       *vmsptr2--;
8465
8466       /* directories do not end in a dot bracket */
8467       if (*vmsptr2 == '.') {
8468         vmsptr2--;
8469
8470         /* ^. is allowed */
8471         if (*vmsptr2 != '^') {
8472           vmsptr--; /* back up over the dot */
8473         }
8474       }
8475       *vmsptr++ = ']';
8476     }
8477   }
8478   else {
8479     char *vmsptr2;
8480     /* Add a trailing dot if a file with no extension */
8481     vmsptr2 = vmsptr - 1;
8482     if ((vmslen > 1) &&
8483         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8484         (*vmsptr2 != ')') && (*lastdot != '.')) {
8485         *vmsptr++ = '.';
8486         vmslen++;
8487     }
8488   }
8489
8490   *vmsptr = '\0';
8491   return SS$_NORMAL;
8492 }
8493 #endif
8494
8495  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
8496 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
8497 {
8498 char * result;
8499 int utf8_flag;
8500
8501    /* If a UTF8 flag is being passed, honor it */
8502    utf8_flag = 0;
8503    if (utf8_fl != NULL) {
8504      utf8_flag = *utf8_fl;
8505     *utf8_fl = 0;
8506    }
8507
8508    if (utf8_flag) {
8509      /* If there is a possibility of UTF8, then if any UTF8 characters
8510         are present, then they must be converted to VTF-7
8511       */
8512      result = strcpy(rslt, path); /* FIX-ME */
8513    }
8514    else
8515      result = strcpy(rslt, path);
8516
8517    return result;
8518 }
8519
8520
8521
8522 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8523 static char *int_tovmsspec
8524    (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
8525   char *dirend;
8526   char *lastdot;
8527   char *vms_delim;
8528   register char *cp1;
8529   const char *cp2;
8530   unsigned long int infront = 0, hasdir = 1;
8531   int rslt_len;
8532   int no_type_seen;
8533   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8534   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8535
8536   if (vms_debug_fileify) {
8537       if (path == NULL)
8538           fprintf(stderr, "int_tovmsspec: path = NULL\n");
8539       else
8540           fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8541   }
8542
8543   if (path == NULL) {
8544       /* If we fail, we should be setting errno */
8545       set_errno(EINVAL);
8546       set_vaxc_errno(SS$_BADPARAM);
8547       return NULL;
8548   }
8549   rslt_len = VMS_MAXRSS-1;
8550
8551   /* '.' and '..' are "[]" and "[-]" for a quick check */
8552   if (path[0] == '.') {
8553     if (path[1] == '\0') {
8554       strcpy(rslt,"[]");
8555       if (utf8_flag != NULL)
8556         *utf8_flag = 0;
8557       return rslt;
8558     }
8559     else {
8560       if (path[1] == '.' && path[2] == '\0') {
8561         strcpy(rslt,"[-]");
8562         if (utf8_flag != NULL)
8563            *utf8_flag = 0;
8564         return rslt;
8565       }
8566     }
8567   }
8568
8569    /* Posix specifications are now a native VMS format */
8570   /*--------------------------------------------------*/
8571 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8572   if (decc_posix_compliant_pathnames) {
8573     if (strncmp(path,"\"^UP^",5) == 0) {
8574       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8575       return rslt;
8576     }
8577   }
8578 #endif
8579
8580   /* This is really the only way to see if this is already in VMS format */
8581   sts = vms_split_path
8582        (path,
8583         &v_spec,
8584         &v_len,
8585         &r_spec,
8586         &r_len,
8587         &d_spec,
8588         &d_len,
8589         &n_spec,
8590         &n_len,
8591         &e_spec,
8592         &e_len,
8593         &vs_spec,
8594         &vs_len);
8595   if (sts == 0) {
8596     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8597        replacement, because the above parse just took care of most of
8598        what is needed to do vmspath when the specification is already
8599        in VMS format.
8600
8601        And if it is not already, it is easier to do the conversion as
8602        part of this routine than to call this routine and then work on
8603        the result.
8604      */
8605
8606     /* If VMS punctuation was found, it is already VMS format */
8607     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8608       if (utf8_flag != NULL)
8609         *utf8_flag = 0;
8610       strcpy(rslt, path);
8611       if (vms_debug_fileify) {
8612           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8613       }
8614       return rslt;
8615     }
8616     /* Now, what to do with trailing "." cases where there is no
8617        extension?  If this is a UNIX specification, and EFS characters
8618        are enabled, then the trailing "." should be converted to a "^.".
8619        But if this was already a VMS specification, then it should be
8620        left alone.
8621
8622        So in the case of ambiguity, leave the specification alone.
8623      */
8624
8625
8626     /* If there is a possibility of UTF8, then if any UTF8 characters
8627         are present, then they must be converted to VTF-7
8628      */
8629     if (utf8_flag != NULL)
8630       *utf8_flag = 0;
8631     strcpy(rslt, path);
8632     if (vms_debug_fileify) {
8633         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8634     }
8635     return rslt;
8636   }
8637
8638   dirend = strrchr(path,'/');
8639
8640   if (dirend == NULL) {
8641      char *macro_start;
8642      int has_macro;
8643
8644      /* If we get here with no UNIX directory delimiters, then this is
8645         not a complete file specification, either garbage a UNIX glob
8646         specification that can not be converted to a VMS wildcard, or
8647         it a UNIX shell macro.  MakeMaker wants shell macros passed
8648         through AS-IS,
8649
8650         utf8 flag setting needs to be preserved.
8651       */
8652       hasdir = 0;
8653
8654       has_macro = 0;
8655       macro_start = strchr(path,'$');
8656       if (macro_start != NULL) {
8657           if (macro_start[1] == '(') {
8658               has_macro = 1;
8659           }
8660       }
8661       if ((decc_efs_charset == 0) || (has_macro)) {
8662           strcpy(rslt, path);
8663           if (vms_debug_fileify) {
8664               fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8665           }
8666           return rslt;
8667       }
8668   }
8669
8670 /* If POSIX mode active, handle the conversion */
8671 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8672   if (decc_efs_charset) {
8673     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8674     if (vms_debug_fileify) {
8675         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8676     }
8677     return rslt;
8678   }
8679 #endif
8680
8681   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
8682     if (!*(dirend+2)) dirend +=2;
8683     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8684     if (decc_efs_charset == 0) {
8685       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8686     }
8687   }
8688
8689   cp1 = rslt;
8690   cp2 = path;
8691   lastdot = strrchr(cp2,'.');
8692   if (*cp2 == '/') {
8693     char *trndev;
8694     int islnm, rooted;
8695     STRLEN trnend;
8696
8697     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8698     if (!*(cp2+1)) {
8699       if (decc_disable_posix_root) {
8700         strcpy(rslt,"sys$disk:[000000]");
8701       }
8702       else {
8703         strcpy(rslt,"sys$posix_root:[000000]");
8704       }
8705       if (utf8_flag != NULL)
8706         *utf8_flag = 0;
8707       if (vms_debug_fileify) {
8708           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8709       }
8710       return rslt;
8711     }
8712     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8713     *cp1 = '\0';
8714     trndev = PerlMem_malloc(VMS_MAXRSS);
8715     if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8716     islnm =  simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8717
8718      /* DECC special handling */
8719     if (!islnm) {
8720       if (strcmp(rslt,"bin") == 0) {
8721         strcpy(rslt,"sys$system");
8722         cp1 = rslt + 10;
8723         *cp1 = 0;
8724         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8725       }
8726       else if (strcmp(rslt,"tmp") == 0) {
8727         strcpy(rslt,"sys$scratch");
8728         cp1 = rslt + 11;
8729         *cp1 = 0;
8730         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8731       }
8732       else if (!decc_disable_posix_root) {
8733         strcpy(rslt, "sys$posix_root");
8734         cp1 = rslt + 14;
8735         *cp1 = 0;
8736         cp2 = path;
8737         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8738         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8739       }
8740       else if (strcmp(rslt,"dev") == 0) {
8741         if (strncmp(cp2,"/null", 5) == 0) {
8742           if ((cp2[5] == 0) || (cp2[5] == '/')) {
8743             strcpy(rslt,"NLA0");
8744             cp1 = rslt + 4;
8745             *cp1 = 0;
8746             cp2 = cp2 + 5;
8747             islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8748           }
8749         }
8750       }
8751     }
8752
8753     trnend = islnm ? strlen(trndev) - 1 : 0;
8754     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8755     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8756     /* If the first element of the path is a logical name, determine
8757      * whether it has to be translated so we can add more directories. */
8758     if (!islnm || rooted) {
8759       *(cp1++) = ':';
8760       *(cp1++) = '[';
8761       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8762       else cp2++;
8763     }
8764     else {
8765       if (cp2 != dirend) {
8766         strcpy(rslt,trndev);
8767         cp1 = rslt + trnend;
8768         if (*cp2 != 0) {
8769           *(cp1++) = '.';
8770           cp2++;
8771         }
8772       }
8773       else {
8774         if (decc_disable_posix_root) {
8775           *(cp1++) = ':';
8776           hasdir = 0;
8777         }
8778       }
8779     }
8780     PerlMem_free(trndev);
8781   }
8782   else {
8783     *(cp1++) = '[';
8784     if (*cp2 == '.') {
8785       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8786         cp2 += 2;         /* skip over "./" - it's redundant */
8787         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8788       }
8789       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8790         *(cp1++) = '-';                                 /* "../" --> "-" */
8791         cp2 += 3;
8792       }
8793       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8794                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8795         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8796         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8797         cp2 += 4;
8798       }
8799       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8800         /* Escape the extra dots in EFS file specifications */
8801         *(cp1++) = '^';
8802       }
8803       if (cp2 > dirend) cp2 = dirend;
8804     }
8805     else *(cp1++) = '.';
8806   }
8807   for (; cp2 < dirend; cp2++) {
8808     if (*cp2 == '/') {
8809       if (*(cp2-1) == '/') continue;
8810       if (*(cp1-1) != '.') *(cp1++) = '.';
8811       infront = 0;
8812     }
8813     else if (!infront && *cp2 == '.') {
8814       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8815       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8816       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8817         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8818         else if (*(cp1-2) == '[') *(cp1-1) = '-';
8819         else {  /* back up over previous directory name */
8820           cp1--;
8821           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
8822           if (*(cp1-1) == '[') {
8823             memcpy(cp1,"000000.",7);
8824             cp1 += 7;
8825           }
8826         }
8827         cp2 += 2;
8828         if (cp2 == dirend) break;
8829       }
8830       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8831                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8832         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8833         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8834         if (!*(cp2+3)) {
8835           *(cp1++) = '.';  /* Simulate trailing '/' */
8836           cp2 += 2;  /* for loop will incr this to == dirend */
8837         }
8838         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8839       }
8840       else {
8841         if (decc_efs_charset == 0)
8842           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8843         else {
8844           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
8845           *(cp1++) = '.';
8846         }
8847       }
8848     }
8849     else {
8850       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
8851       if (*cp2 == '.') {
8852         if (decc_efs_charset == 0)
8853           *(cp1++) = '_';
8854         else {
8855           *(cp1++) = '^';
8856           *(cp1++) = '.';
8857         }
8858       }
8859       else                  *(cp1++) =  *cp2;
8860       infront = 1;
8861     }
8862   }
8863   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8864   if (hasdir) *(cp1++) = ']';
8865   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
8866   /* fixme for ODS5 */
8867   no_type_seen = 0;
8868   if (cp2 > lastdot)
8869     no_type_seen = 1;
8870   while (*cp2) {
8871     switch(*cp2) {
8872     case '?':
8873         if (decc_efs_charset == 0)
8874           *(cp1++) = '%';
8875         else
8876           *(cp1++) = '?';
8877         cp2++;
8878     case ' ':
8879         *(cp1)++ = '^';
8880         *(cp1)++ = '_';
8881         cp2++;
8882         break;
8883     case '.':
8884         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8885             decc_readdir_dropdotnotype) {
8886           *(cp1)++ = '^';
8887           *(cp1)++ = '.';
8888           cp2++;
8889
8890           /* trailing dot ==> '^..' on VMS */
8891           if (*cp2 == '\0') {
8892             *(cp1++) = '.';
8893             no_type_seen = 0;
8894           }
8895         }
8896         else {
8897           *(cp1++) = *(cp2++);
8898           no_type_seen = 0;
8899         }
8900         break;
8901     case '$':
8902          /* This could be a macro to be passed through */
8903         *(cp1++) = *(cp2++);
8904         if (*cp2 == '(') {
8905         const char * save_cp2;
8906         char * save_cp1;
8907         int is_macro;
8908
8909             /* paranoid check */
8910             save_cp2 = cp2;
8911             save_cp1 = cp1;
8912             is_macro = 0;
8913
8914             /* Test through */
8915             *(cp1++) = *(cp2++);
8916             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8917                 *(cp1++) = *(cp2++);
8918                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8919                     *(cp1++) = *(cp2++);
8920                 }
8921                 if (*cp2 == ')') {
8922                     *(cp1++) = *(cp2++);
8923                     is_macro = 1;
8924                 }
8925             }
8926             if (is_macro == 0) {
8927                 /* Not really a macro - never mind */
8928                 cp2 = save_cp2;
8929                 cp1 = save_cp1;
8930             }
8931         }
8932         break;
8933     case '\"':
8934     case '~':
8935     case '`':
8936     case '!':
8937     case '#':
8938     case '%':
8939     case '^':
8940         /* Don't escape again if following character is
8941          * already something we escape.
8942          */
8943         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8944             *(cp1++) = *(cp2++);
8945             break;
8946         }
8947         /* But otherwise fall through and escape it. */
8948     case '&':
8949     case '(':
8950     case ')':
8951     case '=':
8952     case '+':
8953     case '\'':
8954     case '@':
8955     case '[':
8956     case ']':
8957     case '{':
8958     case '}':
8959     case ':':
8960     case '\\':
8961     case '|':
8962     case '<':
8963     case '>':
8964         *(cp1++) = '^';
8965         *(cp1++) = *(cp2++);
8966         break;
8967     case ';':
8968         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8969          * which is wrong.  UNIX notation should be ".dir." unless
8970          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8971          * changing this behavior could break more things at this time.
8972          * efs character set effectively does not allow "." to be a version
8973          * delimiter as a further complication about changing this.
8974          */
8975         if (decc_filename_unix_report != 0) {
8976           *(cp1++) = '^';
8977         }
8978         *(cp1++) = *(cp2++);
8979         break;
8980     default:
8981         *(cp1++) = *(cp2++);
8982     }
8983   }
8984   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8985   char *lcp1;
8986     lcp1 = cp1;
8987     lcp1--;
8988      /* Fix me for "^]", but that requires making sure that you do
8989       * not back up past the start of the filename
8990       */
8991     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8992       *cp1++ = '.';
8993   }
8994   *cp1 = '\0';
8995
8996   if (utf8_flag != NULL)
8997     *utf8_flag = 0;
8998   if (vms_debug_fileify) {
8999       fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
9000   }
9001   return rslt;
9002
9003 }  /* end of int_tovmsspec() */
9004
9005
9006 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
9007 static char *mp_do_tovmsspec
9008    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
9009   static char __tovmsspec_retbuf[VMS_MAXRSS];
9010     char * vmsspec, *ret_spec, *ret_buf;
9011
9012     vmsspec = NULL;
9013     ret_buf = buf;
9014     if (ret_buf == NULL) {
9015         if (ts) {
9016             Newx(vmsspec, VMS_MAXRSS, char);
9017             if (vmsspec == NULL)
9018                 _ckvmssts(SS$_INSFMEM);
9019             ret_buf = vmsspec;
9020         } else {
9021             ret_buf = __tovmsspec_retbuf;
9022         }
9023     }
9024
9025     ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
9026
9027     if (ret_spec == NULL) {
9028        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
9029        if (vmsspec)
9030            Safefree(vmsspec);
9031     }
9032
9033     return ret_spec;
9034
9035 }  /* end of mp_do_tovmsspec() */
9036 /*}}}*/
9037 /* External entry points */
9038 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
9039   { return do_tovmsspec(path,buf,0,NULL); }
9040 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
9041   { return do_tovmsspec(path,buf,1,NULL); }
9042 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9043   { return do_tovmsspec(path,buf,0,utf8_fl); }
9044 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9045   { return do_tovmsspec(path,buf,1,utf8_fl); }
9046
9047 /*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
9048 /* Internal routine for use with out an explict context present */
9049 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl) {
9050
9051     char * ret_spec, *pathified;
9052
9053     if (path == NULL)
9054         return NULL;
9055
9056     pathified = PerlMem_malloc(VMS_MAXRSS);
9057     if (pathified == NULL)
9058         _ckvmssts_noperl(SS$_INSFMEM);
9059
9060     ret_spec = int_pathify_dirspec(path, pathified);
9061
9062     if (ret_spec == NULL) {
9063         PerlMem_free(pathified);
9064         return NULL;
9065     }
9066
9067     ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
9068
9069     PerlMem_free(pathified);
9070     return ret_spec;
9071
9072 }
9073
9074 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
9075 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
9076   static char __tovmspath_retbuf[VMS_MAXRSS];
9077   int vmslen;
9078   char *pathified, *vmsified, *cp;
9079
9080   if (path == NULL) return NULL;
9081   pathified = PerlMem_malloc(VMS_MAXRSS);
9082   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
9083   if (int_pathify_dirspec(path, pathified) == NULL) {
9084     PerlMem_free(pathified);
9085     return NULL;
9086   }
9087
9088   vmsified = NULL;
9089   if (buf == NULL)
9090      Newx(vmsified, VMS_MAXRSS, char);
9091   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
9092     PerlMem_free(pathified);
9093     if (vmsified) Safefree(vmsified);
9094     return NULL;
9095   }
9096   PerlMem_free(pathified);
9097   if (buf) {
9098     return buf;
9099   }
9100   else if (ts) {
9101     vmslen = strlen(vmsified);
9102     Newx(cp,vmslen+1,char);
9103     memcpy(cp,vmsified,vmslen);
9104     cp[vmslen] = '\0';
9105     Safefree(vmsified);
9106     return cp;
9107   }
9108   else {
9109     strcpy(__tovmspath_retbuf,vmsified);
9110     Safefree(vmsified);
9111     return __tovmspath_retbuf;
9112   }
9113
9114 }  /* end of do_tovmspath() */
9115 /*}}}*/
9116 /* External entry points */
9117 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
9118   { return do_tovmspath(path,buf,0, NULL); }
9119 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
9120   { return do_tovmspath(path,buf,1, NULL); }
9121 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
9122   { return do_tovmspath(path,buf,0,utf8_fl); }
9123 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
9124   { return do_tovmspath(path,buf,1,utf8_fl); }
9125
9126
9127 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
9128 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
9129   static char __tounixpath_retbuf[VMS_MAXRSS];
9130   int unixlen;
9131   char *pathified, *unixified, *cp;
9132
9133   if (path == NULL) return NULL;
9134   pathified = PerlMem_malloc(VMS_MAXRSS);
9135   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
9136   if (int_pathify_dirspec(path, pathified) == NULL) {
9137     PerlMem_free(pathified);
9138     return NULL;
9139   }
9140
9141   unixified = NULL;
9142   if (buf == NULL) {
9143       Newx(unixified, VMS_MAXRSS, char);
9144   }
9145   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
9146     PerlMem_free(pathified);
9147     if (unixified) Safefree(unixified);
9148     return NULL;
9149   }
9150   PerlMem_free(pathified);
9151   if (buf) {
9152     return buf;
9153   }
9154   else if (ts) {
9155     unixlen = strlen(unixified);
9156     Newx(cp,unixlen+1,char);
9157     memcpy(cp,unixified,unixlen);
9158     cp[unixlen] = '\0';
9159     Safefree(unixified);
9160     return cp;
9161   }
9162   else {
9163     strcpy(__tounixpath_retbuf,unixified);
9164     Safefree(unixified);
9165     return __tounixpath_retbuf;
9166   }
9167
9168 }  /* end of do_tounixpath() */
9169 /*}}}*/
9170 /* External entry points */
9171 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
9172   { return do_tounixpath(path,buf,0,NULL); }
9173 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
9174   { return do_tounixpath(path,buf,1,NULL); }
9175 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9176   { return do_tounixpath(path,buf,0,utf8_fl); }
9177 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9178   { return do_tounixpath(path,buf,1,utf8_fl); }
9179
9180 /*
9181  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
9182  *
9183  *****************************************************************************
9184  *                                                                           *
9185  *  Copyright (C) 1989-1994, 2007 by                                         *
9186  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
9187  *                                                                           *
9188  *  Permission is hereby granted for the reproduction of this software       *
9189  *  on condition that this copyright notice is included in source            *
9190  *  distributions of the software.  The code may be modified and             *
9191  *  distributed under the same terms as Perl itself.                         *
9192  *                                                                           *
9193  *  27-Aug-1994 Modified for inclusion in perl5                              *
9194  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
9195  *****************************************************************************
9196  */
9197
9198 /*
9199  * getredirection() is intended to aid in porting C programs
9200  * to VMS (Vax-11 C).  The native VMS environment does not support
9201  * '>' and '<' I/O redirection, or command line wild card expansion,
9202  * or a command line pipe mechanism using the '|' AND background
9203  * command execution '&'.  All of these capabilities are provided to any
9204  * C program which calls this procedure as the first thing in the
9205  * main program.
9206  * The piping mechanism will probably work with almost any 'filter' type
9207  * of program.  With suitable modification, it may useful for other
9208  * portability problems as well.
9209  *
9210  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
9211  */
9212 struct list_item
9213     {
9214     struct list_item *next;
9215     char *value;
9216     };
9217
9218 static void add_item(struct list_item **head,
9219                      struct list_item **tail,
9220                      char *value,
9221                      int *count);
9222
9223 static void mp_expand_wild_cards(pTHX_ char *item,
9224                                 struct list_item **head,
9225                                 struct list_item **tail,
9226                                 int *count);
9227
9228 static int background_process(pTHX_ int argc, char **argv);
9229
9230 static void pipe_and_fork(pTHX_ char **cmargv);
9231
9232 /*{{{ void getredirection(int *ac, char ***av)*/
9233 static void
9234 mp_getredirection(pTHX_ int *ac, char ***av)
9235 /*
9236  * Process vms redirection arg's.  Exit if any error is seen.
9237  * If getredirection() processes an argument, it is erased
9238  * from the vector.  getredirection() returns a new argc and argv value.
9239  * In the event that a background command is requested (by a trailing "&"),
9240  * this routine creates a background subprocess, and simply exits the program.
9241  *
9242  * Warning: do not try to simplify the code for vms.  The code
9243  * presupposes that getredirection() is called before any data is
9244  * read from stdin or written to stdout.
9245  *
9246  * Normal usage is as follows:
9247  *
9248  *      main(argc, argv)
9249  *      int             argc;
9250  *      char            *argv[];
9251  *      {
9252  *              getredirection(&argc, &argv);
9253  *      }
9254  */
9255 {
9256     int                 argc = *ac;     /* Argument Count         */
9257     char                **argv = *av;   /* Argument Vector        */
9258     char                *ap;            /* Argument pointer       */
9259     int                 j;              /* argv[] index           */
9260     int                 item_count = 0; /* Count of Items in List */
9261     struct list_item    *list_head = 0; /* First Item in List       */
9262     struct list_item    *list_tail;     /* Last Item in List        */
9263     char                *in = NULL;     /* Input File Name          */
9264     char                *out = NULL;    /* Output File Name         */
9265     char                *outmode = "w"; /* Mode to Open Output File */
9266     char                *err = NULL;    /* Error File Name          */
9267     char                *errmode = "w"; /* Mode to Open Error File  */
9268     int                 cmargc = 0;     /* Piped Command Arg Count  */
9269     char                **cmargv = NULL;/* Piped Command Arg Vector */
9270
9271     /*
9272      * First handle the case where the last thing on the line ends with
9273      * a '&'.  This indicates the desire for the command to be run in a
9274      * subprocess, so we satisfy that desire.
9275      */
9276     ap = argv[argc-1];
9277     if (0 == strcmp("&", ap))
9278        exit(background_process(aTHX_ --argc, argv));
9279     if (*ap && '&' == ap[strlen(ap)-1])
9280         {
9281         ap[strlen(ap)-1] = '\0';
9282        exit(background_process(aTHX_ argc, argv));
9283         }
9284     /*
9285      * Now we handle the general redirection cases that involve '>', '>>',
9286      * '<', and pipes '|'.
9287      */
9288     for (j = 0; j < argc; ++j)
9289         {
9290         if (0 == strcmp("<", argv[j]))
9291             {
9292             if (j+1 >= argc)
9293                 {
9294                 fprintf(stderr,"No input file after < on command line");
9295                 exit(LIB$_WRONUMARG);
9296                 }
9297             in = argv[++j];
9298             continue;
9299             }
9300         if ('<' == *(ap = argv[j]))
9301             {
9302             in = 1 + ap;
9303             continue;
9304             }
9305         if (0 == strcmp(">", ap))
9306             {
9307             if (j+1 >= argc)
9308                 {
9309                 fprintf(stderr,"No output file after > on command line");
9310                 exit(LIB$_WRONUMARG);
9311                 }
9312             out = argv[++j];
9313             continue;
9314             }
9315         if ('>' == *ap)
9316             {
9317             if ('>' == ap[1])
9318                 {
9319                 outmode = "a";
9320                 if ('\0' == ap[2])
9321                     out = argv[++j];
9322                 else
9323                     out = 2 + ap;
9324                 }
9325             else
9326                 out = 1 + ap;
9327             if (j >= argc)
9328                 {
9329                 fprintf(stderr,"No output file after > or >> on command line");
9330                 exit(LIB$_WRONUMARG);
9331                 }
9332             continue;
9333             }
9334         if (('2' == *ap) && ('>' == ap[1]))
9335             {
9336             if ('>' == ap[2])
9337                 {
9338                 errmode = "a";
9339                 if ('\0' == ap[3])
9340                     err = argv[++j];
9341                 else
9342                     err = 3 + ap;
9343                 }
9344             else
9345                 if ('\0' == ap[2])
9346                     err = argv[++j];
9347                 else
9348                     err = 2 + ap;
9349             if (j >= argc)
9350                 {
9351                 fprintf(stderr,"No output file after 2> or 2>> on command line");
9352                 exit(LIB$_WRONUMARG);
9353                 }
9354             continue;
9355             }
9356         if (0 == strcmp("|", argv[j]))
9357             {
9358             if (j+1 >= argc)
9359                 {
9360                 fprintf(stderr,"No command into which to pipe on command line");
9361                 exit(LIB$_WRONUMARG);
9362                 }
9363             cmargc = argc-(j+1);
9364             cmargv = &argv[j+1];
9365             argc = j;
9366             continue;
9367             }
9368         if ('|' == *(ap = argv[j]))
9369             {
9370             ++argv[j];
9371             cmargc = argc-j;
9372             cmargv = &argv[j];
9373             argc = j;
9374             continue;
9375             }
9376         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9377         }
9378     /*
9379      * Allocate and fill in the new argument vector, Some Unix's terminate
9380      * the list with an extra null pointer.
9381      */
9382     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9383     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9384     *av = argv;
9385     for (j = 0; j < item_count; ++j, list_head = list_head->next)
9386         argv[j] = list_head->value;
9387     *ac = item_count;
9388     if (cmargv != NULL)
9389         {
9390         if (out != NULL)
9391             {
9392             fprintf(stderr,"'|' and '>' may not both be specified on command line");
9393             exit(LIB$_INVARGORD);
9394             }
9395         pipe_and_fork(aTHX_ cmargv);
9396         }
9397
9398     /* Check for input from a pipe (mailbox) */
9399
9400     if (in == NULL && 1 == isapipe(0))
9401         {
9402         char mbxname[L_tmpnam];
9403         long int bufsize;
9404         long int dvi_item = DVI$_DEVBUFSIZ;
9405         $DESCRIPTOR(mbxnam, "");
9406         $DESCRIPTOR(mbxdevnam, "");
9407
9408         /* Input from a pipe, reopen it in binary mode to disable       */
9409         /* carriage control processing.                                 */
9410
9411         fgetname(stdin, mbxname, 1);
9412         mbxnam.dsc$a_pointer = mbxname;
9413         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9414         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9415         mbxdevnam.dsc$a_pointer = mbxname;
9416         mbxdevnam.dsc$w_length = sizeof(mbxname);
9417         dvi_item = DVI$_DEVNAM;
9418         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9419         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9420         set_errno(0);
9421         set_vaxc_errno(1);
9422         freopen(mbxname, "rb", stdin);
9423         if (errno != 0)
9424             {
9425             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9426             exit(vaxc$errno);
9427             }
9428         }
9429     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9430         {
9431         fprintf(stderr,"Can't open input file %s as stdin",in);
9432         exit(vaxc$errno);
9433         }
9434     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9435         {
9436         fprintf(stderr,"Can't open output file %s as stdout",out);
9437         exit(vaxc$errno);
9438         }
9439         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
9440
9441     if (err != NULL) {
9442         if (strcmp(err,"&1") == 0) {
9443             dup2(fileno(stdout), fileno(stderr));
9444             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
9445         } else {
9446         FILE *tmperr;
9447         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9448             {
9449             fprintf(stderr,"Can't open error file %s as stderr",err);
9450             exit(vaxc$errno);
9451             }
9452             fclose(tmperr);
9453            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9454                 {
9455                 exit(vaxc$errno);
9456                 }
9457             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
9458         }
9459         }
9460 #ifdef ARGPROC_DEBUG
9461     PerlIO_printf(Perl_debug_log, "Arglist:\n");
9462     for (j = 0; j < *ac;  ++j)
9463         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9464 #endif
9465    /* Clear errors we may have hit expanding wildcards, so they don't
9466       show up in Perl's $! later */
9467    set_errno(0); set_vaxc_errno(1);
9468 }  /* end of getredirection() */
9469 /*}}}*/
9470
9471 static void add_item(struct list_item **head,
9472                      struct list_item **tail,
9473                      char *value,
9474                      int *count)
9475 {
9476     if (*head == 0)
9477         {
9478         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9479         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9480         *tail = *head;
9481         }
9482     else {
9483         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9484         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9485         *tail = (*tail)->next;
9486         }
9487     (*tail)->value = value;
9488     ++(*count);
9489 }
9490
9491 static void mp_expand_wild_cards(pTHX_ char *item,
9492                               struct list_item **head,
9493                               struct list_item **tail,
9494                               int *count)
9495 {
9496 int expcount = 0;
9497 unsigned long int context = 0;
9498 int isunix = 0;
9499 int item_len = 0;
9500 char *had_version;
9501 char *had_device;
9502 int had_directory;
9503 char *devdir,*cp;
9504 char *vmsspec;
9505 $DESCRIPTOR(filespec, "");
9506 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9507 $DESCRIPTOR(resultspec, "");
9508 unsigned long int lff_flags = 0;
9509 int sts;
9510 int rms_sts;
9511
9512 #ifdef VMS_LONGNAME_SUPPORT
9513     lff_flags = LIB$M_FIL_LONG_NAMES;
9514 #endif
9515
9516     for (cp = item; *cp; cp++) {
9517         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9518         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9519     }
9520     if (!*cp || isspace(*cp))
9521         {
9522         add_item(head, tail, item, count);
9523         return;
9524         }
9525     else
9526         {
9527      /* "double quoted" wild card expressions pass as is */
9528      /* From DCL that means using e.g.:                  */
9529      /* perl program """perl.*"""                        */
9530      item_len = strlen(item);
9531      if ( '"' == *item && '"' == item[item_len-1] )
9532        {
9533        item++;
9534        item[item_len-2] = '\0';
9535        add_item(head, tail, item, count);
9536        return;
9537        }
9538      }
9539     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9540     resultspec.dsc$b_class = DSC$K_CLASS_D;
9541     resultspec.dsc$a_pointer = NULL;
9542     vmsspec = PerlMem_malloc(VMS_MAXRSS);
9543     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9544     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9545       filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9546     if (!isunix || !filespec.dsc$a_pointer)
9547       filespec.dsc$a_pointer = item;
9548     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9549     /*
9550      * Only return version specs, if the caller specified a version
9551      */
9552     had_version = strchr(item, ';');
9553     /*
9554      * Only return device and directory specs, if the caller specifed either.
9555      */
9556     had_device = strchr(item, ':');
9557     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9558
9559     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9560                                  (&filespec, &resultspec, &context,
9561                                   &defaultspec, 0, &rms_sts, &lff_flags)))
9562         {
9563         char *string;
9564         char *c;
9565
9566         string = PerlMem_malloc(resultspec.dsc$w_length+1);
9567         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9568         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
9569         string[resultspec.dsc$w_length] = '\0';
9570         if (NULL == had_version)
9571             *(strrchr(string, ';')) = '\0';
9572         if ((!had_directory) && (had_device == NULL))
9573             {
9574             if (NULL == (devdir = strrchr(string, ']')))
9575                 devdir = strrchr(string, '>');
9576             strcpy(string, devdir + 1);
9577             }
9578         /*
9579          * Be consistent with what the C RTL has already done to the rest of
9580          * the argv items and lowercase all of these names.
9581          */
9582         if (!decc_efs_case_preserve) {
9583             for (c = string; *c; ++c)
9584             if (isupper(*c))
9585                 *c = tolower(*c);
9586         }
9587         if (isunix) trim_unixpath(string,item,1);
9588         add_item(head, tail, string, count);
9589         ++expcount;
9590     }
9591     PerlMem_free(vmsspec);
9592     if (sts != RMS$_NMF)
9593         {
9594         set_vaxc_errno(sts);
9595         switch (sts)
9596             {
9597             case RMS$_FNF: case RMS$_DNF:
9598                 set_errno(ENOENT); break;
9599             case RMS$_DIR:
9600                 set_errno(ENOTDIR); break;
9601             case RMS$_DEV:
9602                 set_errno(ENODEV); break;
9603             case RMS$_FNM: case RMS$_SYN:
9604                 set_errno(EINVAL); break;
9605             case RMS$_PRV:
9606                 set_errno(EACCES); break;
9607             default:
9608                 _ckvmssts_noperl(sts);
9609             }
9610         }
9611     if (expcount == 0)
9612         add_item(head, tail, item, count);
9613     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9614     _ckvmssts_noperl(lib$find_file_end(&context));
9615 }
9616
9617 static int child_st[2];/* Event Flag set when child process completes   */
9618
9619 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
9620
9621 static unsigned long int exit_handler(int *status)
9622 {
9623 short iosb[4];
9624
9625     if (0 == child_st[0])
9626         {
9627 #ifdef ARGPROC_DEBUG
9628         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
9629 #endif
9630         fflush(stdout);     /* Have to flush pipe for binary data to    */
9631                             /* terminate properly -- <tp@mccall.com>    */
9632         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
9633         sys$dassgn(child_chan);
9634         fclose(stdout);
9635         sys$synch(0, child_st);
9636         }
9637     return(1);
9638 }
9639
9640 static void sig_child(int chan)
9641 {
9642 #ifdef ARGPROC_DEBUG
9643     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
9644 #endif
9645     if (child_st[0] == 0)
9646         child_st[0] = 1;
9647 }
9648
9649 static struct exit_control_block exit_block =
9650     {
9651     0,
9652     exit_handler,
9653     1,
9654     &exit_block.exit_status,
9655     0
9656     };
9657
9658 static void
9659 pipe_and_fork(pTHX_ char **cmargv)
9660 {
9661     PerlIO *fp;
9662     struct dsc$descriptor_s *vmscmd;
9663     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9664     int sts, j, l, ismcr, quote, tquote = 0;
9665
9666     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9667     vms_execfree(vmscmd);
9668
9669     j = l = 0;
9670     p = subcmd;
9671     q = cmargv[0];
9672     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
9673               && toupper(*(q+2)) == 'R' && !*(q+3);
9674
9675     while (q && l < MAX_DCL_LINE_LENGTH) {
9676         if (!*q) {
9677             if (j > 0 && quote) {
9678                 *p++ = '"';
9679                 l++;
9680             }
9681             q = cmargv[++j];
9682             if (q) {
9683                 if (ismcr && j > 1) quote = 1;
9684                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
9685                 *p++ = ' ';
9686                 l++;
9687                 if (quote || tquote) {
9688                     *p++ = '"';
9689                     l++;
9690                 }
9691             }
9692         } else {
9693             if ((quote||tquote) && *q == '"') {
9694                 *p++ = '"';
9695                 l++;
9696             }
9697             *p++ = *q++;
9698             l++;
9699         }
9700     }
9701     *p = '\0';
9702
9703     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9704     if (fp == NULL) {
9705         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9706     }
9707 }
9708
9709 static int background_process(pTHX_ int argc, char **argv)
9710 {
9711 char command[MAX_DCL_SYMBOL + 1] = "$";
9712 $DESCRIPTOR(value, "");
9713 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9714 static $DESCRIPTOR(null, "NLA0:");
9715 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9716 char pidstring[80];
9717 $DESCRIPTOR(pidstr, "");
9718 int pid;
9719 unsigned long int flags = 17, one = 1, retsts;
9720 int len;
9721
9722     strcat(command, argv[0]);
9723     len = strlen(command);
9724     while (--argc && (len < MAX_DCL_SYMBOL))
9725         {
9726         strcat(command, " \"");
9727         strcat(command, *(++argv));
9728         strcat(command, "\"");
9729         len = strlen(command);
9730         }
9731     value.dsc$a_pointer = command;
9732     value.dsc$w_length = strlen(value.dsc$a_pointer);
9733     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9734     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9735     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9736         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9737     }
9738     else {
9739         _ckvmssts_noperl(retsts);
9740     }
9741 #ifdef ARGPROC_DEBUG
9742     PerlIO_printf(Perl_debug_log, "%s\n", command);
9743 #endif
9744     sprintf(pidstring, "%08X", pid);
9745     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9746     pidstr.dsc$a_pointer = pidstring;
9747     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9748     lib$set_symbol(&pidsymbol, &pidstr);
9749     return(SS$_NORMAL);
9750 }
9751 /*}}}*/
9752 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9753
9754
9755 /* OS-specific initialization at image activation (not thread startup) */
9756 /* Older VAXC header files lack these constants */
9757 #ifndef JPI$_RIGHTS_SIZE
9758 #  define JPI$_RIGHTS_SIZE 817
9759 #endif
9760 #ifndef KGB$M_SUBSYSTEM
9761 #  define KGB$M_SUBSYSTEM 0x8
9762 #endif
9763
9764 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9765
9766 /*{{{void vms_image_init(int *, char ***)*/
9767 void
9768 vms_image_init(int *argcp, char ***argvp)
9769 {
9770   int status;
9771   char eqv[LNM$C_NAMLENGTH+1] = "";
9772   unsigned int len, tabct = 8, tabidx = 0;
9773   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9774   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9775   unsigned short int dummy, rlen;
9776   struct dsc$descriptor_s **tabvec;
9777 #if defined(PERL_IMPLICIT_CONTEXT)
9778   pTHX = NULL;
9779 #endif
9780   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
9781                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
9782                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9783                                  {          0,                0,    0,      0} };
9784
9785 #ifdef KILL_BY_SIGPRC
9786     Perl_csighandler_init();
9787 #endif
9788
9789     /* This was moved from the pre-image init handler because on threaded */
9790     /* Perl it was always returning 0 for the default value. */
9791     status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9792     if (status > 0) {
9793         int s;
9794         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9795         if (s > 0) {
9796             int initial;
9797             initial = decc$feature_get_value(s, 4);
9798             if (initial > 0) {
9799                 /* initial is: 0 if nothing has set the feature */
9800                 /*            -1 if initialized to default */
9801                 /*             1 if set by logical name */
9802                 /*             2 if set by decc$feature_set_value */
9803                 decc_disable_posix_root = decc$feature_get_value(s, 1);
9804
9805                 /* If the value is not valid, force the feature off */
9806                 if (decc_disable_posix_root < 0) {
9807                     decc$feature_set_value(s, 1, 1);
9808                     decc_disable_posix_root = 1;
9809                 }
9810             }
9811             else {
9812                 /* Nothing has asked for it explicitly, so use our own default. */
9813                 decc_disable_posix_root = 1;
9814                 decc$feature_set_value(s, 1, 1);
9815             }
9816         }
9817     }
9818
9819
9820   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9821   _ckvmssts_noperl(iosb[0]);
9822   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9823     if (iprv[i]) {           /* Running image installed with privs? */
9824       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
9825       will_taint = TRUE;
9826       break;
9827     }
9828   }
9829   /* Rights identifiers might trigger tainting as well. */
9830   if (!will_taint && (rlen || rsz)) {
9831     while (rlen < rsz) {
9832       /* We didn't get all the identifiers on the first pass.  Allocate a
9833        * buffer much larger than $GETJPI wants (rsz is size in bytes that
9834        * were needed to hold all identifiers at time of last call; we'll
9835        * allocate that many unsigned long ints), and go back and get 'em.
9836        * If it gave us less than it wanted to despite ample buffer space,
9837        * something's broken.  Is your system missing a system identifier?
9838        */
9839       if (rsz <= jpilist[1].buflen) {
9840          /* Perl_croak accvios when used this early in startup. */
9841          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9842                          rsz, (unsigned long) jpilist[1].buflen,
9843                          "Check your rights database for corruption.\n");
9844          exit(SS$_ABORT);
9845       }
9846       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9847       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9848       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9849       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9850       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9851       _ckvmssts_noperl(iosb[0]);
9852     }
9853     mask = jpilist[1].bufadr;
9854     /* Check attribute flags for each identifier (2nd longword); protected
9855      * subsystem identifiers trigger tainting.
9856      */
9857     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9858       if (mask[i] & KGB$M_SUBSYSTEM) {
9859         will_taint = TRUE;
9860         break;
9861       }
9862     }
9863     if (mask != rlst) PerlMem_free(mask);
9864   }
9865
9866   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9867    * logical, some versions of the CRTL will add a phanthom /000000/
9868    * directory.  This needs to be removed.
9869    */
9870   if (decc_filename_unix_report) {
9871   char * zeros;
9872   int ulen;
9873     ulen = strlen(argvp[0][0]);
9874     if (ulen > 7) {
9875       zeros = strstr(argvp[0][0], "/000000/");
9876       if (zeros != NULL) {
9877         int mlen;
9878         mlen = ulen - (zeros - argvp[0][0]) - 7;
9879         memmove(zeros, &zeros[7], mlen);
9880         ulen = ulen - 7;
9881         argvp[0][0][ulen] = '\0';
9882       }
9883     }
9884     /* It also may have a trailing dot that needs to be removed otherwise
9885      * it will be converted to VMS mode incorrectly.
9886      */
9887     ulen--;
9888     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9889       argvp[0][0][ulen] = '\0';
9890   }
9891
9892   /* We need to use this hack to tell Perl it should run with tainting,
9893    * since its tainting flag may be part of the PL_curinterp struct, which
9894    * hasn't been allocated when vms_image_init() is called.
9895    */
9896   if (will_taint) {
9897     char **newargv, **oldargv;
9898     oldargv = *argvp;
9899     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9900     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9901     newargv[0] = oldargv[0];
9902     newargv[1] = PerlMem_malloc(3 * sizeof(char));
9903     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9904     strcpy(newargv[1], "-T");
9905     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9906     (*argcp)++;
9907     newargv[*argcp] = NULL;
9908     /* We orphan the old argv, since we don't know where it's come from,
9909      * so we don't know how to free it.
9910      */
9911     *argvp = newargv;
9912   }
9913   else {  /* Did user explicitly request tainting? */
9914     int i;
9915     char *cp, **av = *argvp;
9916     for (i = 1; i < *argcp; i++) {
9917       if (*av[i] != '-') break;
9918       for (cp = av[i]+1; *cp; cp++) {
9919         if (*cp == 'T') { will_taint = 1; break; }
9920         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9921                   strchr("DFIiMmx",*cp)) break;
9922       }
9923       if (will_taint) break;
9924     }
9925   }
9926
9927   for (tabidx = 0;
9928        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9929        tabidx++) {
9930     if (!tabidx) {
9931       tabvec = (struct dsc$descriptor_s **)
9932             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9933       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9934     }
9935     else if (tabidx >= tabct) {
9936       tabct += 8;
9937       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9938       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9939     }
9940     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9941     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9942     tabvec[tabidx]->dsc$w_length  = 0;
9943     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9944     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
9945     tabvec[tabidx]->dsc$a_pointer = NULL;
9946     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9947   }
9948   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9949
9950   getredirection(argcp,argvp);
9951 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9952   {
9953 # include <reentrancy.h>
9954   decc$set_reentrancy(C$C_MULTITHREAD);
9955   }
9956 #endif
9957   return;
9958 }
9959 /*}}}*/
9960
9961
9962 /* trim_unixpath()
9963  * Trim Unix-style prefix off filespec, so it looks like what a shell
9964  * glob expansion would return (i.e. from specified prefix on, not
9965  * full path).  Note that returned filespec is Unix-style, regardless
9966  * of whether input filespec was VMS-style or Unix-style.
9967  *
9968  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9969  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9970  * vector of options; at present, only bit 0 is used, and if set tells
9971  * trim unixpath to try the current default directory as a prefix when
9972  * presented with a possibly ambiguous ... wildcard.
9973  *
9974  * Returns !=0 on success, with trimmed filespec replacing contents of
9975  * fspec, and 0 on failure, with contents of fpsec unchanged.
9976  */
9977 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9978 int
9979 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9980 {
9981   char *unixified, *unixwild,
9982        *template, *base, *end, *cp1, *cp2;
9983   register int tmplen, reslen = 0, dirs = 0;
9984
9985   if (!wildspec || !fspec) return 0;
9986
9987   unixwild = PerlMem_malloc(VMS_MAXRSS);
9988   if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9989   template = unixwild;
9990   if (strpbrk(wildspec,"]>:") != NULL) {
9991     if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
9992         PerlMem_free(unixwild);
9993         return 0;
9994     }
9995   }
9996   else {
9997     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
9998     unixwild[VMS_MAXRSS-1] = 0;
9999   }
10000   unixified = PerlMem_malloc(VMS_MAXRSS);
10001   if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10002   if (strpbrk(fspec,"]>:") != NULL) {
10003     if (int_tounixspec(fspec, unixified, NULL) == NULL) {
10004         PerlMem_free(unixwild);
10005         PerlMem_free(unixified);
10006         return 0;
10007     }
10008     else base = unixified;
10009     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
10010      * check to see that final result fits into (isn't longer than) fspec */
10011     reslen = strlen(fspec);
10012   }
10013   else base = fspec;
10014
10015   /* No prefix or absolute path on wildcard, so nothing to remove */
10016   if (!*template || *template == '/') {
10017     PerlMem_free(unixwild);
10018     if (base == fspec) {
10019         PerlMem_free(unixified);
10020         return 1;
10021     }
10022     tmplen = strlen(unixified);
10023     if (tmplen > reslen) {
10024         PerlMem_free(unixified);
10025         return 0;  /* not enough space */
10026     }
10027     /* Copy unixified resultant, including trailing NUL */
10028     memmove(fspec,unixified,tmplen+1);
10029     PerlMem_free(unixified);
10030     return 1;
10031   }
10032
10033   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
10034   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
10035     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
10036     for (cp1 = end ;cp1 >= base; cp1--)
10037       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
10038         { cp1++; break; }
10039     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
10040     PerlMem_free(unixified);
10041     PerlMem_free(unixwild);
10042     return 1;
10043   }
10044   else {
10045     char *tpl, *lcres;
10046     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
10047     int ells = 1, totells, segdirs, match;
10048     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
10049                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10050
10051     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
10052     totells = ells;
10053     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
10054     tpl = PerlMem_malloc(VMS_MAXRSS);
10055     if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10056     if (ellipsis == template && opts & 1) {
10057       /* Template begins with an ellipsis.  Since we can't tell how many
10058        * directory names at the front of the resultant to keep for an
10059        * arbitrary starting point, we arbitrarily choose the current
10060        * default directory as a starting point.  If it's there as a prefix,
10061        * clip it off.  If not, fall through and act as if the leading
10062        * ellipsis weren't there (i.e. return shortest possible path that
10063        * could match template).
10064        */
10065       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
10066           PerlMem_free(tpl);
10067           PerlMem_free(unixified);
10068           PerlMem_free(unixwild);
10069           return 0;
10070       }
10071       if (!decc_efs_case_preserve) {
10072         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
10073           if (_tolower(*cp1) != _tolower(*cp2)) break;
10074       }
10075       segdirs = dirs - totells;  /* Min # of dirs we must have left */
10076       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
10077       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
10078         memmove(fspec,cp2+1,end - cp2);
10079         PerlMem_free(tpl);
10080         PerlMem_free(unixified);
10081         PerlMem_free(unixwild);
10082         return 1;
10083       }
10084     }
10085     /* First off, back up over constant elements at end of path */
10086     if (dirs) {
10087       for (front = end ; front >= base; front--)
10088          if (*front == '/' && !dirs--) { front++; break; }
10089     }
10090     lcres = PerlMem_malloc(VMS_MAXRSS);
10091     if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10092     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
10093          cp1++,cp2++) {
10094             if (!decc_efs_case_preserve) {
10095                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
10096             }
10097             else {
10098                 *cp2 = *cp1;
10099             }
10100     }
10101     if (cp1 != '\0') {
10102         PerlMem_free(tpl);
10103         PerlMem_free(unixified);
10104         PerlMem_free(unixwild);
10105         PerlMem_free(lcres);
10106         return 0;  /* Path too long. */
10107     }
10108     lcend = cp2;
10109     *cp2 = '\0';  /* Pick up with memcpy later */
10110     lcfront = lcres + (front - base);
10111     /* Now skip over each ellipsis and try to match the path in front of it. */
10112     while (ells--) {
10113       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
10114         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
10115             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
10116       if (cp1 < template) break; /* template started with an ellipsis */
10117       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
10118         ellipsis = cp1; continue;
10119       }
10120       wilddsc.dsc$a_pointer = tpl;
10121       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
10122       nextell = cp1;
10123       for (segdirs = 0, cp2 = tpl;
10124            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
10125            cp1++, cp2++) {
10126          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
10127          else {
10128             if (!decc_efs_case_preserve) {
10129               *cp2 = _tolower(*cp1);  /* else lowercase for match */
10130             }
10131             else {
10132               *cp2 = *cp1;  /* else preserve case for match */
10133             }
10134          }
10135          if (*cp2 == '/') segdirs++;
10136       }
10137       if (cp1 != ellipsis - 1) {
10138           PerlMem_free(tpl);
10139           PerlMem_free(unixified);
10140           PerlMem_free(unixwild);
10141           PerlMem_free(lcres);
10142           return 0; /* Path too long */
10143       }
10144       /* Back up at least as many dirs as in template before matching */
10145       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
10146         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
10147       for (match = 0; cp1 > lcres;) {
10148         resdsc.dsc$a_pointer = cp1;
10149         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
10150           match++;
10151           if (match == 1) lcfront = cp1;
10152         }
10153         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
10154       }
10155       if (!match) {
10156         PerlMem_free(tpl);
10157         PerlMem_free(unixified);
10158         PerlMem_free(unixwild);
10159         PerlMem_free(lcres);
10160         return 0;  /* Can't find prefix ??? */
10161       }
10162       if (match > 1 && opts & 1) {
10163         /* This ... wildcard could cover more than one set of dirs (i.e.
10164          * a set of similar dir names is repeated).  If the template
10165          * contains more than 1 ..., upstream elements could resolve the
10166          * ambiguity, but it's not worth a full backtracking setup here.
10167          * As a quick heuristic, clip off the current default directory
10168          * if it's present to find the trimmed spec, else use the
10169          * shortest string that this ... could cover.
10170          */
10171         char def[NAM$C_MAXRSS+1], *st;
10172
10173         if (getcwd(def, sizeof def,0) == NULL) {
10174             PerlMem_free(unixified);
10175             PerlMem_free(unixwild);
10176             PerlMem_free(lcres);
10177             PerlMem_free(tpl);
10178             return 0;
10179         }
10180         if (!decc_efs_case_preserve) {
10181           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
10182             if (_tolower(*cp1) != _tolower(*cp2)) break;
10183         }
10184         segdirs = dirs - totells;  /* Min # of dirs we must have left */
10185         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
10186         if (*cp1 == '\0' && *cp2 == '/') {
10187           memmove(fspec,cp2+1,end - cp2);
10188           PerlMem_free(tpl);
10189           PerlMem_free(unixified);
10190           PerlMem_free(unixwild);
10191           PerlMem_free(lcres);
10192           return 1;
10193         }
10194         /* Nope -- stick with lcfront from above and keep going. */
10195       }
10196     }
10197     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
10198     PerlMem_free(tpl);
10199     PerlMem_free(unixified);
10200     PerlMem_free(unixwild);
10201     PerlMem_free(lcres);
10202     return 1;
10203     ellipsis = nextell;
10204   }
10205
10206 }  /* end of trim_unixpath() */
10207 /*}}}*/
10208
10209
10210 /*
10211  *  VMS readdir() routines.
10212  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
10213  *
10214  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
10215  *  Minor modifications to original routines.
10216  */
10217
10218 /* readdir may have been redefined by reentr.h, so make sure we get
10219  * the local version for what we do here.
10220  */
10221 #ifdef readdir
10222 # undef readdir
10223 #endif
10224 #if !defined(PERL_IMPLICIT_CONTEXT)
10225 # define readdir Perl_readdir
10226 #else
10227 # define readdir(a) Perl_readdir(aTHX_ a)
10228 #endif
10229
10230     /* Number of elements in vms_versions array */
10231 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
10232
10233 /*
10234  *  Open a directory, return a handle for later use.
10235  */
10236 /*{{{ DIR *opendir(char*name) */
10237 DIR *
10238 Perl_opendir(pTHX_ const char *name)
10239 {
10240     DIR *dd;
10241     char *dir;
10242     Stat_t sb;
10243
10244     Newx(dir, VMS_MAXRSS, char);
10245     if (int_tovmspath(name, dir, NULL) == NULL) {
10246       Safefree(dir);
10247       return NULL;
10248     }
10249     /* Check access before stat; otherwise stat does not
10250      * accurately report whether it's a directory.
10251      */
10252     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
10253       /* cando_by_name has already set errno */
10254       Safefree(dir);
10255       return NULL;
10256     }
10257     if (flex_stat(dir,&sb) == -1) return NULL;
10258     if (!S_ISDIR(sb.st_mode)) {
10259       Safefree(dir);
10260       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
10261       return NULL;
10262     }
10263     /* Get memory for the handle, and the pattern. */
10264     Newx(dd,1,DIR);
10265     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
10266
10267     /* Fill in the fields; mainly playing with the descriptor. */
10268     sprintf(dd->pattern, "%s*.*",dir);
10269     Safefree(dir);
10270     dd->context = 0;
10271     dd->count = 0;
10272     dd->flags = 0;
10273     /* By saying we always want the result of readdir() in unix format, we
10274      * are really saying we want all the escapes removed.  Otherwise the caller,
10275      * having no way to know whether it's already in VMS format, might send it
10276      * through tovmsspec again, thus double escaping.
10277      */
10278     dd->flags = PERL_VMSDIR_M_UNIXSPECS;
10279     dd->pat.dsc$a_pointer = dd->pattern;
10280     dd->pat.dsc$w_length = strlen(dd->pattern);
10281     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
10282     dd->pat.dsc$b_class = DSC$K_CLASS_S;
10283 #if defined(USE_ITHREADS)
10284     Newx(dd->mutex,1,perl_mutex);
10285     MUTEX_INIT( (perl_mutex *) dd->mutex );
10286 #else
10287     dd->mutex = NULL;
10288 #endif
10289
10290     return dd;
10291 }  /* end of opendir() */
10292 /*}}}*/
10293
10294 /*
10295  *  Set the flag to indicate we want versions or not.
10296  */
10297 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10298 void
10299 vmsreaddirversions(DIR *dd, int flag)
10300 {
10301     if (flag)
10302         dd->flags |= PERL_VMSDIR_M_VERSIONS;
10303     else
10304         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10305 }
10306 /*}}}*/
10307
10308 /*
10309  *  Free up an opened directory.
10310  */
10311 /*{{{ void closedir(DIR *dd)*/
10312 void
10313 Perl_closedir(DIR *dd)
10314 {
10315     int sts;
10316
10317     sts = lib$find_file_end(&dd->context);
10318     Safefree(dd->pattern);
10319 #if defined(USE_ITHREADS)
10320     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10321     Safefree(dd->mutex);
10322 #endif
10323     Safefree(dd);
10324 }
10325 /*}}}*/
10326
10327 /*
10328  *  Collect all the version numbers for the current file.
10329  */
10330 static void
10331 collectversions(pTHX_ DIR *dd)
10332 {
10333     struct dsc$descriptor_s     pat;
10334     struct dsc$descriptor_s     res;
10335     struct dirent *e;
10336     char *p, *text, *buff;
10337     int i;
10338     unsigned long context, tmpsts;
10339
10340     /* Convenient shorthand. */
10341     e = &dd->entry;
10342
10343     /* Add the version wildcard, ignoring the "*.*" put on before */
10344     i = strlen(dd->pattern);
10345     Newx(text,i + e->d_namlen + 3,char);
10346     strcpy(text, dd->pattern);
10347     sprintf(&text[i - 3], "%s;*", e->d_name);
10348
10349     /* Set up the pattern descriptor. */
10350     pat.dsc$a_pointer = text;
10351     pat.dsc$w_length = i + e->d_namlen - 1;
10352     pat.dsc$b_dtype = DSC$K_DTYPE_T;
10353     pat.dsc$b_class = DSC$K_CLASS_S;
10354
10355     /* Set up result descriptor. */
10356     Newx(buff, VMS_MAXRSS, char);
10357     res.dsc$a_pointer = buff;
10358     res.dsc$w_length = VMS_MAXRSS - 1;
10359     res.dsc$b_dtype = DSC$K_DTYPE_T;
10360     res.dsc$b_class = DSC$K_CLASS_S;
10361
10362     /* Read files, collecting versions. */
10363     for (context = 0, e->vms_verscount = 0;
10364          e->vms_verscount < VERSIZE(e);
10365          e->vms_verscount++) {
10366         unsigned long rsts;
10367         unsigned long flags = 0;
10368
10369 #ifdef VMS_LONGNAME_SUPPORT
10370         flags = LIB$M_FIL_LONG_NAMES;
10371 #endif
10372         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10373         if (tmpsts == RMS$_NMF || context == 0) break;
10374         _ckvmssts(tmpsts);
10375         buff[VMS_MAXRSS - 1] = '\0';
10376         if ((p = strchr(buff, ';')))
10377             e->vms_versions[e->vms_verscount] = atoi(p + 1);
10378         else
10379             e->vms_versions[e->vms_verscount] = -1;
10380     }
10381
10382     _ckvmssts(lib$find_file_end(&context));
10383     Safefree(text);
10384     Safefree(buff);
10385
10386 }  /* end of collectversions() */
10387
10388 /*
10389  *  Read the next entry from the directory.
10390  */
10391 /*{{{ struct dirent *readdir(DIR *dd)*/
10392 struct dirent *
10393 Perl_readdir(pTHX_ DIR *dd)
10394 {
10395     struct dsc$descriptor_s     res;
10396     char *p, *buff;
10397     unsigned long int tmpsts;
10398     unsigned long rsts;
10399     unsigned long flags = 0;
10400     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10401     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10402
10403     /* Set up result descriptor, and get next file. */
10404     Newx(buff, VMS_MAXRSS, char);
10405     res.dsc$a_pointer = buff;
10406     res.dsc$w_length = VMS_MAXRSS - 1;
10407     res.dsc$b_dtype = DSC$K_DTYPE_T;
10408     res.dsc$b_class = DSC$K_CLASS_S;
10409
10410 #ifdef VMS_LONGNAME_SUPPORT
10411     flags = LIB$M_FIL_LONG_NAMES;
10412 #endif
10413
10414     tmpsts = lib$find_file
10415         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10416     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
10417     if (!(tmpsts & 1)) {
10418       set_vaxc_errno(tmpsts);
10419       switch (tmpsts) {
10420         case RMS$_PRV:
10421           set_errno(EACCES); break;
10422         case RMS$_DEV:
10423           set_errno(ENODEV); break;
10424         case RMS$_DIR:
10425           set_errno(ENOTDIR); break;
10426         case RMS$_FNF: case RMS$_DNF:
10427           set_errno(ENOENT); break;
10428         default:
10429           set_errno(EVMSERR);
10430       }
10431       Safefree(buff);
10432       return NULL;
10433     }
10434     dd->count++;
10435     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10436     buff[res.dsc$w_length] = '\0';
10437     p = buff + res.dsc$w_length;
10438     while (--p >= buff) if (!isspace(*p)) break;
10439     *p = '\0';
10440     if (!decc_efs_case_preserve) {
10441       for (p = buff; *p; p++) *p = _tolower(*p);
10442     }
10443
10444     /* Skip any directory component and just copy the name. */
10445     sts = vms_split_path
10446        (buff,
10447         &v_spec,
10448         &v_len,
10449         &r_spec,
10450         &r_len,
10451         &d_spec,
10452         &d_len,
10453         &n_spec,
10454         &n_len,
10455         &e_spec,
10456         &e_len,
10457         &vs_spec,
10458         &vs_len);
10459
10460     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10461
10462         /* In Unix report mode, remove the ".dir;1" from the name */
10463         /* if it is a real directory. */
10464         if (decc_filename_unix_report || decc_efs_charset) {
10465             if ((e_len == 4) && (vs_len == 2) && (vs_spec[1] == '1')) {
10466                 if ((toupper(e_spec[1]) == 'D') &&
10467                     (toupper(e_spec[2]) == 'I') &&
10468                     (toupper(e_spec[3]) == 'R')) {
10469                     Stat_t statbuf;
10470                     int ret_sts;
10471
10472                     ret_sts = stat(buff, &statbuf.crtl_stat);
10473                     if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10474                         e_len = 0;
10475                         e_spec[0] = 0;
10476                     }
10477                 }
10478             }
10479         }
10480
10481         /* Drop NULL extensions on UNIX file specification */
10482         if ((e_len == 1) && decc_readdir_dropdotnotype) {
10483             e_len = 0;
10484             e_spec[0] = '\0';
10485         }
10486     }
10487
10488     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
10489     dd->entry.d_name[n_len + e_len] = '\0';
10490     dd->entry.d_namlen = strlen(dd->entry.d_name);
10491
10492     /* Convert the filename to UNIX format if needed */
10493     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10494
10495         /* Translate the encoded characters. */
10496         /* Fixme: Unicode handling could result in embedded 0 characters */
10497         if (strchr(dd->entry.d_name, '^') != NULL) {
10498             char new_name[256];
10499             char * q;
10500             p = dd->entry.d_name;
10501             q = new_name;
10502             while (*p != 0) {
10503                 int inchars_read, outchars_added;
10504                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10505                 p += inchars_read;
10506                 q += outchars_added;
10507                 /* fix-me */
10508                 /* if outchars_added > 1, then this is a wide file specification */
10509                 /* Wide file specifications need to be passed in Perl */
10510                 /* counted strings apparently with a Unicode flag */
10511             }
10512             *q = 0;
10513             strcpy(dd->entry.d_name, new_name);
10514             dd->entry.d_namlen = strlen(dd->entry.d_name);
10515         }
10516     }
10517
10518     dd->entry.vms_verscount = 0;
10519     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10520     Safefree(buff);
10521     return &dd->entry;
10522
10523 }  /* end of readdir() */
10524 /*}}}*/
10525
10526 /*
10527  *  Read the next entry from the directory -- thread-safe version.
10528  */
10529 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10530 int
10531 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10532 {
10533     int retval;
10534
10535     MUTEX_LOCK( (perl_mutex *) dd->mutex );
10536
10537     entry = readdir(dd);
10538     *result = entry;
10539     retval = ( *result == NULL ? errno : 0 );
10540
10541     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10542
10543     return retval;
10544
10545 }  /* end of readdir_r() */
10546 /*}}}*/
10547
10548 /*
10549  *  Return something that can be used in a seekdir later.
10550  */
10551 /*{{{ long telldir(DIR *dd)*/
10552 long
10553 Perl_telldir(DIR *dd)
10554 {
10555     return dd->count;
10556 }
10557 /*}}}*/
10558
10559 /*
10560  *  Return to a spot where we used to be.  Brute force.
10561  */
10562 /*{{{ void seekdir(DIR *dd,long count)*/
10563 void
10564 Perl_seekdir(pTHX_ DIR *dd, long count)
10565 {
10566     int old_flags;
10567
10568     /* If we haven't done anything yet... */
10569     if (dd->count == 0)
10570         return;
10571
10572     /* Remember some state, and clear it. */
10573     old_flags = dd->flags;
10574     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10575     _ckvmssts(lib$find_file_end(&dd->context));
10576     dd->context = 0;
10577
10578     /* The increment is in readdir(). */
10579     for (dd->count = 0; dd->count < count; )
10580         readdir(dd);
10581
10582     dd->flags = old_flags;
10583
10584 }  /* end of seekdir() */
10585 /*}}}*/
10586
10587 /* VMS subprocess management
10588  *
10589  * my_vfork() - just a vfork(), after setting a flag to record that
10590  * the current script is trying a Unix-style fork/exec.
10591  *
10592  * vms_do_aexec() and vms_do_exec() are called in response to the
10593  * perl 'exec' function.  If this follows a vfork call, then they
10594  * call out the regular perl routines in doio.c which do an
10595  * execvp (for those who really want to try this under VMS).
10596  * Otherwise, they do exactly what the perl docs say exec should
10597  * do - terminate the current script and invoke a new command
10598  * (See below for notes on command syntax.)
10599  *
10600  * do_aspawn() and do_spawn() implement the VMS side of the perl
10601  * 'system' function.
10602  *
10603  * Note on command arguments to perl 'exec' and 'system': When handled
10604  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10605  * are concatenated to form a DCL command string.  If the first non-numeric
10606  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10607  * the command string is handed off to DCL directly.  Otherwise,
10608  * the first token of the command is taken as the filespec of an image
10609  * to run.  The filespec is expanded using a default type of '.EXE' and
10610  * the process defaults for device, directory, etc., and if found, the resultant
10611  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10612  * the command string as parameters.  This is perhaps a bit complicated,
10613  * but I hope it will form a happy medium between what VMS folks expect
10614  * from lib$spawn and what Unix folks expect from exec.
10615  */
10616
10617 static int vfork_called;
10618
10619 /*{{{int my_vfork()*/
10620 int
10621 my_vfork()
10622 {
10623   vfork_called++;
10624   return vfork();
10625 }
10626 /*}}}*/
10627
10628
10629 static void
10630 vms_execfree(struct dsc$descriptor_s *vmscmd)
10631 {
10632   if (vmscmd) {
10633       if (vmscmd->dsc$a_pointer) {
10634           PerlMem_free(vmscmd->dsc$a_pointer);
10635       }
10636       PerlMem_free(vmscmd);
10637   }
10638 }
10639
10640 static char *
10641 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10642 {
10643   char *junk, *tmps = NULL;
10644   register size_t cmdlen = 0;
10645   size_t rlen;
10646   register SV **idx;
10647   STRLEN n_a;
10648
10649   idx = mark;
10650   if (really) {
10651     tmps = SvPV(really,rlen);
10652     if (*tmps) {
10653       cmdlen += rlen + 1;
10654       idx++;
10655     }
10656   }
10657
10658   for (idx++; idx <= sp; idx++) {
10659     if (*idx) {
10660       junk = SvPVx(*idx,rlen);
10661       cmdlen += rlen ? rlen + 1 : 0;
10662     }
10663   }
10664   Newx(PL_Cmd, cmdlen+1, char);
10665
10666   if (tmps && *tmps) {
10667     strcpy(PL_Cmd,tmps);
10668     mark++;
10669   }
10670   else *PL_Cmd = '\0';
10671   while (++mark <= sp) {
10672     if (*mark) {
10673       char *s = SvPVx(*mark,n_a);
10674       if (!*s) continue;
10675       if (*PL_Cmd) strcat(PL_Cmd," ");
10676       strcat(PL_Cmd,s);
10677     }
10678   }
10679   return PL_Cmd;
10680
10681 }  /* end of setup_argstr() */
10682
10683
10684 static unsigned long int
10685 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10686                    struct dsc$descriptor_s **pvmscmd)
10687 {
10688   char * vmsspec;
10689   char * resspec;
10690   char image_name[NAM$C_MAXRSS+1];
10691   char image_argv[NAM$C_MAXRSS+1];
10692   $DESCRIPTOR(defdsc,".EXE");
10693   $DESCRIPTOR(defdsc2,".");
10694   struct dsc$descriptor_s resdsc;
10695   struct dsc$descriptor_s *vmscmd;
10696   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10697   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10698   register char *s, *rest, *cp, *wordbreak;
10699   char * cmd;
10700   int cmdlen;
10701   register int isdcl;
10702
10703   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10704   if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10705
10706   /* vmsspec is a DCL command buffer, not just a filename */
10707   vmsspec = PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10708   if (vmsspec == NULL)
10709       _ckvmssts_noperl(SS$_INSFMEM);
10710
10711   resspec = PerlMem_malloc(VMS_MAXRSS);
10712   if (resspec == NULL)
10713       _ckvmssts_noperl(SS$_INSFMEM);
10714
10715   /* Make a copy for modification */
10716   cmdlen = strlen(incmd);
10717   cmd = PerlMem_malloc(cmdlen+1);
10718   if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10719   strncpy(cmd, incmd, cmdlen);
10720   cmd[cmdlen] = 0;
10721   image_name[0] = 0;
10722   image_argv[0] = 0;
10723
10724   resdsc.dsc$a_pointer = resspec;
10725   resdsc.dsc$b_dtype  = DSC$K_DTYPE_T;
10726   resdsc.dsc$b_class  = DSC$K_CLASS_S;
10727   resdsc.dsc$w_length = VMS_MAXRSS - 1;
10728
10729   vmscmd->dsc$a_pointer = NULL;
10730   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
10731   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
10732   vmscmd->dsc$w_length = 0;
10733   if (pvmscmd) *pvmscmd = vmscmd;
10734
10735   if (suggest_quote) *suggest_quote = 0;
10736
10737   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10738     PerlMem_free(cmd);
10739     PerlMem_free(vmsspec);
10740     PerlMem_free(resspec);
10741     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
10742   }
10743
10744   s = cmd;
10745
10746   while (*s && isspace(*s)) s++;
10747
10748   if (*s == '@' || *s == '$') {
10749     vmsspec[0] = *s;  rest = s + 1;
10750     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10751   }
10752   else { cp = vmsspec; rest = s; }
10753   if (*rest == '.' || *rest == '/') {
10754     char *cp2;
10755     for (cp2 = resspec;
10756          *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10757          rest++, cp2++) *cp2 = *rest;
10758     *cp2 = '\0';
10759     if (int_tovmsspec(resspec, cp, 0, NULL)) {
10760       s = vmsspec;
10761
10762       /* When a UNIX spec with no file type is translated to VMS, */
10763       /* A trailing '.' is appended under ODS-5 rules.            */
10764       /* Here we do not want that trailing "." as it prevents     */
10765       /* Looking for a implied ".exe" type. */
10766       if (decc_efs_charset) {
10767           int i;
10768           i = strlen(vmsspec);
10769           if (vmsspec[i-1] == '.') {
10770               vmsspec[i-1] = '\0';
10771           }
10772       }
10773
10774       if (*rest) {
10775         for (cp2 = vmsspec + strlen(vmsspec);
10776              *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10777              rest++, cp2++) *cp2 = *rest;
10778         *cp2 = '\0';
10779       }
10780     }
10781   }
10782   /* Intuit whether verb (first word of cmd) is a DCL command:
10783    *   - if first nonspace char is '@', it's a DCL indirection
10784    * otherwise
10785    *   - if verb contains a filespec separator, it's not a DCL command
10786    *   - if it doesn't, caller tells us whether to default to a DCL
10787    *     command, or to a local image unless told it's DCL (by leading '$')
10788    */
10789   if (*s == '@') {
10790       isdcl = 1;
10791       if (suggest_quote) *suggest_quote = 1;
10792   } else {
10793     register char *filespec = strpbrk(s,":<[.;");
10794     rest = wordbreak = strpbrk(s," \"\t/");
10795     if (!wordbreak) wordbreak = s + strlen(s);
10796     if (*s == '$') check_img = 0;
10797     if (filespec && (filespec < wordbreak)) isdcl = 0;
10798     else isdcl = !check_img;
10799   }
10800
10801   if (!isdcl) {
10802     int rsts;
10803     imgdsc.dsc$a_pointer = s;
10804     imgdsc.dsc$w_length = wordbreak - s;
10805     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10806     if (!(retsts&1)) {
10807         _ckvmssts_noperl(lib$find_file_end(&cxt));
10808         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10809       if (!(retsts & 1) && *s == '$') {
10810         _ckvmssts_noperl(lib$find_file_end(&cxt));
10811         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10812         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10813         if (!(retsts&1)) {
10814           _ckvmssts_noperl(lib$find_file_end(&cxt));
10815           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10816         }
10817       }
10818     }
10819     _ckvmssts_noperl(lib$find_file_end(&cxt));
10820
10821     if (retsts & 1) {
10822       FILE *fp;
10823       s = resspec;
10824       while (*s && !isspace(*s)) s++;
10825       *s = '\0';
10826
10827       /* check that it's really not DCL with no file extension */
10828       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10829       if (fp) {
10830         char b[256] = {0,0,0,0};
10831         read(fileno(fp), b, 256);
10832         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10833         if (isdcl) {
10834           int shebang_len;
10835
10836           /* Check for script */
10837           shebang_len = 0;
10838           if ((b[0] == '#') && (b[1] == '!'))
10839              shebang_len = 2;
10840 #ifdef ALTERNATE_SHEBANG
10841           else {
10842             shebang_len = strlen(ALTERNATE_SHEBANG);
10843             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10844               char * perlstr;
10845                 perlstr = strstr("perl",b);
10846                 if (perlstr == NULL)
10847                   shebang_len = 0;
10848             }
10849             else
10850               shebang_len = 0;
10851           }
10852 #endif
10853
10854           if (shebang_len > 0) {
10855           int i;
10856           int j;
10857           char tmpspec[NAM$C_MAXRSS + 1];
10858
10859             i = shebang_len;
10860              /* Image is following after white space */
10861             /*--------------------------------------*/
10862             while (isprint(b[i]) && isspace(b[i]))
10863                 i++;
10864
10865             j = 0;
10866             while (isprint(b[i]) && !isspace(b[i])) {
10867                 tmpspec[j++] = b[i++];
10868                 if (j >= NAM$C_MAXRSS)
10869                    break;
10870             }
10871             tmpspec[j] = '\0';
10872
10873              /* There may be some default parameters to the image */
10874             /*---------------------------------------------------*/
10875             j = 0;
10876             while (isprint(b[i])) {
10877                 image_argv[j++] = b[i++];
10878                 if (j >= NAM$C_MAXRSS)
10879                    break;
10880             }
10881             while ((j > 0) && !isprint(image_argv[j-1]))
10882                 j--;
10883             image_argv[j] = 0;
10884
10885             /* It will need to be converted to VMS format and validated */
10886             if (tmpspec[0] != '\0') {
10887               char * iname;
10888
10889                /* Try to find the exact program requested to be run */
10890               /*---------------------------------------------------*/
10891               iname = int_rmsexpand
10892                  (tmpspec, image_name, ".exe",
10893                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10894               if (iname != NULL) {
10895                 if (cando_by_name_int
10896                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10897                   /* MCR prefix needed */
10898                   isdcl = 0;
10899                 }
10900                 else {
10901                    /* Try again with a null type */
10902                   /*----------------------------*/
10903                   iname = int_rmsexpand
10904                     (tmpspec, image_name, ".",
10905                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10906                   if (iname != NULL) {
10907                     if (cando_by_name_int
10908                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10909                       /* MCR prefix needed */
10910                       isdcl = 0;
10911                     }
10912                   }
10913                 }
10914
10915                  /* Did we find the image to run the script? */
10916                 /*------------------------------------------*/
10917                 if (isdcl) {
10918                   char *tchr;
10919
10920                    /* Assume DCL or foreign command exists */
10921                   /*--------------------------------------*/
10922                   tchr = strrchr(tmpspec, '/');
10923                   if (tchr != NULL) {
10924                     tchr++;
10925                   }
10926                   else {
10927                     tchr = tmpspec;
10928                   }
10929                   strcpy(image_name, tchr);
10930                 }
10931               }
10932             }
10933           }
10934         }
10935         fclose(fp);
10936       }
10937       if (check_img && isdcl) {
10938           PerlMem_free(cmd);
10939           PerlMem_free(resspec);
10940           PerlMem_free(vmsspec);
10941           return RMS$_FNF;
10942       }
10943
10944       if (cando_by_name(S_IXUSR,0,resspec)) {
10945         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10946         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10947         if (!isdcl) {
10948             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
10949             if (image_name[0] != 0) {
10950                 strcat(vmscmd->dsc$a_pointer, image_name);
10951                 strcat(vmscmd->dsc$a_pointer, " ");
10952             }
10953         } else if (image_name[0] != 0) {
10954             strcpy(vmscmd->dsc$a_pointer, image_name);
10955             strcat(vmscmd->dsc$a_pointer, " ");
10956         } else {
10957             strcpy(vmscmd->dsc$a_pointer,"@");
10958         }
10959         if (suggest_quote) *suggest_quote = 1;
10960
10961         /* If there is an image name, use original command */
10962         if (image_name[0] == 0)
10963             strcat(vmscmd->dsc$a_pointer,resspec);
10964         else {
10965             rest = cmd;
10966             while (*rest && isspace(*rest)) rest++;
10967         }
10968
10969         if (image_argv[0] != 0) {
10970           strcat(vmscmd->dsc$a_pointer,image_argv);
10971           strcat(vmscmd->dsc$a_pointer, " ");
10972         }
10973         if (rest) {
10974            int rest_len;
10975            int vmscmd_len;
10976
10977            rest_len = strlen(rest);
10978            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10979            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10980               strcat(vmscmd->dsc$a_pointer,rest);
10981            else
10982              retsts = CLI$_BUFOVF;
10983         }
10984         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10985         PerlMem_free(cmd);
10986         PerlMem_free(vmsspec);
10987         PerlMem_free(resspec);
10988         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10989       }
10990       else
10991         retsts = RMS$_PRV;
10992     }
10993   }
10994   /* It's either a DCL command or we couldn't find a suitable image */
10995   vmscmd->dsc$w_length = strlen(cmd);
10996
10997   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
10998   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
10999   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
11000
11001   PerlMem_free(cmd);
11002   PerlMem_free(resspec);
11003   PerlMem_free(vmsspec);
11004
11005   /* check if it's a symbol (for quoting purposes) */
11006   if (suggest_quote && !*suggest_quote) {
11007     int iss;
11008     char equiv[LNM$C_NAMLENGTH];
11009     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11010     eqvdsc.dsc$a_pointer = equiv;
11011
11012     iss = lib$get_symbol(vmscmd,&eqvdsc);
11013     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
11014   }
11015   if (!(retsts & 1)) {
11016     /* just hand off status values likely to be due to user error */
11017     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
11018         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
11019        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
11020     else { _ckvmssts_noperl(retsts); }
11021   }
11022
11023   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
11024
11025 }  /* end of setup_cmddsc() */
11026
11027
11028 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
11029 bool
11030 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
11031 {
11032 bool exec_sts;
11033 char * cmd;
11034
11035   if (sp > mark) {
11036     if (vfork_called) {           /* this follows a vfork - act Unixish */
11037       vfork_called--;
11038       if (vfork_called < 0) {
11039         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
11040         vfork_called = 0;
11041       }
11042       else return do_aexec(really,mark,sp);
11043     }
11044                                            /* no vfork - act VMSish */
11045     cmd = setup_argstr(aTHX_ really,mark,sp);
11046     exec_sts = vms_do_exec(cmd);
11047     Safefree(cmd);  /* Clean up from setup_argstr() */
11048     return exec_sts;
11049   }
11050
11051   return FALSE;
11052 }  /* end of vms_do_aexec() */
11053 /*}}}*/
11054
11055 /* {{{bool vms_do_exec(char *cmd) */
11056 bool
11057 Perl_vms_do_exec(pTHX_ const char *cmd)
11058 {
11059   struct dsc$descriptor_s *vmscmd;
11060
11061   if (vfork_called) {             /* this follows a vfork - act Unixish */
11062     vfork_called--;
11063     if (vfork_called < 0) {
11064       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
11065       vfork_called = 0;
11066     }
11067     else return do_exec(cmd);
11068   }
11069
11070   {                               /* no vfork - act VMSish */
11071     unsigned long int retsts;
11072
11073     TAINT_ENV();
11074     TAINT_PROPER("exec");
11075     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
11076       retsts = lib$do_command(vmscmd);
11077
11078     switch (retsts) {
11079       case RMS$_FNF: case RMS$_DNF:
11080         set_errno(ENOENT); break;
11081       case RMS$_DIR:
11082         set_errno(ENOTDIR); break;
11083       case RMS$_DEV:
11084         set_errno(ENODEV); break;
11085       case RMS$_PRV:
11086         set_errno(EACCES); break;
11087       case RMS$_SYN:
11088         set_errno(EINVAL); break;
11089       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11090         set_errno(E2BIG); break;
11091       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11092         _ckvmssts_noperl(retsts); /* fall through */
11093       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11094         set_errno(EVMSERR);
11095     }
11096     set_vaxc_errno(retsts);
11097     if (ckWARN(WARN_EXEC)) {
11098       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
11099              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
11100     }
11101     vms_execfree(vmscmd);
11102   }
11103
11104   return FALSE;
11105
11106 }  /* end of vms_do_exec() */
11107 /*}}}*/
11108
11109 int do_spawn2(pTHX_ const char *, int);
11110
11111 int
11112 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
11113 {
11114 unsigned long int sts;
11115 char * cmd;
11116 int flags = 0;
11117
11118   if (sp > mark) {
11119
11120     /* We'll copy the (undocumented?) Win32 behavior and allow a
11121      * numeric first argument.  But the only value we'll support
11122      * through do_aspawn is a value of 1, which means spawn without
11123      * waiting for completion -- other values are ignored.
11124      */
11125     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
11126         ++mark;
11127         flags = SvIVx(*mark);
11128     }
11129
11130     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
11131         flags = CLI$M_NOWAIT;
11132     else
11133         flags = 0;
11134
11135     cmd = setup_argstr(aTHX_ really, mark, sp);
11136     sts = do_spawn2(aTHX_ cmd, flags);
11137     /* pp_sys will clean up cmd */
11138     return sts;
11139   }
11140   return SS$_ABORT;
11141 }  /* end of do_aspawn() */
11142 /*}}}*/
11143
11144
11145 /* {{{int do_spawn(char* cmd) */
11146 int
11147 Perl_do_spawn(pTHX_ char* cmd)
11148 {
11149     PERL_ARGS_ASSERT_DO_SPAWN;
11150
11151     return do_spawn2(aTHX_ cmd, 0);
11152 }
11153 /*}}}*/
11154
11155 /* {{{int do_spawn_nowait(char* cmd) */
11156 int
11157 Perl_do_spawn_nowait(pTHX_ char* cmd)
11158 {
11159     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
11160
11161     return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
11162 }
11163 /*}}}*/
11164
11165 /* {{{int do_spawn2(char *cmd) */
11166 int
11167 do_spawn2(pTHX_ const char *cmd, int flags)
11168 {
11169   unsigned long int sts, substs;
11170
11171   /* The caller of this routine expects to Safefree(PL_Cmd) */
11172   Newx(PL_Cmd,10,char);
11173
11174   TAINT_ENV();
11175   TAINT_PROPER("spawn");
11176   if (!cmd || !*cmd) {
11177     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
11178     if (!(sts & 1)) {
11179       switch (sts) {
11180         case RMS$_FNF:  case RMS$_DNF:
11181           set_errno(ENOENT); break;
11182         case RMS$_DIR:
11183           set_errno(ENOTDIR); break;
11184         case RMS$_DEV:
11185           set_errno(ENODEV); break;
11186         case RMS$_PRV:
11187           set_errno(EACCES); break;
11188         case RMS$_SYN:
11189           set_errno(EINVAL); break;
11190         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11191           set_errno(E2BIG); break;
11192         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11193           _ckvmssts_noperl(sts); /* fall through */
11194         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11195           set_errno(EVMSERR);
11196       }
11197       set_vaxc_errno(sts);
11198       if (ckWARN(WARN_EXEC)) {
11199         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
11200                     Strerror(errno));
11201       }
11202     }
11203     sts = substs;
11204   }
11205   else {
11206     char mode[3];
11207     PerlIO * fp;
11208     if (flags & CLI$M_NOWAIT)
11209         strcpy(mode, "n");
11210     else
11211         strcpy(mode, "nW");
11212
11213     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
11214     if (fp != NULL)
11215       my_pclose(fp);
11216     /* sts will be the pid in the nowait case */
11217   }
11218   return sts;
11219 }  /* end of do_spawn2() */
11220 /*}}}*/
11221
11222
11223 static unsigned int *sockflags, sockflagsize;
11224
11225 /*
11226  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
11227  * routines found in some versions of the CRTL can't deal with sockets.
11228  * We don't shim the other file open routines since a socket isn't
11229  * likely to be opened by a name.
11230  */
11231 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
11232 FILE *my_fdopen(int fd, const char *mode)
11233 {
11234   FILE *fp = fdopen(fd, mode);
11235
11236   if (fp) {
11237     unsigned int fdoff = fd / sizeof(unsigned int);
11238     Stat_t sbuf; /* native stat; we don't need flex_stat */
11239     if (!sockflagsize || fdoff > sockflagsize) {
11240       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
11241       else           Newx  (sockflags,fdoff+2,unsigned int);
11242       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11243       sockflagsize = fdoff + 2;
11244     }
11245     if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
11246       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11247   }
11248   return fp;
11249
11250 }
11251 /*}}}*/
11252
11253
11254 /*
11255  * Clear the corresponding bit when the (possibly) socket stream is closed.
11256  * There still a small hole: we miss an implicit close which might occur
11257  * via freopen().  >> Todo
11258  */
11259 /*{{{ int my_fclose(FILE *fp)*/
11260 int my_fclose(FILE *fp) {
11261   if (fp) {
11262     unsigned int fd = fileno(fp);
11263     unsigned int fdoff = fd / sizeof(unsigned int);
11264
11265     if (sockflagsize && fdoff < sockflagsize)
11266       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11267   }
11268   return fclose(fp);
11269 }
11270 /*}}}*/
11271
11272
11273 /*
11274  * A simple fwrite replacement which outputs itmsz*nitm chars without
11275  * introducing record boundaries every itmsz chars.
11276  * We are using fputs, which depends on a terminating null.  We may
11277  * well be writing binary data, so we need to accommodate not only
11278  * data with nulls sprinkled in the middle but also data with no null
11279  * byte at the end.
11280  */
11281 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
11282 int
11283 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11284 {
11285   register char *cp, *end, *cpd, *data;
11286   register unsigned int fd = fileno(dest);
11287   register unsigned int fdoff = fd / sizeof(unsigned int);
11288   int retval;
11289   int bufsize = itmsz * nitm + 1;
11290
11291   if (fdoff < sockflagsize &&
11292       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11293     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11294     return nitm;
11295   }
11296
11297   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11298   memcpy( data, src, itmsz*nitm );
11299   data[itmsz*nitm] = '\0';
11300
11301   end = data + itmsz * nitm;
11302   retval = (int) nitm; /* on success return # items written */
11303
11304   cpd = data;
11305   while (cpd <= end) {
11306     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11307     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11308     if (cp < end)
11309       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11310     cpd = cp + 1;
11311   }
11312
11313   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11314   return retval;
11315
11316 }  /* end of my_fwrite() */
11317 /*}}}*/
11318
11319 /*{{{ int my_flush(FILE *fp)*/
11320 int
11321 Perl_my_flush(pTHX_ FILE *fp)
11322 {
11323     int res;
11324     if ((res = fflush(fp)) == 0 && fp) {
11325 #ifdef VMS_DO_SOCKETS
11326         Stat_t s;
11327         if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11328 #endif
11329             res = fsync(fileno(fp));
11330     }
11331 /*
11332  * If the flush succeeded but set end-of-file, we need to clear
11333  * the error because our caller may check ferror().  BTW, this
11334  * probably means we just flushed an empty file.
11335  */
11336     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11337
11338     return res;
11339 }
11340 /*}}}*/
11341
11342 /* fgetname() is not returning the correct file specifications when
11343  * decc_filename_unix_report mode is active.  So we have to have it
11344  * aways return filenames in VMS mode and convert it ourselves.
11345  */
11346
11347 /*{{{ char * my_fgetname(FILE *fp, buf)*/
11348 char *
11349 Perl_my_fgetname(FILE *fp, char * buf) {
11350     char * retname;
11351     char * vms_name;
11352
11353     retname = fgetname(fp, buf, 1);
11354
11355     /* If we are in VMS mode, then we are done */
11356     if (!decc_filename_unix_report || (retname == NULL)) {
11357        return retname;
11358     }
11359
11360     /* Convert this to Unix format */
11361     vms_name = PerlMem_malloc(VMS_MAXRSS + 1);
11362     strcpy(vms_name, retname);
11363     retname = int_tounixspec(vms_name, buf, NULL);
11364     PerlMem_free(vms_name);
11365
11366     return retname;
11367 }
11368 /*}}}*/
11369
11370 /*
11371  * Here are replacements for the following Unix routines in the VMS environment:
11372  *      getpwuid    Get information for a particular UIC or UID
11373  *      getpwnam    Get information for a named user
11374  *      getpwent    Get information for each user in the rights database
11375  *      setpwent    Reset search to the start of the rights database
11376  *      endpwent    Finish searching for users in the rights database
11377  *
11378  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11379  * (defined in pwd.h), which contains the following fields:-
11380  *      struct passwd {
11381  *              char        *pw_name;    Username (in lower case)
11382  *              char        *pw_passwd;  Hashed password
11383  *              unsigned int pw_uid;     UIC
11384  *              unsigned int pw_gid;     UIC group  number
11385  *              char        *pw_unixdir; Default device/directory (VMS-style)
11386  *              char        *pw_gecos;   Owner name
11387  *              char        *pw_dir;     Default device/directory (Unix-style)
11388  *              char        *pw_shell;   Default CLI name (eg. DCL)
11389  *      };
11390  * If the specified user does not exist, getpwuid and getpwnam return NULL.
11391  *
11392  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11393  * not the UIC member number (eg. what's returned by getuid()),
11394  * getpwuid() can accept either as input (if uid is specified, the caller's
11395  * UIC group is used), though it won't recognise gid=0.
11396  *
11397  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11398  * information about other users in your group or in other groups, respectively.
11399  * If the required privilege is not available, then these routines fill only
11400  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11401  * string).
11402  *
11403  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11404  */
11405
11406 /* sizes of various UAF record fields */
11407 #define UAI$S_USERNAME 12
11408 #define UAI$S_IDENT    31
11409 #define UAI$S_OWNER    31
11410 #define UAI$S_DEFDEV   31
11411 #define UAI$S_DEFDIR   63
11412 #define UAI$S_DEFCLI   31
11413 #define UAI$S_PWD       8
11414
11415 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
11416                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11417                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
11418
11419 static char __empty[]= "";
11420 static struct passwd __passwd_empty=
11421     {(char *) __empty, (char *) __empty, 0, 0,
11422      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11423 static int contxt= 0;
11424 static struct passwd __pwdcache;
11425 static char __pw_namecache[UAI$S_IDENT+1];
11426
11427 /*
11428  * This routine does most of the work extracting the user information.
11429  */
11430 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11431 {
11432     static struct {
11433         unsigned char length;
11434         char pw_gecos[UAI$S_OWNER+1];
11435     } owner;
11436     static union uicdef uic;
11437     static struct {
11438         unsigned char length;
11439         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11440     } defdev;
11441     static struct {
11442         unsigned char length;
11443         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11444     } defdir;
11445     static struct {
11446         unsigned char length;
11447         char pw_shell[UAI$S_DEFCLI+1];
11448     } defcli;
11449     static char pw_passwd[UAI$S_PWD+1];
11450
11451     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11452     struct dsc$descriptor_s name_desc;
11453     unsigned long int sts;
11454
11455     static struct itmlst_3 itmlst[]= {
11456         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
11457         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
11458         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
11459         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
11460         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
11461         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
11462         {0,                0,           NULL,    NULL}};
11463
11464     name_desc.dsc$w_length=  strlen(name);
11465     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11466     name_desc.dsc$b_class=   DSC$K_CLASS_S;
11467     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11468
11469 /*  Note that sys$getuai returns many fields as counted strings. */
11470     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11471     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11472       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11473     }
11474     else { _ckvmssts(sts); }
11475     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
11476
11477     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
11478     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11479     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11480     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11481     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11482     owner.pw_gecos[lowner]=            '\0';
11483     defdev.pw_dir[ldefdev+ldefdir]= '\0';
11484     defcli.pw_shell[ldefcli]=          '\0';
11485     if (valid_uic(uic)) {
11486         pwd->pw_uid= uic.uic$l_uic;
11487         pwd->pw_gid= uic.uic$v_group;
11488     }
11489     else
11490       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11491     pwd->pw_passwd=  pw_passwd;
11492     pwd->pw_gecos=   owner.pw_gecos;
11493     pwd->pw_dir=     defdev.pw_dir;
11494     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11495     pwd->pw_shell=   defcli.pw_shell;
11496     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11497         int ldir;
11498         ldir= strlen(pwd->pw_unixdir) - 1;
11499         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11500     }
11501     else
11502         strcpy(pwd->pw_unixdir, pwd->pw_dir);
11503     if (!decc_efs_case_preserve)
11504         __mystrtolower(pwd->pw_unixdir);
11505     return 1;
11506 }
11507
11508 /*
11509  * Get information for a named user.
11510 */
11511 /*{{{struct passwd *getpwnam(char *name)*/
11512 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
11513 {
11514     struct dsc$descriptor_s name_desc;
11515     union uicdef uic;
11516     unsigned long int status, sts;
11517
11518     __pwdcache = __passwd_empty;
11519     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11520       /* We still may be able to determine pw_uid and pw_gid */
11521       name_desc.dsc$w_length=  strlen(name);
11522       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11523       name_desc.dsc$b_class=   DSC$K_CLASS_S;
11524       name_desc.dsc$a_pointer= (char *) name;
11525       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11526         __pwdcache.pw_uid= uic.uic$l_uic;
11527         __pwdcache.pw_gid= uic.uic$v_group;
11528       }
11529       else {
11530         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11531           set_vaxc_errno(sts);
11532           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11533           return NULL;
11534         }
11535         else { _ckvmssts(sts); }
11536       }
11537     }
11538     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
11539     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
11540     __pwdcache.pw_name= __pw_namecache;
11541     return &__pwdcache;
11542 }  /* end of my_getpwnam() */
11543 /*}}}*/
11544
11545 /*
11546  * Get information for a particular UIC or UID.
11547  * Called by my_getpwent with uid=-1 to list all users.
11548 */
11549 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11550 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
11551 {
11552     const $DESCRIPTOR(name_desc,__pw_namecache);
11553     unsigned short lname;
11554     union uicdef uic;
11555     unsigned long int status;
11556
11557     if (uid == (unsigned int) -1) {
11558       do {
11559         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11560         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11561           set_vaxc_errno(status);
11562           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11563           my_endpwent();
11564           return NULL;
11565         }
11566         else { _ckvmssts(status); }
11567       } while (!valid_uic (uic));
11568     }
11569     else {
11570       uic.uic$l_uic= uid;
11571       if (!uic.uic$v_group)
11572         uic.uic$v_group= PerlProc_getgid();
11573       if (valid_uic(uic))
11574         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11575       else status = SS$_IVIDENT;
11576       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11577           status == RMS$_PRV) {
11578         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11579         return NULL;
11580       }
11581       else { _ckvmssts(status); }
11582     }
11583     __pw_namecache[lname]= '\0';
11584     __mystrtolower(__pw_namecache);
11585
11586     __pwdcache = __passwd_empty;
11587     __pwdcache.pw_name = __pw_namecache;
11588
11589 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11590     The identifier's value is usually the UIC, but it doesn't have to be,
11591     so if we can, we let fillpasswd update this. */
11592     __pwdcache.pw_uid =  uic.uic$l_uic;
11593     __pwdcache.pw_gid =  uic.uic$v_group;
11594
11595     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11596     return &__pwdcache;
11597
11598 }  /* end of my_getpwuid() */
11599 /*}}}*/
11600
11601 /*
11602  * Get information for next user.
11603 */
11604 /*{{{struct passwd *my_getpwent()*/
11605 struct passwd *Perl_my_getpwent(pTHX)
11606 {
11607     return (my_getpwuid((unsigned int) -1));
11608 }
11609 /*}}}*/
11610
11611 /*
11612  * Finish searching rights database for users.
11613 */
11614 /*{{{void my_endpwent()*/
11615 void Perl_my_endpwent(pTHX)
11616 {
11617     if (contxt) {
11618       _ckvmssts(sys$finish_rdb(&contxt));
11619       contxt= 0;
11620     }
11621 }
11622 /*}}}*/
11623
11624 #ifdef HOMEGROWN_POSIX_SIGNALS
11625   /* Signal handling routines, pulled into the core from POSIX.xs.
11626    *
11627    * We need these for threads, so they've been rolled into the core,
11628    * rather than left in POSIX.xs.
11629    *
11630    * (DRS, Oct 23, 1997)
11631    */
11632
11633   /* sigset_t is atomic under VMS, so these routines are easy */
11634 /*{{{int my_sigemptyset(sigset_t *) */
11635 int my_sigemptyset(sigset_t *set) {
11636     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11637     *set = 0; return 0;
11638 }
11639 /*}}}*/
11640
11641
11642 /*{{{int my_sigfillset(sigset_t *)*/
11643 int my_sigfillset(sigset_t *set) {
11644     int i;
11645     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11646     for (i = 0; i < NSIG; i++) *set |= (1 << i);
11647     return 0;
11648 }
11649 /*}}}*/
11650
11651
11652 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
11653 int my_sigaddset(sigset_t *set, int sig) {
11654     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11655     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11656     *set |= (1 << (sig - 1));
11657     return 0;
11658 }
11659 /*}}}*/
11660
11661
11662 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
11663 int my_sigdelset(sigset_t *set, int sig) {
11664     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11665     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11666     *set &= ~(1 << (sig - 1));
11667     return 0;
11668 }
11669 /*}}}*/
11670
11671
11672 /*{{{int my_sigismember(sigset_t *set, int sig)*/
11673 int my_sigismember(sigset_t *set, int sig) {
11674     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11675     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11676     return *set & (1 << (sig - 1));
11677 }
11678 /*}}}*/
11679
11680
11681 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
11682 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
11683     sigset_t tempmask;
11684
11685     /* If set and oset are both null, then things are badly wrong. Bail out. */
11686     if ((oset == NULL) && (set == NULL)) {
11687       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
11688       return -1;
11689     }
11690
11691     /* If set's null, then we're just handling a fetch. */
11692     if (set == NULL) {
11693         tempmask = sigblock(0);
11694     }
11695     else {
11696       switch (how) {
11697       case SIG_SETMASK:
11698         tempmask = sigsetmask(*set);
11699         break;
11700       case SIG_BLOCK:
11701         tempmask = sigblock(*set);
11702         break;
11703       case SIG_UNBLOCK:
11704         tempmask = sigblock(0);
11705         sigsetmask(*oset & ~tempmask);
11706         break;
11707       default:
11708         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11709         return -1;
11710       }
11711     }
11712
11713     /* Did they pass us an oset? If so, stick our holding mask into it */
11714     if (oset)
11715       *oset = tempmask;
11716
11717     return 0;
11718 }
11719 /*}}}*/
11720 #endif  /* HOMEGROWN_POSIX_SIGNALS */
11721
11722
11723 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11724  * my_utime(), and flex_stat(), all of which operate on UTC unless
11725  * VMSISH_TIMES is true.
11726  */
11727 /* method used to handle UTC conversions:
11728  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
11729  */
11730 static int gmtime_emulation_type;
11731 /* number of secs to add to UTC POSIX-style time to get local time */
11732 static long int utc_offset_secs;
11733
11734 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11735  * in vmsish.h.  #undef them here so we can call the CRTL routines
11736  * directly.
11737  */
11738 #undef gmtime
11739 #undef localtime
11740 #undef time
11741
11742
11743 /*
11744  * DEC C previous to 6.0 corrupts the behavior of the /prefix
11745  * qualifier with the extern prefix pragma.  This provisional
11746  * hack circumvents this prefix pragma problem in previous
11747  * precompilers.
11748  */
11749 #if defined(__VMS_VER) && __VMS_VER >= 70000000
11750 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
11751 #    pragma __extern_prefix save
11752 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
11753 #    define gmtime decc$__utctz_gmtime
11754 #    define localtime decc$__utctz_localtime
11755 #    define time decc$__utc_time
11756 #    pragma __extern_prefix restore
11757
11758      struct tm *gmtime(), *localtime();
11759
11760 #  endif
11761 #endif
11762
11763
11764 static time_t toutc_dst(time_t loc) {
11765   struct tm *rsltmp;
11766
11767   if ((rsltmp = localtime(&loc)) == NULL) return -1;
11768   loc -= utc_offset_secs;
11769   if (rsltmp->tm_isdst) loc -= 3600;
11770   return loc;
11771 }
11772 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11773        ((gmtime_emulation_type || my_time(NULL)), \
11774        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11775        ((secs) - utc_offset_secs))))
11776
11777 static time_t toloc_dst(time_t utc) {
11778   struct tm *rsltmp;
11779
11780   utc += utc_offset_secs;
11781   if ((rsltmp = localtime(&utc)) == NULL) return -1;
11782   if (rsltmp->tm_isdst) utc += 3600;
11783   return utc;
11784 }
11785 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11786        ((gmtime_emulation_type || my_time(NULL)), \
11787        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11788        ((secs) + utc_offset_secs))))
11789
11790 #ifndef RTL_USES_UTC
11791 /*
11792
11793     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
11794         DST starts on 1st sun of april      at 02:00  std time
11795             ends on last sun of october     at 02:00  dst time
11796     see the UCX management command reference, SET CONFIG TIMEZONE
11797     for formatting info.
11798
11799     No, it's not as general as it should be, but then again, NOTHING
11800     will handle UK times in a sensible way.
11801 */
11802
11803
11804 /*
11805     parse the DST start/end info:
11806     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
11807 */
11808
11809 static char *
11810 tz_parse_startend(char *s, struct tm *w, int *past)
11811 {
11812     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
11813     int ly, dozjd, d, m, n, hour, min, sec, j, k;
11814     time_t g;
11815
11816     if (!s)    return 0;
11817     if (!w) return 0;
11818     if (!past) return 0;
11819
11820     ly = 0;
11821     if (w->tm_year % 4        == 0) ly = 1;
11822     if (w->tm_year % 100      == 0) ly = 0;
11823     if (w->tm_year+1900 % 400 == 0) ly = 1;
11824     if (ly) dinm[1]++;
11825
11826     dozjd = isdigit(*s);
11827     if (*s == 'J' || *s == 'j' || dozjd) {
11828         if (!dozjd && !isdigit(*++s)) return 0;
11829         d = *s++ - '0';
11830         if (isdigit(*s)) {
11831             d = d*10 + *s++ - '0';
11832             if (isdigit(*s)) {
11833                 d = d*10 + *s++ - '0';
11834             }
11835         }
11836         if (d == 0) return 0;
11837         if (d > 366) return 0;
11838         d--;
11839         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
11840         g = d * 86400;
11841         dozjd = 1;
11842     } else if (*s == 'M' || *s == 'm') {
11843         if (!isdigit(*++s)) return 0;
11844         m = *s++ - '0';
11845         if (isdigit(*s)) m = 10*m + *s++ - '0';
11846         if (*s != '.') return 0;
11847         if (!isdigit(*++s)) return 0;
11848         n = *s++ - '0';
11849         if (n < 1 || n > 5) return 0;
11850         if (*s != '.') return 0;
11851         if (!isdigit(*++s)) return 0;
11852         d = *s++ - '0';
11853         if (d > 6) return 0;
11854     }
11855
11856     if (*s == '/') {
11857         if (!isdigit(*++s)) return 0;
11858         hour = *s++ - '0';
11859         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
11860         if (*s == ':') {
11861             if (!isdigit(*++s)) return 0;
11862             min = *s++ - '0';
11863             if (isdigit(*s)) min = 10*min + *s++ - '0';
11864             if (*s == ':') {
11865                 if (!isdigit(*++s)) return 0;
11866                 sec = *s++ - '0';
11867                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
11868             }
11869         }
11870     } else {
11871         hour = 2;
11872         min = 0;
11873         sec = 0;
11874     }
11875
11876     if (dozjd) {
11877         if (w->tm_yday < d) goto before;
11878         if (w->tm_yday > d) goto after;
11879     } else {
11880         if (w->tm_mon+1 < m) goto before;
11881         if (w->tm_mon+1 > m) goto after;
11882
11883         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
11884         k = d - j; /* mday of first d */
11885         if (k <= 0) k += 7;
11886         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
11887         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
11888         if (w->tm_mday < k) goto before;
11889         if (w->tm_mday > k) goto after;
11890     }
11891
11892     if (w->tm_hour < hour) goto before;
11893     if (w->tm_hour > hour) goto after;
11894     if (w->tm_min  < min)  goto before;
11895     if (w->tm_min  > min)  goto after;
11896     if (w->tm_sec  < sec)  goto before;
11897     goto after;
11898
11899 before:
11900     *past = 0;
11901     return s;
11902 after:
11903     *past = 1;
11904     return s;
11905 }
11906
11907
11908
11909
11910 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
11911
11912 static char *
11913 tz_parse_offset(char *s, int *offset)
11914 {
11915     int hour = 0, min = 0, sec = 0;
11916     int neg = 0;
11917     if (!s) return 0;
11918     if (!offset) return 0;
11919
11920     if (*s == '-') {neg++; s++;}
11921     if (*s == '+') s++;
11922     if (!isdigit(*s)) return 0;
11923     hour = *s++ - '0';
11924     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
11925     if (hour > 24) return 0;
11926     if (*s == ':') {
11927         if (!isdigit(*++s)) return 0;
11928         min = *s++ - '0';
11929         if (isdigit(*s)) min = min*10 + (*s++ - '0');
11930         if (min > 59) return 0;
11931         if (*s == ':') {
11932             if (!isdigit(*++s)) return 0;
11933             sec = *s++ - '0';
11934             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
11935             if (sec > 59) return 0;
11936         }
11937     }
11938
11939     *offset = (hour*60+min)*60 + sec;
11940     if (neg) *offset = -*offset;
11941     return s;
11942 }
11943
11944 /*
11945     input time is w, whatever type of time the CRTL localtime() uses.
11946     sets dst, the zone, and the gmtoff (seconds)
11947
11948     caches the value of TZ and UCX$TZ env variables; note that
11949     my_setenv looks for these and sets a flag if they're changed
11950     for efficiency.
11951
11952     We have to watch out for the "australian" case (dst starts in
11953     october, ends in april)...flagged by "reverse" and checked by
11954     scanning through the months of the previous year.
11955
11956 */
11957
11958 static int
11959 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
11960 {
11961     time_t when;
11962     struct tm *w2;
11963     char *s,*s2;
11964     char *dstzone, *tz, *s_start, *s_end;
11965     int std_off, dst_off, isdst;
11966     int y, dststart, dstend;
11967     static char envtz[1025];  /* longer than any logical, symbol, ... */
11968     static char ucxtz[1025];
11969     static char reversed = 0;
11970
11971     if (!w) return 0;
11972
11973     if (tz_updated) {
11974         tz_updated = 0;
11975         reversed = -1;  /* flag need to check  */
11976         envtz[0] = ucxtz[0] = '\0';
11977         tz = my_getenv("TZ",0);
11978         if (tz) strcpy(envtz, tz);
11979         tz = my_getenv("UCX$TZ",0);
11980         if (tz) strcpy(ucxtz, tz);
11981         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
11982     }
11983     tz = envtz;
11984     if (!*tz) tz = ucxtz;
11985
11986     s = tz;
11987     while (isalpha(*s)) s++;
11988     s = tz_parse_offset(s, &std_off);
11989     if (!s) return 0;
11990     if (!*s) {                  /* no DST, hurray we're done! */
11991         isdst = 0;
11992         goto done;
11993     }
11994
11995     dstzone = s;
11996     while (isalpha(*s)) s++;
11997     s2 = tz_parse_offset(s, &dst_off);
11998     if (s2) {
11999         s = s2;
12000     } else {
12001         dst_off = std_off - 3600;
12002     }
12003
12004     if (!*s) {      /* default dst start/end?? */
12005         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
12006             s = strchr(ucxtz,',');
12007         }
12008         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
12009     }
12010     if (*s != ',') return 0;
12011
12012     when = *w;
12013     when = _toutc(when);      /* convert to utc */
12014     when = when - std_off;    /* convert to pseudolocal time*/
12015
12016     w2 = localtime(&when);
12017     y = w2->tm_year;
12018     s_start = s+1;
12019     s = tz_parse_startend(s_start,w2,&dststart);
12020     if (!s) return 0;
12021     if (*s != ',') return 0;
12022
12023     when = *w;
12024     when = _toutc(when);      /* convert to utc */
12025     when = when - dst_off;    /* convert to pseudolocal time*/
12026     w2 = localtime(&when);
12027     if (w2->tm_year != y) {   /* spans a year, just check one time */
12028         when += dst_off - std_off;
12029         w2 = localtime(&when);
12030     }
12031     s_end = s+1;
12032     s = tz_parse_startend(s_end,w2,&dstend);
12033     if (!s) return 0;
12034
12035     if (reversed == -1) {  /* need to check if start later than end */
12036         int j, ds, de;
12037
12038         when = *w;
12039         if (when < 2*365*86400) {
12040             when += 2*365*86400;
12041         } else {
12042             when -= 365*86400;
12043         }
12044         w2 =localtime(&when);
12045         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
12046
12047         for (j = 0; j < 12; j++) {
12048             w2 =localtime(&when);
12049             tz_parse_startend(s_start,w2,&ds);
12050             tz_parse_startend(s_end,w2,&de);
12051             if (ds != de) break;
12052             when += 30*86400;
12053         }
12054         reversed = 0;
12055         if (de && !ds) reversed = 1;
12056     }
12057
12058     isdst = dststart && !dstend;
12059     if (reversed) isdst = dststart  || !dstend;
12060
12061 done:
12062     if (dst)    *dst = isdst;
12063     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
12064     if (isdst)  tz = dstzone;
12065     if (zone) {
12066         while(isalpha(*tz))  *zone++ = *tz++;
12067         *zone = '\0';
12068     }
12069     return 1;
12070 }
12071
12072 #endif /* !RTL_USES_UTC */
12073
12074 /* my_time(), my_localtime(), my_gmtime()
12075  * By default traffic in UTC time values, using CRTL gmtime() or
12076  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
12077  * Note: We need to use these functions even when the CRTL has working
12078  * UTC support, since they also handle C<use vmsish qw(times);>
12079  *
12080  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
12081  * Modified by Charles Bailey <bailey@newman.upenn.edu>
12082  */
12083
12084 /*{{{time_t my_time(time_t *timep)*/
12085 time_t Perl_my_time(pTHX_ time_t *timep)
12086 {
12087   time_t when;
12088   struct tm *tm_p;
12089
12090   if (gmtime_emulation_type == 0) {
12091     int dstnow;
12092     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
12093                               /* results of calls to gmtime() and localtime() */
12094                               /* for same &base */
12095
12096     gmtime_emulation_type++;
12097     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
12098       char off[LNM$C_NAMLENGTH+1];;
12099
12100       gmtime_emulation_type++;
12101       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
12102         gmtime_emulation_type++;
12103         utc_offset_secs = 0;
12104         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
12105       }
12106       else { utc_offset_secs = atol(off); }
12107     }
12108     else { /* We've got a working gmtime() */
12109       struct tm gmt, local;
12110
12111       gmt = *tm_p;
12112       tm_p = localtime(&base);
12113       local = *tm_p;
12114       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
12115       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
12116       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
12117       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
12118     }
12119   }
12120
12121   when = time(NULL);
12122 # ifdef VMSISH_TIME
12123 # ifdef RTL_USES_UTC
12124   if (VMSISH_TIME) when = _toloc(when);
12125 # else
12126   if (!VMSISH_TIME) when = _toutc(when);
12127 # endif
12128 # endif
12129   if (timep != NULL) *timep = when;
12130   return when;
12131
12132 }  /* end of my_time() */
12133 /*}}}*/
12134
12135
12136 /*{{{struct tm *my_gmtime(const time_t *timep)*/
12137 struct tm *
12138 Perl_my_gmtime(pTHX_ const time_t *timep)
12139 {
12140   char *p;
12141   time_t when;
12142   struct tm *rsltmp;
12143
12144   if (timep == NULL) {
12145     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12146     return NULL;
12147   }
12148   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
12149
12150   when = *timep;
12151 # ifdef VMSISH_TIME
12152   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
12153 #  endif
12154 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
12155   return gmtime(&when);
12156 # else
12157   /* CRTL localtime() wants local time as input, so does no tz correction */
12158   rsltmp = localtime(&when);
12159   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
12160   return rsltmp;
12161 #endif
12162 }  /* end of my_gmtime() */
12163 /*}}}*/
12164
12165
12166 /*{{{struct tm *my_localtime(const time_t *timep)*/
12167 struct tm *
12168 Perl_my_localtime(pTHX_ const time_t *timep)
12169 {
12170   time_t when, whenutc;
12171   struct tm *rsltmp;
12172   int dst, offset;
12173
12174   if (timep == NULL) {
12175     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12176     return NULL;
12177   }
12178   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
12179   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
12180
12181   when = *timep;
12182 # ifdef RTL_USES_UTC
12183 # ifdef VMSISH_TIME
12184   if (VMSISH_TIME) when = _toutc(when);
12185 # endif
12186   /* CRTL localtime() wants UTC as input, does tz correction itself */
12187   return localtime(&when);
12188
12189 # else /* !RTL_USES_UTC */
12190   whenutc = when;
12191 # ifdef VMSISH_TIME
12192   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
12193   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
12194 # endif
12195   dst = -1;
12196 #ifndef RTL_USES_UTC
12197   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
12198       when = whenutc - offset;                   /* pseudolocal time*/
12199   }
12200 # endif
12201   /* CRTL localtime() wants local time as input, so does no tz correction */
12202   rsltmp = localtime(&when);
12203   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
12204   return rsltmp;
12205 # endif
12206
12207 } /*  end of my_localtime() */
12208 /*}}}*/
12209
12210 /* Reset definitions for later calls */
12211 #define gmtime(t)    my_gmtime(t)
12212 #define localtime(t) my_localtime(t)
12213 #define time(t)      my_time(t)
12214
12215
12216 /* my_utime - update modification/access time of a file
12217  *
12218  * VMS 7.3 and later implementation
12219  * Only the UTC translation is home-grown. The rest is handled by the
12220  * CRTL utime(), which will take into account the relevant feature
12221  * logicals and ODS-5 volume characteristics for true access times.
12222  *
12223  * pre VMS 7.3 implementation:
12224  * The calling sequence is identical to POSIX utime(), but under
12225  * VMS with ODS-2, only the modification time is changed; ODS-2 does
12226  * not maintain access times.  Restrictions differ from the POSIX
12227  * definition in that the time can be changed as long as the
12228  * caller has permission to execute the necessary IO$_MODIFY $QIO;
12229  * no separate checks are made to insure that the caller is the
12230  * owner of the file or has special privs enabled.
12231  * Code here is based on Joe Meadows' FILE utility.
12232  *
12233  */
12234
12235 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
12236  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
12237  * in 100 ns intervals.
12238  */
12239 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
12240
12241 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
12242 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
12243 {
12244 #if __CRTL_VER >= 70300000
12245   struct utimbuf utc_utimes, *utc_utimesp;
12246
12247   if (utimes != NULL) {
12248     utc_utimes.actime = utimes->actime;
12249     utc_utimes.modtime = utimes->modtime;
12250 # ifdef VMSISH_TIME
12251     /* If input was local; convert to UTC for sys svc */
12252     if (VMSISH_TIME) {
12253       utc_utimes.actime = _toutc(utimes->actime);
12254       utc_utimes.modtime = _toutc(utimes->modtime);
12255     }
12256 # endif
12257     utc_utimesp = &utc_utimes;
12258   }
12259   else {
12260     utc_utimesp = NULL;
12261   }
12262
12263   return utime(file, utc_utimesp);
12264
12265 #else /* __CRTL_VER < 70300000 */
12266
12267   register int i;
12268   int sts;
12269   long int bintime[2], len = 2, lowbit, unixtime,
12270            secscale = 10000000; /* seconds --> 100 ns intervals */
12271   unsigned long int chan, iosb[2], retsts;
12272   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
12273   struct FAB myfab = cc$rms_fab;
12274   struct NAM mynam = cc$rms_nam;
12275 #if defined (__DECC) && defined (__VAX)
12276   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
12277    * at least through VMS V6.1, which causes a type-conversion warning.
12278    */
12279 #  pragma message save
12280 #  pragma message disable cvtdiftypes
12281 #endif
12282   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
12283   struct fibdef myfib;
12284 #if defined (__DECC) && defined (__VAX)
12285   /* This should be right after the declaration of myatr, but due
12286    * to a bug in VAX DEC C, this takes effect a statement early.
12287    */
12288 #  pragma message restore
12289 #endif
12290   /* cast ok for read only parameter */
12291   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
12292                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
12293                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
12294
12295   if (file == NULL || *file == '\0') {
12296     SETERRNO(ENOENT, LIB$_INVARG);
12297     return -1;
12298   }
12299
12300   /* Convert to VMS format ensuring that it will fit in 255 characters */
12301   if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
12302       SETERRNO(ENOENT, LIB$_INVARG);
12303       return -1;
12304   }
12305   if (utimes != NULL) {
12306     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
12307      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
12308      * Since time_t is unsigned long int, and lib$emul takes a signed long int
12309      * as input, we force the sign bit to be clear by shifting unixtime right
12310      * one bit, then multiplying by an extra factor of 2 in lib$emul().
12311      */
12312     lowbit = (utimes->modtime & 1) ? secscale : 0;
12313     unixtime = (long int) utimes->modtime;
12314 #   ifdef VMSISH_TIME
12315     /* If input was UTC; convert to local for sys svc */
12316     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
12317 #   endif
12318     unixtime >>= 1;  secscale <<= 1;
12319     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
12320     if (!(retsts & 1)) {
12321       SETERRNO(EVMSERR, retsts);
12322       return -1;
12323     }
12324     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
12325     if (!(retsts & 1)) {
12326       SETERRNO(EVMSERR, retsts);
12327       return -1;
12328     }
12329   }
12330   else {
12331     /* Just get the current time in VMS format directly */
12332     retsts = sys$gettim(bintime);
12333     if (!(retsts & 1)) {
12334       SETERRNO(EVMSERR, retsts);
12335       return -1;
12336     }
12337   }
12338
12339   myfab.fab$l_fna = vmsspec;
12340   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
12341   myfab.fab$l_nam = &mynam;
12342   mynam.nam$l_esa = esa;
12343   mynam.nam$b_ess = (unsigned char) sizeof esa;
12344   mynam.nam$l_rsa = rsa;
12345   mynam.nam$b_rss = (unsigned char) sizeof rsa;
12346   if (decc_efs_case_preserve)
12347       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
12348
12349   /* Look for the file to be affected, letting RMS parse the file
12350    * specification for us as well.  I have set errno using only
12351    * values documented in the utime() man page for VMS POSIX.
12352    */
12353   retsts = sys$parse(&myfab,0,0);
12354   if (!(retsts & 1)) {
12355     set_vaxc_errno(retsts);
12356     if      (retsts == RMS$_PRV) set_errno(EACCES);
12357     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
12358     else                         set_errno(EVMSERR);
12359     return -1;
12360   }
12361   retsts = sys$search(&myfab,0,0);
12362   if (!(retsts & 1)) {
12363     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12364     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12365     set_vaxc_errno(retsts);
12366     if      (retsts == RMS$_PRV) set_errno(EACCES);
12367     else if (retsts == RMS$_FNF) set_errno(ENOENT);
12368     else                         set_errno(EVMSERR);
12369     return -1;
12370   }
12371
12372   devdsc.dsc$w_length = mynam.nam$b_dev;
12373   /* cast ok for read only parameter */
12374   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
12375
12376   retsts = sys$assign(&devdsc,&chan,0,0);
12377   if (!(retsts & 1)) {
12378     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12379     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12380     set_vaxc_errno(retsts);
12381     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
12382     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
12383     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
12384     else                               set_errno(EVMSERR);
12385     return -1;
12386   }
12387
12388   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
12389   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
12390
12391   memset((void *) &myfib, 0, sizeof myfib);
12392 #if defined(__DECC) || defined(__DECCXX)
12393   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
12394   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
12395   /* This prevents the revision time of the file being reset to the current
12396    * time as a result of our IO$_MODIFY $QIO. */
12397   myfib.fib$l_acctl = FIB$M_NORECORD;
12398 #else
12399   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
12400   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
12401   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
12402 #endif
12403   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
12404   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12405   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12406   _ckvmssts(sys$dassgn(chan));
12407   if (retsts & 1) retsts = iosb[0];
12408   if (!(retsts & 1)) {
12409     set_vaxc_errno(retsts);
12410     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12411     else                      set_errno(EVMSERR);
12412     return -1;
12413   }
12414
12415   return 0;
12416
12417 #endif /* #if __CRTL_VER >= 70300000 */
12418
12419 }  /* end of my_utime() */
12420 /*}}}*/
12421
12422 /*
12423  * flex_stat, flex_lstat, flex_fstat
12424  * basic stat, but gets it right when asked to stat
12425  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
12426  */
12427
12428 #ifndef _USE_STD_STAT
12429 /* encode_dev packs a VMS device name string into an integer to allow
12430  * simple comparisons. This can be used, for example, to check whether two
12431  * files are located on the same device, by comparing their encoded device
12432  * names. Even a string comparison would not do, because stat() reuses the
12433  * device name buffer for each call; so without encode_dev, it would be
12434  * necessary to save the buffer and use strcmp (this would mean a number of
12435  * changes to the standard Perl code, to say nothing of what a Perl script
12436  * would have to do.
12437  *
12438  * The device lock id, if it exists, should be unique (unless perhaps compared
12439  * with lock ids transferred from other nodes). We have a lock id if the disk is
12440  * mounted cluster-wide, which is when we tend to get long (host-qualified)
12441  * device names. Thus we use the lock id in preference, and only if that isn't
12442  * available, do we try to pack the device name into an integer (flagged by
12443  * the sign bit (LOCKID_MASK) being set).
12444  *
12445  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
12446  * name and its encoded form, but it seems very unlikely that we will find
12447  * two files on different disks that share the same encoded device names,
12448  * and even more remote that they will share the same file id (if the test
12449  * is to check for the same file).
12450  *
12451  * A better method might be to use sys$device_scan on the first call, and to
12452  * search for the device, returning an index into the cached array.
12453  * The number returned would be more intelligible.
12454  * This is probably not worth it, and anyway would take quite a bit longer
12455  * on the first call.
12456  */
12457 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
12458 static mydev_t encode_dev (pTHX_ const char *dev)
12459 {
12460   int i;
12461   unsigned long int f;
12462   mydev_t enc;
12463   char c;
12464   const char *q;
12465
12466   if (!dev || !dev[0]) return 0;
12467
12468 #if LOCKID_MASK
12469   {
12470     struct dsc$descriptor_s dev_desc;
12471     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
12472
12473     /* For cluster-mounted disks, the disk lock identifier is unique, so we
12474        can try that first. */
12475     dev_desc.dsc$w_length =  strlen (dev);
12476     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
12477     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
12478     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
12479     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
12480     if (!$VMS_STATUS_SUCCESS(status)) {
12481       switch (status) {
12482         case SS$_NOSUCHDEV:
12483           SETERRNO(ENODEV, status);
12484           return 0;
12485         default:
12486           _ckvmssts(status);
12487       }
12488     }
12489     if (lockid) return (lockid & ~LOCKID_MASK);
12490   }
12491 #endif
12492
12493   /* Otherwise we try to encode the device name */
12494   enc = 0;
12495   f = 1;
12496   i = 0;
12497   for (q = dev + strlen(dev); q--; q >= dev) {
12498     if (*q == ':')
12499         break;
12500     if (isdigit (*q))
12501       c= (*q) - '0';
12502     else if (isalpha (toupper (*q)))
12503       c= toupper (*q) - 'A' + (char)10;
12504     else
12505       continue; /* Skip '$'s */
12506     i++;
12507     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
12508     if (i>1) f *= 36;
12509     enc += f * (unsigned long int) c;
12510   }
12511   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
12512
12513 }  /* end of encode_dev() */
12514 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12515         device_no = encode_dev(aTHX_ devname)
12516 #else
12517 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12518         device_no = new_dev_no
12519 #endif
12520
12521 static int
12522 is_null_device(name)
12523     const char *name;
12524 {
12525   if (decc_bug_devnull != 0) {
12526     if (strncmp("/dev/null", name, 9) == 0)
12527       return 1;
12528   }
12529     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
12530        The underscore prefix, controller letter, and unit number are
12531        independently optional; for our purposes, the colon punctuation
12532        is not.  The colon can be trailed by optional directory and/or
12533        filename, but two consecutive colons indicates a nodename rather
12534        than a device.  [pr]  */
12535   if (*name == '_') ++name;
12536   if (tolower(*name++) != 'n') return 0;
12537   if (tolower(*name++) != 'l') return 0;
12538   if (tolower(*name) == 'a') ++name;
12539   if (*name == '0') ++name;
12540   return (*name++ == ':') && (*name != ':');
12541 }
12542
12543 static int
12544 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
12545
12546 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
12547
12548 static I32
12549 Perl_cando_by_name_int
12550    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
12551 {
12552   char usrname[L_cuserid];
12553   struct dsc$descriptor_s usrdsc =
12554          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
12555   char *vmsname = NULL, *fileified = NULL;
12556   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
12557   unsigned short int retlen, trnlnm_iter_count;
12558   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12559   union prvdef curprv;
12560   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
12561          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
12562          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
12563   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
12564          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
12565          {0,0,0,0}};
12566   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
12567          {0,0,0,0}};
12568   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12569   Stat_t st;
12570   static int profile_context = -1;
12571
12572   if (!fname || !*fname) return FALSE;
12573
12574   /* Make sure we expand logical names, since sys$check_access doesn't */
12575   fileified = PerlMem_malloc(VMS_MAXRSS);
12576   if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12577   if (!strpbrk(fname,"/]>:")) {
12578       strcpy(fileified,fname);
12579       trnlnm_iter_count = 0;
12580       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
12581         trnlnm_iter_count++;
12582         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
12583       }
12584       fname = fileified;
12585   }
12586
12587   vmsname = PerlMem_malloc(VMS_MAXRSS);
12588   if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12589   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
12590     /* Don't know if already in VMS format, so make sure */
12591     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
12592       PerlMem_free(fileified);
12593       PerlMem_free(vmsname);
12594       return FALSE;
12595     }
12596   }
12597   else {
12598     strcpy(vmsname,fname);
12599   }
12600
12601   /* sys$check_access needs a file spec, not a directory spec.
12602    * flex_stat now will handle a null thread context during startup.
12603    */
12604
12605   retlen = namdsc.dsc$w_length = strlen(vmsname);
12606   if (vmsname[retlen-1] == ']'
12607       || vmsname[retlen-1] == '>'
12608       || vmsname[retlen-1] == ':'
12609       || (!flex_stat_int(vmsname, &st, 1) &&
12610           S_ISDIR(st.st_mode))) {
12611
12612       if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
12613         PerlMem_free(fileified);
12614         PerlMem_free(vmsname);
12615         return FALSE;
12616       }
12617       fname = fileified;
12618   }
12619   else {
12620       fname = vmsname;
12621   }
12622
12623   retlen = namdsc.dsc$w_length = strlen(fname);
12624   namdsc.dsc$a_pointer = (char *)fname;
12625
12626   switch (bit) {
12627     case S_IXUSR: case S_IXGRP: case S_IXOTH:
12628       access = ARM$M_EXECUTE;
12629       flags = CHP$M_READ;
12630       break;
12631     case S_IRUSR: case S_IRGRP: case S_IROTH:
12632       access = ARM$M_READ;
12633       flags = CHP$M_READ | CHP$M_USEREADALL;
12634       break;
12635     case S_IWUSR: case S_IWGRP: case S_IWOTH:
12636       access = ARM$M_WRITE;
12637       flags = CHP$M_READ | CHP$M_WRITE;
12638       break;
12639     case S_IDUSR: case S_IDGRP: case S_IDOTH:
12640       access = ARM$M_DELETE;
12641       flags = CHP$M_READ | CHP$M_WRITE;
12642       break;
12643     default:
12644       if (fileified != NULL)
12645         PerlMem_free(fileified);
12646       if (vmsname != NULL)
12647         PerlMem_free(vmsname);
12648       return FALSE;
12649   }
12650
12651   /* Before we call $check_access, create a user profile with the current
12652    * process privs since otherwise it just uses the default privs from the
12653    * UAF and might give false positives or negatives.  This only works on
12654    * VMS versions v6.0 and later since that's when sys$create_user_profile
12655    * became available.
12656    */
12657
12658   /* get current process privs and username */
12659   _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
12660   _ckvmssts_noperl(iosb[0]);
12661
12662 #if defined(__VMS_VER) && __VMS_VER >= 60000000
12663
12664   /* find out the space required for the profile */
12665   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
12666                                     &usrprodsc.dsc$w_length,&profile_context));
12667
12668   /* allocate space for the profile and get it filled in */
12669   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
12670   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12671   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
12672                                     &usrprodsc.dsc$w_length,&profile_context));
12673
12674   /* use the profile to check access to the file; free profile & analyze results */
12675   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
12676   PerlMem_free(usrprodsc.dsc$a_pointer);
12677   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
12678
12679 #else
12680
12681   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
12682
12683 #endif
12684
12685   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
12686       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
12687       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
12688     set_vaxc_errno(retsts);
12689     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12690     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12691     else set_errno(ENOENT);
12692     if (fileified != NULL)
12693       PerlMem_free(fileified);
12694     if (vmsname != NULL)
12695       PerlMem_free(vmsname);
12696     return FALSE;
12697   }
12698   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12699     if (fileified != NULL)
12700       PerlMem_free(fileified);
12701     if (vmsname != NULL)
12702       PerlMem_free(vmsname);
12703     return TRUE;
12704   }
12705   _ckvmssts_noperl(retsts);
12706
12707   if (fileified != NULL)
12708     PerlMem_free(fileified);
12709   if (vmsname != NULL)
12710     PerlMem_free(vmsname);
12711   return FALSE;  /* Should never get here */
12712
12713 }
12714
12715 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
12716 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12717  * subset of the applicable information.
12718  */
12719 bool
12720 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12721 {
12722   return cando_by_name_int
12723         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12724 }  /* end of cando() */
12725 /*}}}*/
12726
12727
12728 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12729 I32
12730 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12731 {
12732    return cando_by_name_int(bit, effective, fname, 0);
12733
12734 }  /* end of cando_by_name() */
12735 /*}}}*/
12736
12737
12738 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12739 int
12740 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12741 {
12742   if (!fstat(fd, &statbufp->crtl_stat)) {
12743     char *cptr;
12744     char *vms_filename;
12745     vms_filename = PerlMem_malloc(VMS_MAXRSS);
12746     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12747
12748     /* Save name for cando by name in VMS format */
12749     cptr = getname(fd, vms_filename, 1);
12750
12751     /* This should not happen, but just in case */
12752     if (cptr == NULL) {
12753         statbufp->st_devnam[0] = 0;
12754     }
12755     else {
12756         /* Make sure that the saved name fits in 255 characters */
12757         cptr = int_rmsexpand_vms
12758                        (vms_filename,
12759                         statbufp->st_devnam,
12760                         0);
12761         if (cptr == NULL)
12762             statbufp->st_devnam[0] = 0;
12763     }
12764     PerlMem_free(vms_filename);
12765
12766     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12767     VMS_DEVICE_ENCODE
12768         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12769
12770 #   ifdef RTL_USES_UTC
12771 #   ifdef VMSISH_TIME
12772     if (VMSISH_TIME) {
12773       statbufp->st_mtime = _toloc(statbufp->st_mtime);
12774       statbufp->st_atime = _toloc(statbufp->st_atime);
12775       statbufp->st_ctime = _toloc(statbufp->st_ctime);
12776     }
12777 #   endif
12778 #   else
12779 #   ifdef VMSISH_TIME
12780     if (!VMSISH_TIME) { /* Return UTC instead of local time */
12781 #   else
12782     if (1) {
12783 #   endif
12784       statbufp->st_mtime = _toutc(statbufp->st_mtime);
12785       statbufp->st_atime = _toutc(statbufp->st_atime);
12786       statbufp->st_ctime = _toutc(statbufp->st_ctime);
12787     }
12788 #endif
12789     return 0;
12790   }
12791   return -1;
12792
12793 }  /* end of flex_fstat() */
12794 /*}}}*/
12795
12796 static int
12797 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12798 {
12799     char *fileified;
12800     char *temp_fspec;
12801     const char *save_spec;
12802     char *ret_spec;
12803     int retval = -1;
12804     int efs_hack = 0;
12805     dSAVEDERRNO;
12806
12807     if (!fspec) {
12808         errno = EINVAL;
12809         return retval;
12810     }
12811
12812     if (decc_bug_devnull != 0) {
12813       if (is_null_device(fspec)) { /* Fake a stat() for the null device */
12814         memset(statbufp,0,sizeof *statbufp);
12815         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12816         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12817         statbufp->st_uid = 0x00010001;
12818         statbufp->st_gid = 0x0001;
12819         time((time_t *)&statbufp->st_mtime);
12820         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12821         return 0;
12822       }
12823     }
12824
12825     /* Try for a directory name first.  If fspec contains a filename without
12826      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12827      * and sea:[wine.dark]water. exist, we prefer the directory here.
12828      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12829      * not sea:[wine.dark]., if the latter exists.  If the intended target is
12830      * the file with null type, specify this by calling flex_stat() with
12831      * a '.' at the end of fspec.
12832      *
12833      * If we are in Posix filespec mode, accept the filename as is.
12834      */
12835
12836
12837     fileified = PerlMem_malloc(VMS_MAXRSS);
12838     if (fileified == NULL)
12839         _ckvmssts_noperl(SS$_INSFMEM);
12840
12841     temp_fspec = PerlMem_malloc(VMS_MAXRSS);
12842     if (temp_fspec == NULL)
12843         _ckvmssts_noperl(SS$_INSFMEM);
12844
12845     strcpy(temp_fspec, fspec);
12846
12847     SAVE_ERRNO;
12848
12849 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12850   if (decc_posix_compliant_pathnames == 0) {
12851 #endif
12852
12853     /* We may be able to optimize this, but in order for fileify_dirspec to
12854      * always return a usuable answer, we have to call vmspath first to
12855      * make sure that it is in VMS directory format, as stat/lstat on 8.3
12856      * can not handle directories in unix format that it does not have read
12857      * access to.  Vmspath handles the case where a bare name which could be
12858      * a logical name gets passed.
12859      */
12860     ret_spec = int_tovmspath(fspec, temp_fspec, NULL);
12861     if (ret_spec != NULL) {
12862         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
12863         if (ret_spec != NULL) {
12864             if (lstat_flag == 0)
12865                 retval = stat(fileified, &statbufp->crtl_stat);
12866             else
12867                 retval = lstat(fileified, &statbufp->crtl_stat);
12868             save_spec = fileified;
12869         }
12870     }
12871
12872     if (retval && vms_bug_stat_filename) {
12873
12874         /* We should try again as a vmsified file specification */
12875         /* However Perl traditionally has not done this, which  */
12876         /* causes problems with existing tests */
12877
12878         ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12879         if (ret_spec != NULL) {
12880             if (lstat_flag == 0)
12881                 retval = stat(temp_fspec, &statbufp->crtl_stat);
12882             else
12883                 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12884             save_spec = temp_fspec;
12885         }
12886     }
12887
12888     if (retval) {
12889         /* Last chance - allow multiple dots with out EFS CHARSET */
12890         /* The CRTL stat() falls down hard on multi-dot filenames in unix
12891          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12892          * enable it if it isn't already.
12893          */
12894 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12895         if (!decc_efs_charset && (decc_efs_charset_index > 0))
12896             decc$feature_set_value(decc_efs_charset_index, 1, 1);
12897 #endif
12898         if (lstat_flag == 0)
12899             retval = stat(fspec, &statbufp->crtl_stat);
12900         else
12901             retval = lstat(fspec, &statbufp->crtl_stat);
12902         save_spec = fspec;
12903 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12904         if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
12905             decc$feature_set_value(decc_efs_charset_index, 1, 0);
12906             efs_hack = 1;
12907         }
12908 #endif
12909     }
12910
12911 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12912   } else {
12913     if (lstat_flag == 0)
12914       retval = stat(temp_fspec, &statbufp->crtl_stat);
12915     else
12916       retval = lstat(temp_fspec, &statbufp->crtl_stat);
12917       save_spec = temp_fspec;
12918   }
12919 #endif
12920
12921 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12922   /* As you were... */
12923   if (!decc_efs_charset)
12924     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12925 #endif
12926
12927     if (!retval) {
12928     char * cptr;
12929     int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12930
12931       /* If this is an lstat, do not follow the link */
12932       if (lstat_flag)
12933         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12934
12935 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12936       /* If we used the efs_hack above, we must also use it here for */
12937       /* perl_cando to work */
12938       if (efs_hack && (decc_efs_charset_index > 0)) {
12939           decc$feature_set_value(decc_efs_charset_index, 1, 1);
12940       }
12941 #endif
12942       cptr = int_rmsexpand_tovms(save_spec, statbufp->st_devnam, rmsex_flags);
12943 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12944       if (efs_hack && (decc_efs_charset_index > 0)) {
12945           decc$feature_set_value(decc_efs_charset, 1, 0);
12946       }
12947 #endif
12948
12949       /* Fix me: If this is NULL then stat found a file, and we could */
12950       /* not convert the specification to VMS - Should never happen */
12951       if (cptr == NULL)
12952         statbufp->st_devnam[0] = 0;
12953
12954       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12955       VMS_DEVICE_ENCODE
12956         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12957 #     ifdef RTL_USES_UTC
12958 #     ifdef VMSISH_TIME
12959       if (VMSISH_TIME) {
12960         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12961         statbufp->st_atime = _toloc(statbufp->st_atime);
12962         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12963       }
12964 #     endif
12965 #     else
12966 #     ifdef VMSISH_TIME
12967       if (!VMSISH_TIME) { /* Return UTC instead of local time */
12968 #     else
12969       if (1) {
12970 #     endif
12971         statbufp->st_mtime = _toutc(statbufp->st_mtime);
12972         statbufp->st_atime = _toutc(statbufp->st_atime);
12973         statbufp->st_ctime = _toutc(statbufp->st_ctime);
12974       }
12975 #     endif
12976     }
12977     /* If we were successful, leave errno where we found it */
12978     if (retval == 0) RESTORE_ERRNO;
12979     return retval;
12980
12981 }  /* end of flex_stat_int() */
12982
12983
12984 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12985 int
12986 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12987 {
12988    return flex_stat_int(fspec, statbufp, 0);
12989 }
12990 /*}}}*/
12991
12992 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12993 int
12994 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12995 {
12996    return flex_stat_int(fspec, statbufp, 1);
12997 }
12998 /*}}}*/
12999
13000
13001 /*{{{char *my_getlogin()*/
13002 /* VMS cuserid == Unix getlogin, except calling sequence */
13003 char *
13004 my_getlogin(void)
13005 {
13006     static char user[L_cuserid];
13007     return cuserid(user);
13008 }
13009 /*}}}*/
13010
13011
13012 /*  rmscopy - copy a file using VMS RMS routines
13013  *
13014  *  Copies contents and attributes of spec_in to spec_out, except owner
13015  *  and protection information.  Name and type of spec_in are used as
13016  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
13017  *  should try to propagate timestamps from the input file to the output file.
13018  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
13019  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
13020  *  propagated to the output file at creation iff the output file specification
13021  *  did not contain an explicit name or type, and the revision date is always
13022  *  updated at the end of the copy operation.  If it is greater than 0, then
13023  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
13024  *  other than the revision date should be propagated, and bit 1 indicates
13025  *  that the revision date should be propagated.
13026  *
13027  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
13028  *
13029  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
13030  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
13031  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
13032  * as part of the Perl standard distribution under the terms of the
13033  * GNU General Public License or the Perl Artistic License.  Copies
13034  * of each may be found in the Perl standard distribution.
13035  */ /* FIXME */
13036 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
13037 int
13038 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
13039 {
13040     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
13041          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
13042     unsigned long int i, sts, sts2;
13043     int dna_len;
13044     struct FAB fab_in, fab_out;
13045     struct RAB rab_in, rab_out;
13046     rms_setup_nam(nam);
13047     rms_setup_nam(nam_out);
13048     struct XABDAT xabdat;
13049     struct XABFHC xabfhc;
13050     struct XABRDT xabrdt;
13051     struct XABSUM xabsum;
13052
13053     vmsin = PerlMem_malloc(VMS_MAXRSS);
13054     if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13055     vmsout = PerlMem_malloc(VMS_MAXRSS);
13056     if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13057     if (!spec_in  || !*spec_in  || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
13058         !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
13059       PerlMem_free(vmsin);
13060       PerlMem_free(vmsout);
13061       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13062       return 0;
13063     }
13064
13065     esa = PerlMem_malloc(VMS_MAXRSS);
13066     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13067     esal = NULL;
13068 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
13069     esal = PerlMem_malloc(VMS_MAXRSS);
13070     if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13071 #endif
13072     fab_in = cc$rms_fab;
13073     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
13074     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
13075     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
13076     fab_in.fab$l_fop = FAB$M_SQO;
13077     rms_bind_fab_nam(fab_in, nam);
13078     fab_in.fab$l_xab = (void *) &xabdat;
13079
13080     rsa = PerlMem_malloc(VMS_MAXRSS);
13081     if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13082     rsal = NULL;
13083 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
13084     rsal = PerlMem_malloc(VMS_MAXRSS);
13085     if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13086 #endif
13087     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
13088     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
13089     rms_nam_esl(nam) = 0;
13090     rms_nam_rsl(nam) = 0;
13091     rms_nam_esll(nam) = 0;
13092     rms_nam_rsll(nam) = 0;
13093 #ifdef NAM$M_NO_SHORT_UPCASE
13094     if (decc_efs_case_preserve)
13095         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
13096 #endif
13097
13098     xabdat = cc$rms_xabdat;        /* To get creation date */
13099     xabdat.xab$l_nxt = (void *) &xabfhc;
13100
13101     xabfhc = cc$rms_xabfhc;        /* To get record length */
13102     xabfhc.xab$l_nxt = (void *) &xabsum;
13103
13104     xabsum = cc$rms_xabsum;        /* To get key and area information */
13105
13106     if (!((sts = sys$open(&fab_in)) & 1)) {
13107       PerlMem_free(vmsin);
13108       PerlMem_free(vmsout);
13109       PerlMem_free(esa);
13110       if (esal != NULL)
13111         PerlMem_free(esal);
13112       PerlMem_free(rsa);
13113       if (rsal != NULL)
13114         PerlMem_free(rsal);
13115       set_vaxc_errno(sts);
13116       switch (sts) {
13117         case RMS$_FNF: case RMS$_DNF:
13118           set_errno(ENOENT); break;
13119         case RMS$_DIR:
13120           set_errno(ENOTDIR); break;
13121         case RMS$_DEV:
13122           set_errno(ENODEV); break;
13123         case RMS$_SYN:
13124           set_errno(EINVAL); break;
13125         case RMS$_PRV:
13126           set_errno(EACCES); break;
13127         default:
13128           set_errno(EVMSERR);
13129       }
13130       return 0;
13131     }
13132
13133     nam_out = nam;
13134     fab_out = fab_in;
13135     fab_out.fab$w_ifi = 0;
13136     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
13137     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
13138     fab_out.fab$l_fop = FAB$M_SQO;
13139     rms_bind_fab_nam(fab_out, nam_out);
13140     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
13141     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
13142     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
13143     esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
13144     if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13145     rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
13146     if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13147     esal_out = NULL;
13148     rsal_out = NULL;
13149 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
13150     esal_out = PerlMem_malloc(VMS_MAXRSS);
13151     if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13152     rsal_out = PerlMem_malloc(VMS_MAXRSS);
13153     if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13154 #endif
13155     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
13156     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
13157
13158     if (preserve_dates == 0) {  /* Act like DCL COPY */
13159       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
13160       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
13161       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
13162         PerlMem_free(vmsin);
13163         PerlMem_free(vmsout);
13164         PerlMem_free(esa);
13165         if (esal != NULL)
13166             PerlMem_free(esal);
13167         PerlMem_free(rsa);
13168         if (rsal != NULL)
13169             PerlMem_free(rsal);
13170         PerlMem_free(esa_out);
13171         if (esal_out != NULL)
13172             PerlMem_free(esal_out);
13173         PerlMem_free(rsa_out);
13174         if (rsal_out != NULL)
13175             PerlMem_free(rsal_out);
13176         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
13177         set_vaxc_errno(sts);
13178         return 0;
13179       }
13180       fab_out.fab$l_xab = (void *) &xabdat;
13181       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
13182         preserve_dates = 1;
13183     }
13184     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
13185       preserve_dates =0;      /* bitmask from this point forward   */
13186
13187     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
13188     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
13189       PerlMem_free(vmsin);
13190       PerlMem_free(vmsout);
13191       PerlMem_free(esa);
13192       if (esal != NULL)
13193           PerlMem_free(esal);
13194       PerlMem_free(rsa);
13195       if (rsal != NULL)
13196           PerlMem_free(rsal);
13197       PerlMem_free(esa_out);
13198       if (esal_out != NULL)
13199           PerlMem_free(esal_out);
13200       PerlMem_free(rsa_out);
13201       if (rsal_out != NULL)
13202           PerlMem_free(rsal_out);
13203       set_vaxc_errno(sts);
13204       switch (sts) {
13205         case RMS$_DNF:
13206           set_errno(ENOENT); break;
13207         case RMS$_DIR:
13208           set_errno(ENOTDIR); break;
13209         case RMS$_DEV:
13210           set_errno(ENODEV); break;
13211         case RMS$_SYN:
13212           set_errno(EINVAL); break;
13213         case RMS$_PRV:
13214           set_errno(EACCES); break;
13215         default:
13216           set_errno(EVMSERR);
13217       }
13218       return 0;
13219     }
13220     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
13221     if (preserve_dates & 2) {
13222       /* sys$close() will process xabrdt, not xabdat */
13223       xabrdt = cc$rms_xabrdt;
13224 #ifndef __GNUC__
13225       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
13226 #else
13227       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
13228        * is unsigned long[2], while DECC & VAXC use a struct */
13229       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
13230 #endif
13231       fab_out.fab$l_xab = (void *) &xabrdt;
13232     }
13233
13234     ubf = PerlMem_malloc(32256);
13235     if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13236     rab_in = cc$rms_rab;
13237     rab_in.rab$l_fab = &fab_in;
13238     rab_in.rab$l_rop = RAB$M_BIO;
13239     rab_in.rab$l_ubf = ubf;
13240     rab_in.rab$w_usz = 32256;
13241     if (!((sts = sys$connect(&rab_in)) & 1)) {
13242       sys$close(&fab_in); sys$close(&fab_out);
13243       PerlMem_free(vmsin);
13244       PerlMem_free(vmsout);
13245       PerlMem_free(ubf);
13246       PerlMem_free(esa);
13247       if (esal != NULL)
13248           PerlMem_free(esal);
13249       PerlMem_free(rsa);
13250       if (rsal != NULL)
13251           PerlMem_free(rsal);
13252       PerlMem_free(esa_out);
13253       if (esal_out != NULL)
13254           PerlMem_free(esal_out);
13255       PerlMem_free(rsa_out);
13256       if (rsal_out != NULL)
13257           PerlMem_free(rsal_out);
13258       set_errno(EVMSERR); set_vaxc_errno(sts);
13259       return 0;
13260     }
13261
13262     rab_out = cc$rms_rab;
13263     rab_out.rab$l_fab = &fab_out;
13264     rab_out.rab$l_rbf = ubf;
13265     if (!((sts = sys$connect(&rab_out)) & 1)) {
13266       sys$close(&fab_in); sys$close(&fab_out);
13267       PerlMem_free(vmsin);
13268       PerlMem_free(vmsout);
13269       PerlMem_free(ubf);
13270       PerlMem_free(esa);
13271       if (esal != NULL)
13272           PerlMem_free(esal);
13273       PerlMem_free(rsa);
13274       if (rsal != NULL)
13275           PerlMem_free(rsal);
13276       PerlMem_free(esa_out);
13277       if (esal_out != NULL)
13278           PerlMem_free(esal_out);
13279       PerlMem_free(rsa_out);
13280       if (rsal_out != NULL)
13281           PerlMem_free(rsal_out);
13282       set_errno(EVMSERR); set_vaxc_errno(sts);
13283       return 0;
13284     }
13285
13286     while ((sts = sys$read(&rab_in))) {  /* always true  */
13287       if (sts == RMS$_EOF) break;
13288       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
13289       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
13290         sys$close(&fab_in); sys$close(&fab_out);
13291         PerlMem_free(vmsin);
13292         PerlMem_free(vmsout);
13293         PerlMem_free(ubf);
13294         PerlMem_free(esa);
13295         if (esal != NULL)
13296             PerlMem_free(esal);
13297         PerlMem_free(rsa);
13298         if (rsal != NULL)
13299             PerlMem_free(rsal);
13300         PerlMem_free(esa_out);
13301         if (esal_out != NULL)
13302             PerlMem_free(esal_out);
13303         PerlMem_free(rsa_out);
13304         if (rsal_out != NULL)
13305             PerlMem_free(rsal_out);
13306         set_errno(EVMSERR); set_vaxc_errno(sts);
13307         return 0;
13308       }
13309     }
13310
13311
13312     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
13313     sys$close(&fab_in);  sys$close(&fab_out);
13314     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
13315
13316     PerlMem_free(vmsin);
13317     PerlMem_free(vmsout);
13318     PerlMem_free(ubf);
13319     PerlMem_free(esa);
13320     if (esal != NULL)
13321         PerlMem_free(esal);
13322     PerlMem_free(rsa);
13323     if (rsal != NULL)
13324         PerlMem_free(rsal);
13325     PerlMem_free(esa_out);
13326     if (esal_out != NULL)
13327         PerlMem_free(esal_out);
13328     PerlMem_free(rsa_out);
13329     if (rsal_out != NULL)
13330         PerlMem_free(rsal_out);
13331
13332     if (!(sts & 1)) {
13333       set_errno(EVMSERR); set_vaxc_errno(sts);
13334       return 0;
13335     }
13336
13337     return 1;
13338
13339 }  /* end of rmscopy() */
13340 /*}}}*/
13341
13342
13343 /***  The following glue provides 'hooks' to make some of the routines
13344  * from this file available from Perl.  These routines are sufficiently
13345  * basic, and are required sufficiently early in the build process,
13346  * that's it's nice to have them available to miniperl as well as the
13347  * full Perl, so they're set up here instead of in an extension.  The
13348  * Perl code which handles importation of these names into a given
13349  * package lives in [.VMS]Filespec.pm in @INC.
13350  */
13351
13352 void
13353 rmsexpand_fromperl(pTHX_ CV *cv)
13354 {
13355   dXSARGS;
13356   char *fspec, *defspec = NULL, *rslt;
13357   STRLEN n_a;
13358   int fs_utf8, dfs_utf8;
13359
13360   fs_utf8 = 0;
13361   dfs_utf8 = 0;
13362   if (!items || items > 2)
13363     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
13364   fspec = SvPV(ST(0),n_a);
13365   fs_utf8 = SvUTF8(ST(0));
13366   if (!fspec || !*fspec) XSRETURN_UNDEF;
13367   if (items == 2) {
13368     defspec = SvPV(ST(1),n_a);
13369     dfs_utf8 = SvUTF8(ST(1));
13370   }
13371   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
13372   ST(0) = sv_newmortal();
13373   if (rslt != NULL) {
13374     sv_usepvn(ST(0),rslt,strlen(rslt));
13375     if (fs_utf8) {
13376         SvUTF8_on(ST(0));
13377     }
13378   }
13379   XSRETURN(1);
13380 }
13381
13382 void
13383 vmsify_fromperl(pTHX_ CV *cv)
13384 {
13385   dXSARGS;
13386   char *vmsified;
13387   STRLEN n_a;
13388   int utf8_fl;
13389
13390   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
13391   utf8_fl = SvUTF8(ST(0));
13392   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13393   ST(0) = sv_newmortal();
13394   if (vmsified != NULL) {
13395     sv_usepvn(ST(0),vmsified,strlen(vmsified));
13396     if (utf8_fl) {
13397         SvUTF8_on(ST(0));
13398     }
13399   }
13400   XSRETURN(1);
13401 }
13402
13403 void
13404 unixify_fromperl(pTHX_ CV *cv)
13405 {
13406   dXSARGS;
13407   char *unixified;
13408   STRLEN n_a;
13409   int utf8_fl;
13410
13411   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
13412   utf8_fl = SvUTF8(ST(0));
13413   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13414   ST(0) = sv_newmortal();
13415   if (unixified != NULL) {
13416     sv_usepvn(ST(0),unixified,strlen(unixified));
13417     if (utf8_fl) {
13418         SvUTF8_on(ST(0));
13419     }
13420   }
13421   XSRETURN(1);
13422 }
13423
13424 void
13425 fileify_fromperl(pTHX_ CV *cv)
13426 {
13427   dXSARGS;
13428   char *fileified;
13429   STRLEN n_a;
13430   int utf8_fl;
13431
13432   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
13433   utf8_fl = SvUTF8(ST(0));
13434   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13435   ST(0) = sv_newmortal();
13436   if (fileified != NULL) {
13437     sv_usepvn(ST(0),fileified,strlen(fileified));
13438     if (utf8_fl) {
13439         SvUTF8_on(ST(0));
13440     }
13441   }
13442   XSRETURN(1);
13443 }
13444
13445 void
13446 pathify_fromperl(pTHX_ CV *cv)
13447 {
13448   dXSARGS;
13449   char *pathified;
13450   STRLEN n_a;
13451   int utf8_fl;
13452
13453   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
13454   utf8_fl = SvUTF8(ST(0));
13455   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13456   ST(0) = sv_newmortal();
13457   if (pathified != NULL) {
13458     sv_usepvn(ST(0),pathified,strlen(pathified));
13459     if (utf8_fl) {
13460         SvUTF8_on(ST(0));
13461     }
13462   }
13463   XSRETURN(1);
13464 }
13465
13466 void
13467 vmspath_fromperl(pTHX_ CV *cv)
13468 {
13469   dXSARGS;
13470   char *vmspath;
13471   STRLEN n_a;
13472   int utf8_fl;
13473
13474   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
13475   utf8_fl = SvUTF8(ST(0));
13476   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13477   ST(0) = sv_newmortal();
13478   if (vmspath != NULL) {
13479     sv_usepvn(ST(0),vmspath,strlen(vmspath));
13480     if (utf8_fl) {
13481         SvUTF8_on(ST(0));
13482     }
13483   }
13484   XSRETURN(1);
13485 }
13486
13487 void
13488 unixpath_fromperl(pTHX_ CV *cv)
13489 {
13490   dXSARGS;
13491   char *unixpath;
13492   STRLEN n_a;
13493   int utf8_fl;
13494
13495   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
13496   utf8_fl = SvUTF8(ST(0));
13497   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13498   ST(0) = sv_newmortal();
13499   if (unixpath != NULL) {
13500     sv_usepvn(ST(0),unixpath,strlen(unixpath));
13501     if (utf8_fl) {
13502         SvUTF8_on(ST(0));
13503     }
13504   }
13505   XSRETURN(1);
13506 }
13507
13508 void
13509 candelete_fromperl(pTHX_ CV *cv)
13510 {
13511   dXSARGS;
13512   char *fspec, *fsp;
13513   SV *mysv;
13514   IO *io;
13515   STRLEN n_a;
13516
13517   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
13518
13519   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13520   Newx(fspec, VMS_MAXRSS, char);
13521   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
13522   if (SvTYPE(mysv) == SVt_PVGV) {
13523     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
13524       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13525       ST(0) = &PL_sv_no;
13526       Safefree(fspec);
13527       XSRETURN(1);
13528     }
13529     fsp = fspec;
13530   }
13531   else {
13532     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
13533       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13534       ST(0) = &PL_sv_no;
13535       Safefree(fspec);
13536       XSRETURN(1);
13537     }
13538   }
13539
13540   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
13541   Safefree(fspec);
13542   XSRETURN(1);
13543 }
13544
13545 void
13546 rmscopy_fromperl(pTHX_ CV *cv)
13547 {
13548   dXSARGS;
13549   char *inspec, *outspec, *inp, *outp;
13550   int date_flag;
13551   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
13552                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13553   unsigned long int sts;
13554   SV *mysv;
13555   IO *io;
13556   STRLEN n_a;
13557
13558   if (items < 2 || items > 3)
13559     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
13560
13561   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13562   Newx(inspec, VMS_MAXRSS, char);
13563   if (SvTYPE(mysv) == SVt_PVGV) {
13564     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
13565       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13566       ST(0) = &PL_sv_no;
13567       Safefree(inspec);
13568       XSRETURN(1);
13569     }
13570     inp = inspec;
13571   }
13572   else {
13573     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
13574       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13575       ST(0) = &PL_sv_no;
13576       Safefree(inspec);
13577       XSRETURN(1);
13578     }
13579   }
13580   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
13581   Newx(outspec, VMS_MAXRSS, char);
13582   if (SvTYPE(mysv) == SVt_PVGV) {
13583     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
13584       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13585       ST(0) = &PL_sv_no;
13586       Safefree(inspec);
13587       Safefree(outspec);
13588       XSRETURN(1);
13589     }
13590     outp = outspec;
13591   }
13592   else {
13593     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
13594       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13595       ST(0) = &PL_sv_no;
13596       Safefree(inspec);
13597       Safefree(outspec);
13598       XSRETURN(1);
13599     }
13600   }
13601   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
13602
13603   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
13604   Safefree(inspec);
13605   Safefree(outspec);
13606   XSRETURN(1);
13607 }
13608
13609 /* The mod2fname is limited to shorter filenames by design, so it should
13610  * not be modified to support longer EFS pathnames
13611  */
13612 void
13613 mod2fname(pTHX_ CV *cv)
13614 {
13615   dXSARGS;
13616   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
13617        workbuff[NAM$C_MAXRSS*1 + 1];
13618   int total_namelen = 3, counter, num_entries;
13619   /* ODS-5 ups this, but we want to be consistent, so... */
13620   int max_name_len = 39;
13621   AV *in_array = (AV *)SvRV(ST(0));
13622
13623   num_entries = av_len(in_array);
13624
13625   /* All the names start with PL_. */
13626   strcpy(ultimate_name, "PL_");
13627
13628   /* Clean up our working buffer */
13629   Zero(work_name, sizeof(work_name), char);
13630
13631   /* Run through the entries and build up a working name */
13632   for(counter = 0; counter <= num_entries; counter++) {
13633     /* If it's not the first name then tack on a __ */
13634     if (counter) {
13635       strcat(work_name, "__");
13636     }
13637     strcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)));
13638   }
13639
13640   /* Check to see if we actually have to bother...*/
13641   if (strlen(work_name) + 3 <= max_name_len) {
13642     strcat(ultimate_name, work_name);
13643   } else {
13644     /* It's too darned big, so we need to go strip. We use the same */
13645     /* algorithm as xsubpp does. First, strip out doubled __ */
13646     char *source, *dest, last;
13647     dest = workbuff;
13648     last = 0;
13649     for (source = work_name; *source; source++) {
13650       if (last == *source && last == '_') {
13651         continue;
13652       }
13653       *dest++ = *source;
13654       last = *source;
13655     }
13656     /* Go put it back */
13657     strcpy(work_name, workbuff);
13658     /* Is it still too big? */
13659     if (strlen(work_name) + 3 > max_name_len) {
13660       /* Strip duplicate letters */
13661       last = 0;
13662       dest = workbuff;
13663       for (source = work_name; *source; source++) {
13664         if (last == toupper(*source)) {
13665         continue;
13666         }
13667         *dest++ = *source;
13668         last = toupper(*source);
13669       }
13670       strcpy(work_name, workbuff);
13671     }
13672
13673     /* Is it *still* too big? */
13674     if (strlen(work_name) + 3 > max_name_len) {
13675       /* Too bad, we truncate */
13676       work_name[max_name_len - 2] = 0;
13677     }
13678     strcat(ultimate_name, work_name);
13679   }
13680
13681   /* Okay, return it */
13682   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
13683   XSRETURN(1);
13684 }
13685
13686 void
13687 hushexit_fromperl(pTHX_ CV *cv)
13688 {
13689     dXSARGS;
13690
13691     if (items > 0) {
13692         VMSISH_HUSHED = SvTRUE(ST(0));
13693     }
13694     ST(0) = boolSV(VMSISH_HUSHED);
13695     XSRETURN(1);
13696 }
13697
13698
13699 PerlIO *
13700 Perl_vms_start_glob
13701    (pTHX_ SV *tmpglob,
13702     IO *io)
13703 {
13704     PerlIO *fp;
13705     struct vs_str_st *rslt;
13706     char *vmsspec;
13707     char *rstr;
13708     char *begin, *cp;
13709     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13710     PerlIO *tmpfp;
13711     STRLEN i;
13712     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13713     struct dsc$descriptor_vs rsdsc;
13714     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13715     unsigned long hasver = 0, isunix = 0;
13716     unsigned long int lff_flags = 0;
13717     int rms_sts;
13718     int vms_old_glob = 1;
13719
13720     if (!SvOK(tmpglob)) {
13721         SETERRNO(ENOENT,RMS$_FNF);
13722         return NULL;
13723     }
13724
13725     vms_old_glob = !decc_filename_unix_report;
13726
13727 #ifdef VMS_LONGNAME_SUPPORT
13728     lff_flags = LIB$M_FIL_LONG_NAMES;
13729 #endif
13730     /* The Newx macro will not allow me to assign a smaller array
13731      * to the rslt pointer, so we will assign it to the begin char pointer
13732      * and then copy the value into the rslt pointer.
13733      */
13734     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13735     rslt = (struct vs_str_st *)begin;
13736     rslt->length = 0;
13737     rstr = &rslt->str[0];
13738     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13739     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13740     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13741     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13742
13743     Newx(vmsspec, VMS_MAXRSS, char);
13744
13745         /* We could find out if there's an explicit dev/dir or version
13746            by peeking into lib$find_file's internal context at
13747            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13748            but that's unsupported, so I don't want to do it now and
13749            have it bite someone in the future. */
13750         /* Fix-me: vms_split_path() is the only way to do this, the
13751            existing method will fail with many legal EFS or UNIX specifications
13752          */
13753
13754     cp = SvPV(tmpglob,i);
13755
13756     for (; i; i--) {
13757         if (cp[i] == ';') hasver = 1;
13758         if (cp[i] == '.') {
13759             if (sts) hasver = 1;
13760             else sts = 1;
13761         }
13762         if (cp[i] == '/') {
13763             hasdir = isunix = 1;
13764             break;
13765         }
13766         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13767             hasdir = 1;
13768             break;
13769         }
13770     }
13771
13772     /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13773     if ((hasdir == 0) && decc_filename_unix_report) {
13774         isunix = 1;
13775     }
13776
13777     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13778         char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13779         int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13780         int wildstar = 0;
13781         int wildquery = 0;
13782         int found = 0;
13783         Stat_t st;
13784         int stat_sts;
13785         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13786         if (!stat_sts && S_ISDIR(st.st_mode)) {
13787             char * vms_dir;
13788             const char * fname;
13789             STRLEN fname_len;
13790
13791             /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13792             /* path delimiter of ':>]', if so, then the old behavior has */
13793             /* obviously been specificially requested */
13794
13795             fname = SvPVX_const(tmpglob);
13796             fname_len = strlen(fname);
13797             vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13798             if (vms_old_glob || (vms_dir != NULL)) {
13799                 wilddsc.dsc$a_pointer = tovmspath_utf8(
13800                                             SvPVX(tmpglob),vmsspec,NULL);
13801                 ok = (wilddsc.dsc$a_pointer != NULL);
13802                 /* maybe passed 'foo' rather than '[.foo]', thus not
13803                    detected above */
13804                 hasdir = 1;
13805             } else {
13806                 /* Operate just on the directory, the special stat/fstat for */
13807                 /* leaves the fileified  specification in the st_devnam */
13808                 /* member. */
13809                 wilddsc.dsc$a_pointer = st.st_devnam;
13810                 ok = 1;
13811             }
13812         }
13813         else {
13814             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13815             ok = (wilddsc.dsc$a_pointer != NULL);
13816         }
13817         if (ok)
13818             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13819
13820         /* If not extended character set, replace ? with % */
13821         /* With extended character set, ? is a wildcard single character */
13822         for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13823             if (*cp == '?') {
13824                 wildquery = 1;
13825                 if (!decc_efs_case_preserve)
13826                     *cp = '%';
13827             } else if (*cp == '%') {
13828                 wildquery = 1;
13829             } else if (*cp == '*') {
13830                 wildstar = 1;
13831             }
13832         }
13833
13834         if (ok) {
13835             wv_sts = vms_split_path(
13836                 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13837                 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13838                 &wvs_spec, &wvs_len);
13839         } else {
13840             wn_spec = NULL;
13841             wn_len = 0;
13842             we_spec = NULL;
13843             we_len = 0;
13844         }
13845
13846         sts = SS$_NORMAL;
13847         while (ok && $VMS_STATUS_SUCCESS(sts)) {
13848          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13849          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13850          int valid_find;
13851
13852             valid_find = 0;
13853             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13854                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
13855             if (!$VMS_STATUS_SUCCESS(sts))
13856                 break;
13857
13858             /* with varying string, 1st word of buffer contains result length */
13859             rstr[rslt->length] = '\0';
13860
13861              /* Find where all the components are */
13862              v_sts = vms_split_path
13863                        (rstr,
13864                         &v_spec,
13865                         &v_len,
13866                         &r_spec,
13867                         &r_len,
13868                         &d_spec,
13869                         &d_len,
13870                         &n_spec,
13871                         &n_len,
13872                         &e_spec,
13873                         &e_len,
13874                         &vs_spec,
13875                         &vs_len);
13876
13877             /* If no version on input, truncate the version on output */
13878             if (!hasver && (vs_len > 0)) {
13879                 *vs_spec = '\0';
13880                 vs_len = 0;
13881             }
13882
13883             if (isunix) {
13884
13885                 /* In Unix report mode, remove the ".dir;1" from the name */
13886                 /* if it is a real directory */
13887                 if (decc_filename_unix_report || decc_efs_charset) {
13888                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13889                         Stat_t statbuf;
13890                         int ret_sts;
13891
13892                         ret_sts = flex_lstat(rstr, &statbuf);
13893                         if ((ret_sts == 0) &&
13894                             S_ISDIR(statbuf.st_mode)) {
13895                             e_len = 0;
13896                             e_spec[0] = 0;
13897                         }
13898                     }
13899                 }
13900
13901                 /* No version & a null extension on UNIX handling */
13902                 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13903                     e_len = 0;
13904                     *e_spec = '\0';
13905                 }
13906             }
13907
13908             if (!decc_efs_case_preserve) {
13909                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13910             }
13911
13912             /* Find File treats a Null extension as return all extensions */
13913             /* This is contrary to Perl expectations */
13914
13915             if (wildstar || wildquery || vms_old_glob) {
13916                 /* really need to see if the returned file name matched */
13917                 /* but for now will assume that it matches */
13918                 valid_find = 1;
13919             } else {
13920                 /* Exact Match requested */
13921                 /* How are directories handled? - like a file */
13922                 if ((e_len == we_len) && (n_len == wn_len)) {
13923                     int t1;
13924                     t1 = e_len;
13925                     if (t1 > 0)
13926                         t1 = strncmp(e_spec, we_spec, e_len);
13927                     if (t1 == 0) {
13928                        t1 = n_len;
13929                        if (t1 > 0)
13930                            t1 = strncmp(n_spec, we_spec, n_len);
13931                        if (t1 == 0)
13932                            valid_find = 1;
13933                     }
13934                 }
13935             }
13936
13937             if (valid_find) {
13938                 found++;
13939
13940                 if (hasdir) {
13941                     if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13942                     begin = rstr;
13943                 }
13944                 else {
13945                     /* Start with the name */
13946                     begin = n_spec;
13947                 }
13948                 strcat(begin,"\n");
13949                 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13950             }
13951         }
13952         if (cxt) (void)lib$find_file_end(&cxt);
13953
13954         if (!found) {
13955             /* Be POSIXish: return the input pattern when no matches */
13956             strcpy(rstr,SvPVX(tmpglob));
13957             strcat(rstr,"\n");
13958             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13959         }
13960
13961         if (ok && sts != RMS$_NMF &&
13962             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13963         if (!ok) {
13964             if (!(sts & 1)) {
13965                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13966             }
13967             PerlIO_close(tmpfp);
13968             fp = NULL;
13969         }
13970         else {
13971             PerlIO_rewind(tmpfp);
13972             IoTYPE(io) = IoTYPE_RDONLY;
13973             IoIFP(io) = fp = tmpfp;
13974             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
13975         }
13976     }
13977     Safefree(vmsspec);
13978     Safefree(rslt);
13979     return fp;
13980 }
13981
13982
13983 static char *
13984 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13985                    int *utf8_fl);
13986
13987 void
13988 unixrealpath_fromperl(pTHX_ CV *cv)
13989 {
13990     dXSARGS;
13991     char *fspec, *rslt_spec, *rslt;
13992     STRLEN n_a;
13993
13994     if (!items || items != 1)
13995         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
13996
13997     fspec = SvPV(ST(0),n_a);
13998     if (!fspec || !*fspec) XSRETURN_UNDEF;
13999
14000     Newx(rslt_spec, VMS_MAXRSS + 1, char);
14001     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
14002
14003     ST(0) = sv_newmortal();
14004     if (rslt != NULL)
14005         sv_usepvn(ST(0),rslt,strlen(rslt));
14006     else
14007         Safefree(rslt_spec);
14008         XSRETURN(1);
14009 }
14010
14011 static char *
14012 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
14013                    int *utf8_fl);
14014
14015 void
14016 vmsrealpath_fromperl(pTHX_ CV *cv)
14017 {
14018     dXSARGS;
14019     char *fspec, *rslt_spec, *rslt;
14020     STRLEN n_a;
14021
14022     if (!items || items != 1)
14023         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
14024
14025     fspec = SvPV(ST(0),n_a);
14026     if (!fspec || !*fspec) XSRETURN_UNDEF;
14027
14028     Newx(rslt_spec, VMS_MAXRSS + 1, char);
14029     rslt = do_vms_realname(fspec, rslt_spec, NULL);
14030
14031     ST(0) = sv_newmortal();
14032     if (rslt != NULL)
14033         sv_usepvn(ST(0),rslt,strlen(rslt));
14034     else
14035         Safefree(rslt_spec);
14036         XSRETURN(1);
14037 }
14038
14039 #ifdef HAS_SYMLINK
14040 /*
14041  * A thin wrapper around decc$symlink to make sure we follow the
14042  * standard and do not create a symlink with a zero-length name.
14043  *
14044  * Also in ODS-2 mode, existing tests assume that the link target
14045  * will be converted to UNIX format.
14046  */
14047 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
14048 int Perl_my_symlink(pTHX_ const char *contents, const char *link_name) {
14049   if (!link_name || !*link_name) {
14050     SETERRNO(ENOENT, SS$_NOSUCHFILE);
14051     return -1;
14052   }
14053
14054   if (decc_efs_charset) {
14055       return symlink(contents, link_name);
14056   } else {
14057       int sts;
14058       char * utarget;
14059
14060       /* Unless we are in ODS-5 mode, convert the symlink target to UNIX */
14061       /* because in order to work, the symlink target must be in UNIX format */
14062
14063       /* As symbolic links can hold things other than files, we will only do */
14064       /* the conversion in in ODS-2 mode */
14065
14066       utarget = PerlMem_malloc(VMS_MAXRSS + 1);
14067       if (int_tounixspec(contents, utarget, NULL) == NULL) {
14068
14069           /* This should not fail, as an untranslatable filename */
14070           /* should be passed through */
14071           utarget = (char *)contents;
14072       }
14073       sts = symlink(utarget, link_name);
14074       PerlMem_free(utarget);
14075       return sts;
14076   }
14077
14078 }
14079 /*}}}*/
14080
14081 #endif /* HAS_SYMLINK */
14082
14083 int do_vms_case_tolerant(void);
14084
14085 void
14086 case_tolerant_process_fromperl(pTHX_ CV *cv)
14087 {
14088   dXSARGS;
14089   ST(0) = boolSV(do_vms_case_tolerant());
14090   XSRETURN(1);
14091 }
14092
14093 #ifdef USE_ITHREADS
14094
14095 void
14096 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
14097                           struct interp_intern *dst)
14098 {
14099     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
14100
14101     memcpy(dst,src,sizeof(struct interp_intern));
14102 }
14103
14104 #endif
14105
14106 void
14107 Perl_sys_intern_clear(pTHX)
14108 {
14109 }
14110
14111 void
14112 Perl_sys_intern_init(pTHX)
14113 {
14114     unsigned int ix = RAND_MAX;
14115     double x;
14116
14117     VMSISH_HUSHED = 0;
14118
14119     MY_POSIX_EXIT = vms_posix_exit;
14120
14121     x = (float)ix;
14122     MY_INV_RAND_MAX = 1./x;
14123 }
14124
14125 void
14126 init_os_extras(void)
14127 {
14128   dTHX;
14129   char* file = __FILE__;
14130   if (decc_disable_to_vms_logname_translation) {
14131     no_translate_barewords = TRUE;
14132   } else {
14133     no_translate_barewords = FALSE;
14134   }
14135
14136   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
14137   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
14138   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
14139   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
14140   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
14141   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
14142   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
14143   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
14144   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
14145   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
14146   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
14147   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
14148   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
14149   newXSproto("VMS::Filespec::case_tolerant_process",
14150       case_tolerant_process_fromperl,file,"");
14151
14152   store_pipelocs(aTHX);         /* will redo any earlier attempts */
14153
14154   return;
14155 }
14156
14157 #if __CRTL_VER == 80200000
14158 /* This missed getting in to the DECC SDK for 8.2 */
14159 char *realpath(const char *file_name, char * resolved_name, ...);
14160 #endif
14161
14162 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
14163 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
14164  * The perl fallback routine to provide realpath() is not as efficient
14165  * on OpenVMS.
14166  */
14167
14168 /* Hack, use old stat() as fastest way of getting ino_t and device */
14169 int decc$stat(const char *name, void * statbuf);
14170 #if !defined(__VAX) && __CRTL_VER >= 80200000
14171 int decc$lstat(const char *name, void * statbuf);
14172 #else
14173 #define decc$lstat decc$stat
14174 #endif
14175
14176
14177 /* Realpath is fragile.  In 8.3 it does not work if the feature
14178  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
14179  * links are implemented in RMS, not the CRTL. It also can fail if the
14180  * user does not have read/execute access to some of the directories.
14181  * So in order for Do What I Mean mode to work, if realpath() fails,
14182  * fall back to looking up the filename by the device name and FID.
14183  */
14184
14185 int vms_fid_to_name(char * outname, int outlen,
14186                     const char * name, int lstat_flag, mode_t * mode)
14187 {
14188 #pragma message save
14189 #pragma message disable MISALGNDSTRCT
14190 #pragma message disable MISALGNDMEM
14191 #pragma member_alignment save
14192 #pragma nomember_alignment
14193 struct statbuf_t {
14194     char           * st_dev;
14195     unsigned short st_ino[3];
14196     unsigned short old_st_mode;
14197     unsigned long  padl[30];  /* plenty of room */
14198 } statbuf;
14199 #pragma message restore
14200 #pragma member_alignment restore
14201
14202     int sts;
14203     struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
14204     struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
14205     char *fileified;
14206     char *temp_fspec;
14207     char *ret_spec;
14208
14209     /* Need to follow the mostly the same rules as flex_stat_int, or we may get
14210      * unexpected answers
14211      */
14212
14213     fileified = PerlMem_malloc(VMS_MAXRSS);
14214     if (fileified == NULL)
14215         _ckvmssts_noperl(SS$_INSFMEM);
14216
14217     temp_fspec = PerlMem_malloc(VMS_MAXRSS);
14218     if (temp_fspec == NULL)
14219         _ckvmssts_noperl(SS$_INSFMEM);
14220
14221     sts = -1;
14222     /* First need to try as a directory */
14223     ret_spec = int_tovmspath(name, temp_fspec, NULL);
14224     if (ret_spec != NULL) {
14225         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
14226         if (ret_spec != NULL) {
14227             if (lstat_flag == 0)
14228                 sts = decc$stat(fileified, &statbuf);
14229             else
14230                 sts = decc$lstat(fileified, &statbuf);
14231         }
14232     }
14233
14234     /* Then as a VMS file spec */
14235     if (sts != 0) {
14236         ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
14237         if (ret_spec != NULL) {
14238             if (lstat_flag == 0) {
14239                 sts = decc$stat(temp_fspec, &statbuf);
14240             } else {
14241                 sts = decc$lstat(temp_fspec, &statbuf);
14242             }
14243         }
14244     }
14245
14246     if (sts) {
14247         /* Next try - allow multiple dots with out EFS CHARSET */
14248         /* The CRTL stat() falls down hard on multi-dot filenames in unix
14249          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
14250          * enable it if it isn't already.
14251          */
14252 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14253         if (!decc_efs_charset && (decc_efs_charset_index > 0))
14254             decc$feature_set_value(decc_efs_charset_index, 1, 1);
14255 #endif
14256         ret_spec = int_tovmspath(name, temp_fspec, NULL);
14257         if (lstat_flag == 0) {
14258             sts = decc$stat(name, &statbuf);
14259         } else {
14260             sts = decc$lstat(name, &statbuf);
14261         }
14262 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14263         if (!decc_efs_charset && (decc_efs_charset_index > 0))
14264             decc$feature_set_value(decc_efs_charset_index, 1, 0);
14265 #endif
14266     }
14267
14268
14269     /* and then because the Perl Unix to VMS conversion is not perfect */
14270     /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
14271     /* characters from filenames so we need to try it as-is */
14272     if (sts) {
14273         if (lstat_flag == 0) {
14274             sts = decc$stat(name, &statbuf);
14275         } else {
14276             sts = decc$lstat(name, &statbuf);
14277         }
14278     }
14279
14280     if (sts == 0) {
14281         int vms_sts;
14282
14283         dvidsc.dsc$a_pointer=statbuf.st_dev;
14284         dvidsc.dsc$w_length=strlen(statbuf.st_dev);
14285
14286         specdsc.dsc$a_pointer = outname;
14287         specdsc.dsc$w_length = outlen-1;
14288
14289         vms_sts = lib$fid_to_name
14290             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
14291         if ($VMS_STATUS_SUCCESS(vms_sts)) {
14292             outname[specdsc.dsc$w_length] = 0;
14293
14294             /* Return the mode */
14295             if (mode) {
14296                 *mode = statbuf.old_st_mode;
14297             }
14298             return 0;
14299         }
14300     }
14301     return sts;
14302 }
14303
14304
14305
14306 static char *
14307 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
14308                    int *utf8_fl)
14309 {
14310     char * rslt = NULL;
14311
14312 #ifdef HAS_SYMLINK
14313     if (decc_posix_compliant_pathnames > 0 ) {
14314         /* realpath currently only works if posix compliant pathnames are
14315          * enabled.  It may start working when they are not, but in that
14316          * case we still want the fallback behavior for backwards compatibility
14317          */
14318         rslt = realpath(filespec, outbuf);
14319     }
14320 #endif
14321
14322     if (rslt == NULL) {
14323         char * vms_spec;
14324         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
14325         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
14326         int file_len;
14327         mode_t my_mode;
14328
14329         /* Fall back to fid_to_name */
14330
14331         Newx(vms_spec, VMS_MAXRSS + 1, char);
14332
14333         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
14334         if (sts == 0) {
14335
14336
14337             /* Now need to trim the version off */
14338             sts = vms_split_path
14339                   (vms_spec,
14340                    &v_spec,
14341                    &v_len,
14342                    &r_spec,
14343                    &r_len,
14344                    &d_spec,
14345                    &d_len,
14346                    &n_spec,
14347                    &n_len,
14348                    &e_spec,
14349                    &e_len,
14350                    &vs_spec,
14351                    &vs_len);
14352
14353
14354                 if (sts == 0) {
14355                     int haslower = 0;
14356                     const char *cp;
14357
14358                     /* Trim off the version */
14359                     int file_len = v_len + r_len + d_len + n_len + e_len;
14360                     vms_spec[file_len] = 0;
14361
14362                     /* The result is expected to be in UNIX format */
14363                     rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
14364
14365                     /* Downcase if input had any lower case letters and
14366                      * case preservation is not in effect.
14367                      */
14368                     if (!decc_efs_case_preserve) {
14369                         for (cp = filespec; *cp; cp++)
14370                             if (islower(*cp)) { haslower = 1; break; }
14371
14372                         if (haslower) __mystrtolower(rslt);
14373                     }
14374                 }
14375         } else {
14376
14377             /* Now for some hacks to deal with backwards and forward */
14378             /* compatibilty */
14379             if (!decc_efs_charset) {
14380
14381                 /* 1. ODS-2 mode wants to do a syntax only translation */
14382                 rslt = int_rmsexpand(filespec, outbuf,
14383                                     NULL, 0, NULL, utf8_fl);
14384
14385             } else {
14386                 if (decc_filename_unix_report) {
14387                     char * dir_name;
14388                     char * vms_dir_name;
14389                     char * file_name;
14390
14391                     /* 2. ODS-5 / UNIX report mode should return a failure */
14392                     /*    if the parent directory also does not exist */
14393                     /*    Otherwise, get the real path for the parent */
14394                     /*    and add the child to it.
14395
14396                     /* basename / dirname only available for VMS 7.0+ */
14397                     /* So we may need to implement them as common routines */
14398
14399                     Newx(dir_name, VMS_MAXRSS + 1, char);
14400                     Newx(vms_dir_name, VMS_MAXRSS + 1, char);
14401                     dir_name[0] = '\0';
14402                     file_name = NULL;
14403
14404                     /* First try a VMS parse */
14405                     sts = vms_split_path
14406                           (filespec,
14407                            &v_spec,
14408                            &v_len,
14409                            &r_spec,
14410                            &r_len,
14411                            &d_spec,
14412                            &d_len,
14413                            &n_spec,
14414                            &n_len,
14415                            &e_spec,
14416                            &e_len,
14417                            &vs_spec,
14418                            &vs_len);
14419
14420                     if (sts == 0) {
14421                         /* This is VMS */
14422
14423                         int dir_len = v_len + r_len + d_len + n_len;
14424                         if (dir_len > 0) {
14425                            strncpy(dir_name, filespec, dir_len);
14426                            dir_name[dir_len] = '\0';
14427                            file_name = (char *)&filespec[dir_len + 1];
14428                         }
14429                     } else {
14430                         /* This must be UNIX */
14431                         char * tchar;
14432
14433                         tchar = strrchr(filespec, '/');
14434
14435                         if (tchar != NULL) {
14436                             int dir_len = tchar - filespec;
14437                             strncpy(dir_name, filespec, dir_len);
14438                             dir_name[dir_len] = '\0';
14439                             file_name = (char *) &filespec[dir_len + 1];
14440                         }
14441                     }
14442
14443                     /* Dir name is defaulted */
14444                     if (dir_name[0] == 0) {
14445                         dir_name[0] = '.';
14446                         dir_name[1] = '\0';
14447                     }
14448
14449                     /* Need realpath for the directory */
14450                     sts = vms_fid_to_name(vms_dir_name,
14451                                           VMS_MAXRSS + 1,
14452                                           dir_name, 0, NULL);
14453
14454                     if (sts == 0) {
14455                         /* Now need to pathify it.
14456                         char *tdir = int_pathify_dirspec(vms_dir_name,
14457                                                          outbuf);
14458
14459                         /* And now add the original filespec to it */
14460                         if (file_name != NULL) {
14461                             strcat(outbuf, file_name);
14462                         }
14463                         return outbuf;
14464                     }
14465                     Safefree(vms_dir_name);
14466                     Safefree(dir_name);
14467                 }
14468             }
14469         }
14470         Safefree(vms_spec);
14471     }
14472     return rslt;
14473 }
14474
14475 static char *
14476 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
14477                    int *utf8_fl)
14478 {
14479     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
14480     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
14481     int file_len;
14482
14483     /* Fall back to fid_to_name */
14484
14485     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
14486     if (sts != 0) {
14487         return NULL;
14488     }
14489     else {
14490
14491
14492         /* Now need to trim the version off */
14493         sts = vms_split_path
14494                   (outbuf,
14495                    &v_spec,
14496                    &v_len,
14497                    &r_spec,
14498                    &r_len,
14499                    &d_spec,
14500                    &d_len,
14501                    &n_spec,
14502                    &n_len,
14503                    &e_spec,
14504                    &e_len,
14505                    &vs_spec,
14506                    &vs_len);
14507
14508
14509         if (sts == 0) {
14510             int haslower = 0;
14511             const char *cp;
14512
14513             /* Trim off the version */
14514             int file_len = v_len + r_len + d_len + n_len + e_len;
14515             outbuf[file_len] = 0;
14516
14517             /* Downcase if input had any lower case letters and
14518              * case preservation is not in effect.
14519              */
14520             if (!decc_efs_case_preserve) {
14521                 for (cp = filespec; *cp; cp++)
14522                     if (islower(*cp)) { haslower = 1; break; }
14523
14524                 if (haslower) __mystrtolower(outbuf);
14525             }
14526         }
14527     }
14528     return outbuf;
14529 }
14530
14531
14532 /*}}}*/
14533 /* External entry points */
14534 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
14535 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
14536
14537 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
14538 { return do_vms_realname(filespec, outbuf, utf8_fl); }
14539
14540 /* case_tolerant */
14541
14542 /*{{{int do_vms_case_tolerant(void)*/
14543 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
14544  * controlled by a process setting.
14545  */
14546 int do_vms_case_tolerant(void)
14547 {
14548     return vms_process_case_tolerant;
14549 }
14550 /*}}}*/
14551 /* External entry points */
14552 #if __CRTL_VER >= 70301000 && !defined(__VAX)
14553 int Perl_vms_case_tolerant(void)
14554 { return do_vms_case_tolerant(); }
14555 #else
14556 int Perl_vms_case_tolerant(void)
14557 { return vms_process_case_tolerant; }
14558 #endif
14559
14560
14561  /* Start of DECC RTL Feature handling */
14562
14563 static int sys_trnlnm
14564    (const char * logname,
14565     char * value,
14566     int value_len)
14567 {
14568     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
14569     const unsigned long attr = LNM$M_CASE_BLIND;
14570     struct dsc$descriptor_s name_dsc;
14571     int status;
14572     unsigned short result;
14573     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
14574                                 {0, 0, 0, 0}};
14575
14576     name_dsc.dsc$w_length = strlen(logname);
14577     name_dsc.dsc$a_pointer = (char *)logname;
14578     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14579     name_dsc.dsc$b_class = DSC$K_CLASS_S;
14580
14581     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
14582
14583     if ($VMS_STATUS_SUCCESS(status)) {
14584
14585          /* Null terminate and return the string */
14586         /*--------------------------------------*/
14587         value[result] = 0;
14588     }
14589
14590     return status;
14591 }
14592
14593 static int sys_crelnm
14594    (const char * logname,
14595     const char * value)
14596 {
14597     int ret_val;
14598     const char * proc_table = "LNM$PROCESS_TABLE";
14599     struct dsc$descriptor_s proc_table_dsc;
14600     struct dsc$descriptor_s logname_dsc;
14601     struct itmlst_3 item_list[2];
14602
14603     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
14604     proc_table_dsc.dsc$w_length = strlen(proc_table);
14605     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14606     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
14607
14608     logname_dsc.dsc$a_pointer = (char *) logname;
14609     logname_dsc.dsc$w_length = strlen(logname);
14610     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14611     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
14612
14613     item_list[0].buflen = strlen(value);
14614     item_list[0].itmcode = LNM$_STRING;
14615     item_list[0].bufadr = (char *)value;
14616     item_list[0].retlen = NULL;
14617
14618     item_list[1].buflen = 0;
14619     item_list[1].itmcode = 0;
14620
14621     ret_val = sys$crelnm
14622                        (NULL,
14623                         (const struct dsc$descriptor_s *)&proc_table_dsc,
14624                         (const struct dsc$descriptor_s *)&logname_dsc,
14625                         NULL,
14626                         (const struct item_list_3 *) item_list);
14627
14628     return ret_val;
14629 }
14630
14631 /* C RTL Feature settings */
14632
14633 static int set_features
14634    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
14635     int (* cli_routine)(void),  /* Not documented */
14636     void *image_info)           /* Not documented */
14637 {
14638     int status;
14639     int s;
14640     char* str;
14641     char val_str[10];
14642 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
14643     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
14644     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
14645     unsigned long case_perm;
14646     unsigned long case_image;
14647 #endif
14648
14649     /* Allow an exception to bring Perl into the VMS debugger */
14650     vms_debug_on_exception = 0;
14651     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
14652     if ($VMS_STATUS_SUCCESS(status)) {
14653        val_str[0] = _toupper(val_str[0]);
14654        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14655          vms_debug_on_exception = 1;
14656        else
14657          vms_debug_on_exception = 0;
14658     }
14659
14660     /* Debug unix/vms file translation routines */
14661     vms_debug_fileify = 0;
14662     status = sys_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
14663     if ($VMS_STATUS_SUCCESS(status)) {
14664         val_str[0] = _toupper(val_str[0]);
14665         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14666             vms_debug_fileify = 1;
14667         else
14668             vms_debug_fileify = 0;
14669     }
14670
14671
14672     /* Historically PERL has been doing vmsify / stat differently than */
14673     /* the CRTL.  In particular, under some conditions the CRTL will   */
14674     /* remove some illegal characters like spaces from filenames       */
14675     /* resulting in some differences.  The stat()/lstat() wrapper has  */
14676     /* been reporting such file names as invalid and fails to stat them */
14677     /* fixing this bug so that stat()/lstat() accept these like the     */
14678     /* CRTL does will result in several tests failing.                  */
14679     /* This should really be fixed, but for now, set up a feature to    */
14680     /* enable it so that the impact can be studied.                     */
14681     vms_bug_stat_filename = 0;
14682     status = sys_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
14683     if ($VMS_STATUS_SUCCESS(status)) {
14684         val_str[0] = _toupper(val_str[0]);
14685         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14686             vms_bug_stat_filename = 1;
14687         else
14688             vms_bug_stat_filename = 0;
14689     }
14690
14691
14692     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
14693     vms_vtf7_filenames = 0;
14694     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
14695     if ($VMS_STATUS_SUCCESS(status)) {
14696        val_str[0] = _toupper(val_str[0]);
14697        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14698          vms_vtf7_filenames = 1;
14699        else
14700          vms_vtf7_filenames = 0;
14701     }
14702
14703     /* unlink all versions on unlink() or rename() */
14704     vms_unlink_all_versions = 0;
14705     status = sys_trnlnm
14706         ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
14707     if ($VMS_STATUS_SUCCESS(status)) {
14708        val_str[0] = _toupper(val_str[0]);
14709        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14710          vms_unlink_all_versions = 1;
14711        else
14712          vms_unlink_all_versions = 0;
14713     }
14714
14715     /* Dectect running under GNV Bash or other UNIX like shell */
14716 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14717     gnv_unix_shell = 0;
14718     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
14719     if ($VMS_STATUS_SUCCESS(status)) {
14720          gnv_unix_shell = 1;
14721          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
14722          set_feature_default("DECC$EFS_CHARSET", 1);
14723          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
14724          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
14725          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
14726          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
14727          vms_unlink_all_versions = 1;
14728          vms_posix_exit = 1;
14729     }
14730 #endif
14731
14732     /* hacks to see if known bugs are still present for testing */
14733
14734     /* PCP mode requires creating /dev/null special device file */
14735     decc_bug_devnull = 0;
14736     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14737     if ($VMS_STATUS_SUCCESS(status)) {
14738        val_str[0] = _toupper(val_str[0]);
14739        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14740           decc_bug_devnull = 1;
14741        else
14742           decc_bug_devnull = 0;
14743     }
14744
14745     /* UNIX directory names with no paths are broken in a lot of places */
14746     decc_dir_barename = 1;
14747     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
14748     if ($VMS_STATUS_SUCCESS(status)) {
14749       val_str[0] = _toupper(val_str[0]);
14750       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14751         decc_dir_barename = 1;
14752       else
14753         decc_dir_barename = 0;
14754     }
14755
14756 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14757     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14758     if (s >= 0) {
14759         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14760         if (decc_disable_to_vms_logname_translation < 0)
14761             decc_disable_to_vms_logname_translation = 0;
14762     }
14763
14764     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14765     if (s >= 0) {
14766         decc_efs_case_preserve = decc$feature_get_value(s, 1);
14767         if (decc_efs_case_preserve < 0)
14768             decc_efs_case_preserve = 0;
14769     }
14770
14771     s = decc$feature_get_index("DECC$EFS_CHARSET");
14772     decc_efs_charset_index = s;
14773     if (s >= 0) {
14774         decc_efs_charset = decc$feature_get_value(s, 1);
14775         if (decc_efs_charset < 0)
14776             decc_efs_charset = 0;
14777     }
14778
14779     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14780     if (s >= 0) {
14781         decc_filename_unix_report = decc$feature_get_value(s, 1);
14782         if (decc_filename_unix_report > 0) {
14783             decc_filename_unix_report = 1;
14784             vms_posix_exit = 1;
14785         }
14786         else
14787             decc_filename_unix_report = 0;
14788     }
14789
14790     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14791     if (s >= 0) {
14792         decc_filename_unix_only = decc$feature_get_value(s, 1);
14793         if (decc_filename_unix_only > 0) {
14794             decc_filename_unix_only = 1;
14795         }
14796         else {
14797             decc_filename_unix_only = 0;
14798         }
14799     }
14800
14801     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14802     if (s >= 0) {
14803         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14804         if (decc_filename_unix_no_version < 0)
14805             decc_filename_unix_no_version = 0;
14806     }
14807
14808     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14809     if (s >= 0) {
14810         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14811         if (decc_readdir_dropdotnotype < 0)
14812             decc_readdir_dropdotnotype = 0;
14813     }
14814
14815 #if __CRTL_VER >= 80200000
14816     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14817     if (s >= 0) {
14818         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14819         if (decc_posix_compliant_pathnames < 0)
14820             decc_posix_compliant_pathnames = 0;
14821         if (decc_posix_compliant_pathnames > 4)
14822             decc_posix_compliant_pathnames = 0;
14823     }
14824
14825 #endif
14826 #else
14827     status = sys_trnlnm
14828         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
14829     if ($VMS_STATUS_SUCCESS(status)) {
14830         val_str[0] = _toupper(val_str[0]);
14831         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14832            decc_disable_to_vms_logname_translation = 1;
14833         }
14834     }
14835
14836 #ifndef __VAX
14837     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
14838     if ($VMS_STATUS_SUCCESS(status)) {
14839         val_str[0] = _toupper(val_str[0]);
14840         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14841            decc_efs_case_preserve = 1;
14842         }
14843     }
14844 #endif
14845
14846     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14847     if ($VMS_STATUS_SUCCESS(status)) {
14848         val_str[0] = _toupper(val_str[0]);
14849         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14850            decc_filename_unix_report = 1;
14851         }
14852     }
14853     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14854     if ($VMS_STATUS_SUCCESS(status)) {
14855         val_str[0] = _toupper(val_str[0]);
14856         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14857            decc_filename_unix_only = 1;
14858            decc_filename_unix_report = 1;
14859         }
14860     }
14861     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14862     if ($VMS_STATUS_SUCCESS(status)) {
14863         val_str[0] = _toupper(val_str[0]);
14864         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14865            decc_filename_unix_no_version = 1;
14866         }
14867     }
14868     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
14869     if ($VMS_STATUS_SUCCESS(status)) {
14870         val_str[0] = _toupper(val_str[0]);
14871         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14872            decc_readdir_dropdotnotype = 1;
14873         }
14874     }
14875 #endif
14876
14877 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
14878
14879      /* Report true case tolerance */
14880     /*----------------------------*/
14881     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14882     if (!$VMS_STATUS_SUCCESS(status))
14883         case_perm = PPROP$K_CASE_BLIND;
14884     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14885     if (!$VMS_STATUS_SUCCESS(status))
14886         case_image = PPROP$K_CASE_BLIND;
14887     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14888         (case_image == PPROP$K_CASE_SENSITIVE))
14889         vms_process_case_tolerant = 0;
14890
14891 #endif
14892
14893     /* USE POSIX/DCL Exit codes - Recommended, but needs to default to  */
14894     /* for strict backward compatibilty */
14895     status = sys_trnlnm
14896         ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14897     if ($VMS_STATUS_SUCCESS(status)) {
14898        val_str[0] = _toupper(val_str[0]);
14899        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14900          vms_posix_exit = 1;
14901        else
14902          vms_posix_exit = 0;
14903     }
14904
14905
14906     /* CRTL can be initialized past this point, but not before. */
14907 /*    DECC$CRTL_INIT(); */
14908
14909     return SS$_NORMAL;
14910 }
14911
14912 #ifdef __DECC
14913 #pragma nostandard
14914 #pragma extern_model save
14915 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
14916         const __align (LONGWORD) int spare[8] = {0};
14917
14918 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
14919 #if __DECC_VER >= 60560002
14920 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
14921 #else
14922 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
14923 #endif
14924 #endif /* __DECC */
14925
14926 const long vms_cc_features = (const long)set_features;
14927
14928 /*
14929 ** Force a reference to LIB$INITIALIZE to ensure it
14930 ** exists in the image.
14931 */
14932 int lib$initialize(void);
14933 #ifdef __DECC
14934 #pragma extern_model strict_refdef
14935 #endif
14936     int lib_init_ref = (int) lib$initialize;
14937
14938 #ifdef __DECC
14939 #pragma extern_model restore
14940 #pragma standard
14941 #endif
14942
14943 /*  End of vms.c */