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                     "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                      "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 #ifdef __VAX
2889 #  define PERL_BUFSIZ        512
2890 #else
2891 #  define PERL_BUFSIZ        8192
2892 #endif
2893
2894
2895 static void
2896 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2897 {
2898   unsigned long int mbxbufsiz;
2899   static unsigned long int syssize = 0;
2900   unsigned long int dviitm = DVI$_DEVNAM;
2901   char csize[LNM$C_NAMLENGTH+1];
2902   int sts;
2903
2904   if (!syssize) {
2905     unsigned long syiitm = SYI$_MAXBUF;
2906     /*
2907      * Get the SYSGEN parameter MAXBUF
2908      *
2909      * If the logical 'PERL_MBX_SIZE' is defined
2910      * use the value of the logical instead of PERL_BUFSIZ, but
2911      * keep the size between 128 and MAXBUF.
2912      *
2913      */
2914     _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2915   }
2916
2917   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2918       mbxbufsiz = atoi(csize);
2919   } else {
2920       mbxbufsiz = PERL_BUFSIZ;
2921   }
2922   if (mbxbufsiz < 128) mbxbufsiz = 128;
2923   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2924
2925   _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2926
2927   sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2928   _ckvmssts_noperl(sts);
2929   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2930
2931 }  /* end of create_mbx() */
2932
2933
2934 /*{{{  my_popen and my_pclose*/
2935
2936 typedef struct _iosb           IOSB;
2937 typedef struct _iosb*         pIOSB;
2938 typedef struct _pipe           Pipe;
2939 typedef struct _pipe*         pPipe;
2940 typedef struct pipe_details    Info;
2941 typedef struct pipe_details*  pInfo;
2942 typedef struct _srqp            RQE;
2943 typedef struct _srqp*          pRQE;
2944 typedef struct _tochildbuf      CBuf;
2945 typedef struct _tochildbuf*    pCBuf;
2946
2947 struct _iosb {
2948     unsigned short status;
2949     unsigned short count;
2950     unsigned long  dvispec;
2951 };
2952
2953 #pragma member_alignment save
2954 #pragma nomember_alignment quadword
2955 struct _srqp {          /* VMS self-relative queue entry */
2956     unsigned long qptr[2];
2957 };
2958 #pragma member_alignment restore
2959 static RQE  RQE_ZERO = {0,0};
2960
2961 struct _tochildbuf {
2962     RQE             q;
2963     int             eof;
2964     unsigned short  size;
2965     char            *buf;
2966 };
2967
2968 struct _pipe {
2969     RQE            free;
2970     RQE            wait;
2971     int            fd_out;
2972     unsigned short chan_in;
2973     unsigned short chan_out;
2974     char          *buf;
2975     unsigned int   bufsize;
2976     IOSB           iosb;
2977     IOSB           iosb2;
2978     int           *pipe_done;
2979     int            retry;
2980     int            type;
2981     int            shut_on_empty;
2982     int            need_wake;
2983     pPipe         *home;
2984     pInfo          info;
2985     pCBuf          curr;
2986     pCBuf          curr2;
2987 #if defined(PERL_IMPLICIT_CONTEXT)
2988     void            *thx;           /* Either a thread or an interpreter */
2989                                     /* pointer, depending on how we're built */
2990 #endif
2991 };
2992
2993
2994 struct pipe_details
2995 {
2996     pInfo           next;
2997     PerlIO *fp;  /* file pointer to pipe mailbox */
2998     int useFILE; /* using stdio, not perlio */
2999     int pid;   /* PID of subprocess */
3000     int mode;  /* == 'r' if pipe open for reading */
3001     int done;  /* subprocess has completed */
3002     int waiting; /* waiting for completion/closure */
3003     int             closing;        /* my_pclose is closing this pipe */
3004     unsigned long   completion;     /* termination status of subprocess */
3005     pPipe           in;             /* pipe in to sub */
3006     pPipe           out;            /* pipe out of sub */
3007     pPipe           err;            /* pipe of sub's sys$error */
3008     int             in_done;        /* true when in pipe finished */
3009     int             out_done;
3010     int             err_done;
3011     unsigned short  xchan;          /* channel to debug xterm */
3012     unsigned short  xchan_valid;    /* channel is assigned */
3013 };
3014
3015 struct exit_control_block
3016 {
3017     struct exit_control_block *flink;
3018     unsigned long int   (*exit_routine)();
3019     unsigned long int arg_count;
3020     unsigned long int *status_address;
3021     unsigned long int exit_status;
3022 };
3023
3024 typedef struct _closed_pipes    Xpipe;
3025 typedef struct _closed_pipes*  pXpipe;
3026
3027 struct _closed_pipes {
3028     int             pid;            /* PID of subprocess */
3029     unsigned long   completion;     /* termination status of subprocess */
3030 };
3031 #define NKEEPCLOSED 50
3032 static Xpipe closed_list[NKEEPCLOSED];
3033 static int   closed_index = 0;
3034 static int   closed_num = 0;
3035
3036 #define RETRY_DELAY     "0 ::0.20"
3037 #define MAX_RETRY              50
3038
3039 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
3040 static unsigned long mypid;
3041 static unsigned long delaytime[2];
3042
3043 static pInfo open_pipes = NULL;
3044 static $DESCRIPTOR(nl_desc, "NL:");
3045
3046 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
3047
3048
3049
3050 static unsigned long int
3051 pipe_exit_routine()
3052 {
3053     pInfo info;
3054     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
3055     int sts, did_stuff, need_eof, j;
3056
3057    /*
3058     * Flush any pending i/o, but since we are in process run-down, be
3059     * careful about referencing PerlIO structures that may already have
3060     * been deallocated.  We may not even have an interpreter anymore.
3061     */
3062     info = open_pipes;
3063     while (info) {
3064         if (info->fp) {
3065 #if defined(PERL_IMPLICIT_CONTEXT)
3066            /* We need to use the Perl context of the thread that created */
3067            /* the pipe. */
3068            pTHX;
3069            if (info->err)
3070                aTHX = info->err->thx;
3071            else if (info->out)
3072                aTHX = info->out->thx;
3073            else if (info->in)
3074                aTHX = info->in->thx;
3075 #endif
3076            if (!info->useFILE
3077 #if defined(USE_ITHREADS)
3078              && my_perl
3079 #endif
3080              && PL_perlio_fd_refcnt)
3081                PerlIO_flush(info->fp);
3082            else
3083                fflush((FILE *)info->fp);
3084         }
3085         info = info->next;
3086     }
3087
3088     /*
3089      next we try sending an EOF...ignore if doesn't work, make sure we
3090      don't hang
3091     */
3092     did_stuff = 0;
3093     info = open_pipes;
3094
3095     while (info) {
3096       int need_eof;
3097       _ckvmssts_noperl(sys$setast(0));
3098       if (info->in && !info->in->shut_on_empty) {
3099         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3100                                  0, 0, 0, 0, 0, 0));
3101         info->waiting = 1;
3102         did_stuff = 1;
3103       }
3104       _ckvmssts_noperl(sys$setast(1));
3105       info = info->next;
3106     }
3107
3108     /* wait for EOF to have effect, up to ~ 30 sec [default] */
3109
3110     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3111         int nwait = 0;
3112
3113         info = open_pipes;
3114         while (info) {
3115           _ckvmssts_noperl(sys$setast(0));
3116           if (info->waiting && info->done)
3117                 info->waiting = 0;
3118           nwait += info->waiting;
3119           _ckvmssts_noperl(sys$setast(1));
3120           info = info->next;
3121         }
3122         if (!nwait) break;
3123         sleep(1);
3124     }
3125
3126     did_stuff = 0;
3127     info = open_pipes;
3128     while (info) {
3129       _ckvmssts_noperl(sys$setast(0));
3130       if (!info->done) { /* Tap them gently on the shoulder . . .*/
3131         sts = sys$forcex(&info->pid,0,&abort);
3132         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3133         did_stuff = 1;
3134       }
3135       _ckvmssts_noperl(sys$setast(1));
3136       info = info->next;
3137     }
3138
3139     /* again, wait for effect */
3140
3141     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3142         int nwait = 0;
3143
3144         info = open_pipes;
3145         while (info) {
3146           _ckvmssts_noperl(sys$setast(0));
3147           if (info->waiting && info->done)
3148                 info->waiting = 0;
3149           nwait += info->waiting;
3150           _ckvmssts_noperl(sys$setast(1));
3151           info = info->next;
3152         }
3153         if (!nwait) break;
3154         sleep(1);
3155     }
3156
3157     info = open_pipes;
3158     while (info) {
3159       _ckvmssts_noperl(sys$setast(0));
3160       if (!info->done) {  /* We tried to be nice . . . */
3161         sts = sys$delprc(&info->pid,0);
3162         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3163         info->done = 1;  /* sys$delprc is as done as we're going to get. */
3164       }
3165       _ckvmssts_noperl(sys$setast(1));
3166       info = info->next;
3167     }
3168
3169     while(open_pipes) {
3170
3171 #if defined(PERL_IMPLICIT_CONTEXT)
3172       /* We need to use the Perl context of the thread that created */
3173       /* the pipe. */
3174       pTHX;
3175       if (open_pipes->err)
3176           aTHX = open_pipes->err->thx;
3177       else if (open_pipes->out)
3178           aTHX = open_pipes->out->thx;
3179       else if (open_pipes->in)
3180           aTHX = open_pipes->in->thx;
3181 #endif
3182       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3183       else if (!(sts & 1)) retsts = sts;
3184     }
3185     return retsts;
3186 }
3187
3188 static struct exit_control_block pipe_exitblock =
3189        {(struct exit_control_block *) 0,
3190         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3191
3192 static void pipe_mbxtofd_ast(pPipe p);
3193 static void pipe_tochild1_ast(pPipe p);
3194 static void pipe_tochild2_ast(pPipe p);
3195
3196 static void
3197 popen_completion_ast(pInfo info)
3198 {
3199   pInfo i = open_pipes;
3200   int iss;
3201   int sts;
3202   pXpipe x;
3203
3204   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3205   closed_list[closed_index].pid = info->pid;
3206   closed_list[closed_index].completion = info->completion;
3207   closed_index++;
3208   if (closed_index == NKEEPCLOSED)
3209     closed_index = 0;
3210   closed_num++;
3211
3212   while (i) {
3213     if (i == info) break;
3214     i = i->next;
3215   }
3216   if (!i) return;       /* unlinked, probably freed too */
3217
3218   info->done = TRUE;
3219
3220 /*
3221     Writing to subprocess ...
3222             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3223
3224             chan_out may be waiting for "done" flag, or hung waiting
3225             for i/o completion to child...cancel the i/o.  This will
3226             put it into "snarf mode" (done but no EOF yet) that discards
3227             input.
3228
3229     Output from subprocess (stdout, stderr) needs to be flushed and
3230     shut down.   We try sending an EOF, but if the mbx is full the pipe
3231     routine should still catch the "shut_on_empty" flag, telling it to
3232     use immediate-style reads so that "mbx empty" -> EOF.
3233
3234
3235 */
3236   if (info->in && !info->in_done) {               /* only for mode=w */
3237         if (info->in->shut_on_empty && info->in->need_wake) {
3238             info->in->need_wake = FALSE;
3239             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3240         } else {
3241             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3242         }
3243   }
3244
3245   if (info->out && !info->out_done) {             /* were we also piping output? */
3246       info->out->shut_on_empty = TRUE;
3247       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3248       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3249       _ckvmssts_noperl(iss);
3250   }
3251
3252   if (info->err && !info->err_done) {        /* we were piping stderr */
3253         info->err->shut_on_empty = TRUE;
3254         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3255         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3256         _ckvmssts_noperl(iss);
3257   }
3258   _ckvmssts_noperl(sys$setef(pipe_ef));
3259
3260 }
3261
3262 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3263 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3264
3265 /*
3266     we actually differ from vmstrnenv since we use this to
3267     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3268     are pointing to the same thing
3269 */
3270
3271 static unsigned short
3272 popen_translate(pTHX_ char *logical, char *result)
3273 {
3274     int iss;
3275     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3276     $DESCRIPTOR(d_log,"");
3277     struct _il3 {
3278         unsigned short length;
3279         unsigned short code;
3280         char *         buffer_addr;
3281         unsigned short *retlenaddr;
3282     } itmlst[2];
3283     unsigned short l, ifi;
3284
3285     d_log.dsc$a_pointer = logical;
3286     d_log.dsc$w_length  = strlen(logical);
3287
3288     itmlst[0].code = LNM$_STRING;
3289     itmlst[0].length = 255;
3290     itmlst[0].buffer_addr = result;
3291     itmlst[0].retlenaddr = &l;
3292
3293     itmlst[1].code = 0;
3294     itmlst[1].length = 0;
3295     itmlst[1].buffer_addr = 0;
3296     itmlst[1].retlenaddr = 0;
3297
3298     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3299     if (iss == SS$_NOLOGNAM) {
3300         iss = SS$_NORMAL;
3301         l = 0;
3302     }
3303     if (!(iss&1)) lib$signal(iss);
3304     result[l] = '\0';
3305 /*
3306     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
3307     strip it off and return the ifi, if any
3308 */
3309     ifi  = 0;
3310     if (result[0] == 0x1b && result[1] == 0x00) {
3311         memmove(&ifi,result+2,2);
3312         strcpy(result,result+4);
3313     }
3314     return ifi;     /* this is the RMS internal file id */
3315 }
3316
3317 static void pipe_infromchild_ast(pPipe p);
3318
3319 /*
3320     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3321     inside an AST routine without worrying about reentrancy and which Perl
3322     memory allocator is being used.
3323
3324     We read data and queue up the buffers, then spit them out one at a
3325     time to the output mailbox when the output mailbox is ready for one.
3326
3327 */
3328 #define INITIAL_TOCHILDQUEUE  2
3329
3330 static pPipe
3331 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3332 {
3333     pPipe p;
3334     pCBuf b;
3335     char mbx1[64], mbx2[64];
3336     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3337                                       DSC$K_CLASS_S, mbx1},
3338                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3339                                       DSC$K_CLASS_S, mbx2};
3340     unsigned int dviitm = DVI$_DEVBUFSIZ;
3341     int j, n;
3342
3343     n = sizeof(Pipe);
3344     _ckvmssts_noperl(lib$get_vm(&n, &p));
3345
3346     create_mbx(&p->chan_in , &d_mbx1);
3347     create_mbx(&p->chan_out, &d_mbx2);
3348     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3349
3350     p->buf           = 0;
3351     p->shut_on_empty = FALSE;
3352     p->need_wake     = FALSE;
3353     p->type          = 0;
3354     p->retry         = 0;
3355     p->iosb.status   = SS$_NORMAL;
3356     p->iosb2.status  = SS$_NORMAL;
3357     p->free          = RQE_ZERO;
3358     p->wait          = RQE_ZERO;
3359     p->curr          = 0;
3360     p->curr2         = 0;
3361     p->info          = 0;
3362 #ifdef PERL_IMPLICIT_CONTEXT
3363     p->thx           = aTHX;
3364 #endif
3365
3366     n = sizeof(CBuf) + p->bufsize;
3367
3368     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3369         _ckvmssts_noperl(lib$get_vm(&n, &b));
3370         b->buf = (char *) b + sizeof(CBuf);
3371         _ckvmssts_noperl(lib$insqhi(b, &p->free));
3372     }
3373
3374     pipe_tochild2_ast(p);
3375     pipe_tochild1_ast(p);
3376     strcpy(wmbx, mbx1);
3377     strcpy(rmbx, mbx2);
3378     return p;
3379 }
3380
3381 /*  reads the MBX Perl is writing, and queues */
3382
3383 static void
3384 pipe_tochild1_ast(pPipe p)
3385 {
3386     pCBuf b = p->curr;
3387     int iss = p->iosb.status;
3388     int eof = (iss == SS$_ENDOFFILE);
3389     int sts;
3390 #ifdef PERL_IMPLICIT_CONTEXT
3391     pTHX = p->thx;
3392 #endif
3393
3394     if (p->retry) {
3395         if (eof) {
3396             p->shut_on_empty = TRUE;
3397             b->eof     = TRUE;
3398             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3399         } else  {
3400             _ckvmssts_noperl(iss);
3401         }
3402
3403         b->eof  = eof;
3404         b->size = p->iosb.count;
3405         _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3406         if (p->need_wake) {
3407             p->need_wake = FALSE;
3408             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3409         }
3410     } else {
3411         p->retry = 1;   /* initial call */
3412     }
3413
3414     if (eof) {                  /* flush the free queue, return when done */
3415         int n = sizeof(CBuf) + p->bufsize;
3416         while (1) {
3417             iss = lib$remqti(&p->free, &b);
3418             if (iss == LIB$_QUEWASEMP) return;
3419             _ckvmssts_noperl(iss);
3420             _ckvmssts_noperl(lib$free_vm(&n, &b));
3421         }
3422     }
3423
3424     iss = lib$remqti(&p->free, &b);
3425     if (iss == LIB$_QUEWASEMP) {
3426         int n = sizeof(CBuf) + p->bufsize;
3427         _ckvmssts_noperl(lib$get_vm(&n, &b));
3428         b->buf = (char *) b + sizeof(CBuf);
3429     } else {
3430        _ckvmssts_noperl(iss);
3431     }
3432
3433     p->curr = b;
3434     iss = sys$qio(0,p->chan_in,
3435              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3436              &p->iosb,
3437              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3438     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3439     _ckvmssts_noperl(iss);
3440 }
3441
3442
3443 /* writes queued buffers to output, waits for each to complete before
3444    doing the next */
3445
3446 static void
3447 pipe_tochild2_ast(pPipe p)
3448 {
3449     pCBuf b = p->curr2;
3450     int iss = p->iosb2.status;
3451     int n = sizeof(CBuf) + p->bufsize;
3452     int done = (p->info && p->info->done) ||
3453               iss == SS$_CANCEL || iss == SS$_ABORT;
3454 #if defined(PERL_IMPLICIT_CONTEXT)
3455     pTHX = p->thx;
3456 #endif
3457
3458     do {
3459         if (p->type) {         /* type=1 has old buffer, dispose */
3460             if (p->shut_on_empty) {
3461                 _ckvmssts_noperl(lib$free_vm(&n, &b));
3462             } else {
3463                 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3464             }
3465             p->type = 0;
3466         }
3467
3468         iss = lib$remqti(&p->wait, &b);
3469         if (iss == LIB$_QUEWASEMP) {
3470             if (p->shut_on_empty) {
3471                 if (done) {
3472                     _ckvmssts_noperl(sys$dassgn(p->chan_out));
3473                     *p->pipe_done = TRUE;
3474                     _ckvmssts_noperl(sys$setef(pipe_ef));
3475                 } else {
3476                     _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3477                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3478                 }
3479                 return;
3480             }
3481             p->need_wake = TRUE;
3482             return;
3483         }
3484         _ckvmssts_noperl(iss);
3485         p->type = 1;
3486     } while (done);
3487
3488
3489     p->curr2 = b;
3490     if (b->eof) {
3491         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3492             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3493     } else {
3494         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3495             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3496     }
3497
3498     return;
3499
3500 }
3501
3502
3503 static pPipe
3504 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3505 {
3506     pPipe p;
3507     char mbx1[64], mbx2[64];
3508     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3509                                       DSC$K_CLASS_S, mbx1},
3510                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3511                                       DSC$K_CLASS_S, mbx2};
3512     unsigned int dviitm = DVI$_DEVBUFSIZ;
3513
3514     int n = sizeof(Pipe);
3515     _ckvmssts_noperl(lib$get_vm(&n, &p));
3516     create_mbx(&p->chan_in , &d_mbx1);
3517     create_mbx(&p->chan_out, &d_mbx2);
3518
3519     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3520     n = p->bufsize * sizeof(char);
3521     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3522     p->shut_on_empty = FALSE;
3523     p->info   = 0;
3524     p->type   = 0;
3525     p->iosb.status = SS$_NORMAL;
3526 #if defined(PERL_IMPLICIT_CONTEXT)
3527     p->thx = aTHX;
3528 #endif
3529     pipe_infromchild_ast(p);
3530
3531     strcpy(wmbx, mbx1);
3532     strcpy(rmbx, mbx2);
3533     return p;
3534 }
3535
3536 static void
3537 pipe_infromchild_ast(pPipe p)
3538 {
3539     int iss = p->iosb.status;
3540     int eof = (iss == SS$_ENDOFFILE);
3541     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3542     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3543 #if defined(PERL_IMPLICIT_CONTEXT)
3544     pTHX = p->thx;
3545 #endif
3546
3547     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3548         _ckvmssts_noperl(sys$dassgn(p->chan_out));
3549         p->chan_out = 0;
3550     }
3551
3552     /* read completed:
3553             input shutdown if EOF from self (done or shut_on_empty)
3554             output shutdown if closing flag set (my_pclose)
3555             send data/eof from child or eof from self
3556             otherwise, re-read (snarf of data from child)
3557     */
3558
3559     if (p->type == 1) {
3560         p->type = 0;
3561         if (myeof && p->chan_in) {                  /* input shutdown */
3562             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3563             p->chan_in = 0;
3564         }
3565
3566         if (p->chan_out) {
3567             if (myeof || kideof) {      /* pass EOF to parent */
3568                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3569                                          pipe_infromchild_ast, p,
3570                                          0, 0, 0, 0, 0, 0));
3571                 return;
3572             } else if (eof) {       /* eat EOF --- fall through to read*/
3573
3574             } else {                /* transmit data */
3575                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3576                                          pipe_infromchild_ast,p,
3577                                          p->buf, p->iosb.count, 0, 0, 0, 0));
3578                 return;
3579             }
3580         }
3581     }
3582
3583     /*  everything shut? flag as done */
3584
3585     if (!p->chan_in && !p->chan_out) {
3586         *p->pipe_done = TRUE;
3587         _ckvmssts_noperl(sys$setef(pipe_ef));
3588         return;
3589     }
3590
3591     /* write completed (or read, if snarfing from child)
3592             if still have input active,
3593                queue read...immediate mode if shut_on_empty so we get EOF if empty
3594             otherwise,
3595                check if Perl reading, generate EOFs as needed
3596     */
3597
3598     if (p->type == 0) {
3599         p->type = 1;
3600         if (p->chan_in) {
3601             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3602                           pipe_infromchild_ast,p,
3603                           p->buf, p->bufsize, 0, 0, 0, 0);
3604             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3605             _ckvmssts_noperl(iss);
3606         } else {           /* send EOFs for extra reads */
3607             p->iosb.status = SS$_ENDOFFILE;
3608             p->iosb.dvispec = 0;
3609             _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3610                                      0, 0, 0,
3611                                      pipe_infromchild_ast, p, 0, 0, 0, 0));
3612         }
3613     }
3614 }
3615
3616 static pPipe
3617 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3618 {
3619     pPipe p;
3620     char mbx[64];
3621     unsigned long dviitm = DVI$_DEVBUFSIZ;
3622     struct stat s;
3623     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3624                                       DSC$K_CLASS_S, mbx};
3625     int n = sizeof(Pipe);
3626
3627     /* things like terminals and mbx's don't need this filter */
3628     if (fd && fstat(fd,&s) == 0) {
3629         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3630         char device[65];
3631         unsigned short dev_len;
3632         struct dsc$descriptor_s d_dev;
3633         char * cptr;
3634         struct item_list_3 items[3];
3635         int status;
3636         unsigned short dvi_iosb[4];
3637
3638         cptr = getname(fd, out, 1);
3639         if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3640         d_dev.dsc$a_pointer = out;
3641         d_dev.dsc$w_length = strlen(out);
3642         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3643         d_dev.dsc$b_class = DSC$K_CLASS_S;
3644
3645         items[0].len = 4;
3646         items[0].code = DVI$_DEVCHAR;
3647         items[0].bufadr = &devchar;
3648         items[0].retadr = NULL;
3649         items[1].len = 64;
3650         items[1].code = DVI$_FULLDEVNAM;
3651         items[1].bufadr = device;
3652         items[1].retadr = &dev_len;
3653         items[2].len = 0;
3654         items[2].code = 0;
3655
3656         status = sys$getdviw
3657                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3658         _ckvmssts_noperl(status);
3659         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3660             device[dev_len] = 0;
3661
3662             if (!(devchar & DEV$M_DIR)) {
3663                 strcpy(out, device);
3664                 return 0;
3665             }
3666         }
3667     }
3668
3669     _ckvmssts_noperl(lib$get_vm(&n, &p));
3670     p->fd_out = dup(fd);
3671     create_mbx(&p->chan_in, &d_mbx);
3672     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3673     n = (p->bufsize+1) * sizeof(char);
3674     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3675     p->shut_on_empty = FALSE;
3676     p->retry = 0;
3677     p->info  = 0;
3678     strcpy(out, mbx);
3679
3680     _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3681                              pipe_mbxtofd_ast, p,
3682                              p->buf, p->bufsize, 0, 0, 0, 0));
3683
3684     return p;
3685 }
3686
3687 static void
3688 pipe_mbxtofd_ast(pPipe p)
3689 {
3690     int iss = p->iosb.status;
3691     int done = p->info->done;
3692     int iss2;
3693     int eof = (iss == SS$_ENDOFFILE);
3694     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3695     int err = !(iss&1) && !eof;
3696 #if defined(PERL_IMPLICIT_CONTEXT)
3697     pTHX = p->thx;
3698 #endif
3699
3700     if (done && myeof) {               /* end piping */
3701         close(p->fd_out);
3702         sys$dassgn(p->chan_in);
3703         *p->pipe_done = TRUE;
3704         _ckvmssts_noperl(sys$setef(pipe_ef));
3705         return;
3706     }
3707
3708     if (!err && !eof) {             /* good data to send to file */
3709         p->buf[p->iosb.count] = '\n';
3710         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3711         if (iss2 < 0) {
3712             p->retry++;
3713             if (p->retry < MAX_RETRY) {
3714                 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3715                 return;
3716             }
3717         }
3718         p->retry = 0;
3719     } else if (err) {
3720         _ckvmssts_noperl(iss);
3721     }
3722
3723
3724     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3725           pipe_mbxtofd_ast, p,
3726           p->buf, p->bufsize, 0, 0, 0, 0);
3727     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3728     _ckvmssts_noperl(iss);
3729 }
3730
3731
3732 typedef struct _pipeloc     PLOC;
3733 typedef struct _pipeloc*   pPLOC;
3734
3735 struct _pipeloc {
3736     pPLOC   next;
3737     char    dir[NAM$C_MAXRSS+1];
3738 };
3739 static pPLOC  head_PLOC = 0;
3740
3741 void
3742 free_pipelocs(pTHX_ void *head)
3743 {
3744     pPLOC p, pnext;
3745     pPLOC *pHead = (pPLOC *)head;
3746
3747     p = *pHead;
3748     while (p) {
3749         pnext = p->next;
3750         PerlMem_free(p);
3751         p = pnext;
3752     }
3753     *pHead = 0;
3754 }
3755
3756 static void
3757 store_pipelocs(pTHX)
3758 {
3759     int    i;
3760     pPLOC  p;
3761     AV    *av = 0;
3762     SV    *dirsv;
3763     GV    *gv;
3764     char  *dir, *x;
3765     char  *unixdir;
3766     char  temp[NAM$C_MAXRSS+1];
3767     STRLEN n_a;
3768
3769     if (head_PLOC)
3770         free_pipelocs(aTHX_ &head_PLOC);
3771
3772 /*  the . directory from @INC comes last */
3773
3774     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3775     if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3776     p->next = head_PLOC;
3777     head_PLOC = p;
3778     strcpy(p->dir,"./");
3779
3780 /*  get the directory from $^X */
3781
3782     unixdir = PerlMem_malloc(VMS_MAXRSS);
3783     if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3784
3785 #ifdef PERL_IMPLICIT_CONTEXT
3786     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3787 #else
3788     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3789 #endif
3790         strcpy(temp, PL_origargv[0]);
3791         x = strrchr(temp,']');
3792         if (x == NULL) {
3793         x = strrchr(temp,'>');
3794           if (x == NULL) {
3795             /* It could be a UNIX path */
3796             x = strrchr(temp,'/');
3797           }
3798         }
3799         if (x)
3800           x[1] = '\0';
3801         else {
3802           /* Got a bare name, so use default directory */
3803           temp[0] = '.';
3804           temp[1] = '\0';
3805         }
3806
3807         if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3808             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3809             if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3810             p->next = head_PLOC;
3811             head_PLOC = p;
3812             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3813             p->dir[NAM$C_MAXRSS] = '\0';
3814         }
3815     }
3816
3817 /*  reverse order of @INC entries, skip "." since entered above */
3818
3819 #ifdef PERL_IMPLICIT_CONTEXT
3820     if (aTHX)
3821 #endif
3822     if (PL_incgv) av = GvAVn(PL_incgv);
3823
3824     for (i = 0; av && i <= AvFILL(av); i++) {
3825         dirsv = *av_fetch(av,i,TRUE);
3826
3827         if (SvROK(dirsv)) continue;
3828         dir = SvPVx(dirsv,n_a);
3829         if (strcmp(dir,".") == 0) continue;
3830         if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3831             continue;
3832
3833         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3834         p->next = head_PLOC;
3835         head_PLOC = p;
3836         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3837         p->dir[NAM$C_MAXRSS] = '\0';
3838     }
3839
3840 /* most likely spot (ARCHLIB) put first in the list */
3841
3842 #ifdef ARCHLIB_EXP
3843     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3844         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3845         if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3846         p->next = head_PLOC;
3847         head_PLOC = p;
3848         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3849         p->dir[NAM$C_MAXRSS] = '\0';
3850     }
3851 #endif
3852     PerlMem_free(unixdir);
3853 }
3854
3855 static I32
3856 Perl_cando_by_name_int
3857    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3858 #if !defined(PERL_IMPLICIT_CONTEXT)
3859 #define cando_by_name_int               Perl_cando_by_name_int
3860 #else
3861 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3862 #endif
3863
3864 static char *
3865 find_vmspipe(pTHX)
3866 {
3867     static int   vmspipe_file_status = 0;
3868     static char  vmspipe_file[NAM$C_MAXRSS+1];
3869
3870     /* already found? Check and use ... need read+execute permission */
3871
3872     if (vmspipe_file_status == 1) {
3873         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3874          && cando_by_name_int
3875            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3876             return vmspipe_file;
3877         }
3878         vmspipe_file_status = 0;
3879     }
3880
3881     /* scan through stored @INC, $^X */
3882
3883     if (vmspipe_file_status == 0) {
3884         char file[NAM$C_MAXRSS+1];
3885         pPLOC  p = head_PLOC;
3886
3887         while (p) {
3888             char * exp_res;
3889             int dirlen;
3890             strcpy(file, p->dir);
3891             dirlen = strlen(file);
3892             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3893             file[NAM$C_MAXRSS] = '\0';
3894             p = p->next;
3895
3896             exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3897             if (!exp_res) continue;
3898
3899             if (cando_by_name_int
3900                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3901              && cando_by_name_int
3902                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3903                 vmspipe_file_status = 1;
3904                 return vmspipe_file;
3905             }
3906         }
3907         vmspipe_file_status = -1;   /* failed, use tempfiles */
3908     }
3909
3910     return 0;
3911 }
3912
3913 static FILE *
3914 vmspipe_tempfile(pTHX)
3915 {
3916     char file[NAM$C_MAXRSS+1];
3917     FILE *fp;
3918     static int index = 0;
3919     Stat_t s0, s1;
3920     int cmp_result;
3921
3922     /* create a tempfile */
3923
3924     /* we can't go from   W, shr=get to  R, shr=get without
3925        an intermediate vulnerable state, so don't bother trying...
3926
3927        and lib$spawn doesn't shr=put, so have to close the write
3928
3929        So... match up the creation date/time and the FID to
3930        make sure we're dealing with the same file
3931
3932     */
3933
3934     index++;
3935     if (!decc_filename_unix_only) {
3936       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3937       fp = fopen(file,"w");
3938       if (!fp) {
3939         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3940         fp = fopen(file,"w");
3941         if (!fp) {
3942             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3943             fp = fopen(file,"w");
3944         }
3945       }
3946      }
3947      else {
3948       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3949       fp = fopen(file,"w");
3950       if (!fp) {
3951         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3952         fp = fopen(file,"w");
3953         if (!fp) {
3954           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3955           fp = fopen(file,"w");
3956         }
3957       }
3958     }
3959     if (!fp) return 0;  /* we're hosed */
3960
3961     fprintf(fp,"$! 'f$verify(0)'\n");
3962     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3963     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3964     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3965     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3966     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3967     fprintf(fp,"$ perl_del    = \"delete\"\n");
3968     fprintf(fp,"$ pif         = \"if\"\n");
3969     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3970     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3971     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3972     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3973     fprintf(fp,"$!  --- build command line to get max possible length\n");
3974     fprintf(fp,"$c=perl_popen_cmd0\n");
3975     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3976     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3977     fprintf(fp,"$x=perl_popen_cmd3\n");
3978     fprintf(fp,"$c=c+x\n");
3979     fprintf(fp,"$ perl_on\n");
3980     fprintf(fp,"$ 'c'\n");
3981     fprintf(fp,"$ perl_status = $STATUS\n");
3982     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3983     fprintf(fp,"$ perl_exit 'perl_status'\n");
3984     fsync(fileno(fp));
3985
3986     fgetname(fp, file, 1);
3987     fstat(fileno(fp), &s0.crtl_stat);
3988     fclose(fp);
3989
3990     if (decc_filename_unix_only)
3991         int_tounixspec(file, file, NULL);
3992     fp = fopen(file,"r","shr=get");
3993     if (!fp) return 0;
3994     fstat(fileno(fp), &s1.crtl_stat);
3995
3996     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3997     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3998         fclose(fp);
3999         return 0;
4000     }
4001
4002     return fp;
4003 }
4004
4005
4006 static int vms_is_syscommand_xterm(void)
4007 {
4008     const static struct dsc$descriptor_s syscommand_dsc =
4009       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
4010
4011     const static struct dsc$descriptor_s decwdisplay_dsc =
4012       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
4013
4014     struct item_list_3 items[2];
4015     unsigned short dvi_iosb[4];
4016     unsigned long devchar;
4017     unsigned long devclass;
4018     int status;
4019
4020     /* Very simple check to guess if sys$command is a decterm? */
4021     /* First see if the DECW$DISPLAY: device exists */
4022     items[0].len = 4;
4023     items[0].code = DVI$_DEVCHAR;
4024     items[0].bufadr = &devchar;
4025     items[0].retadr = NULL;
4026     items[1].len = 0;
4027     items[1].code = 0;
4028
4029     status = sys$getdviw
4030         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
4031
4032     if ($VMS_STATUS_SUCCESS(status)) {
4033         status = dvi_iosb[0];
4034     }
4035
4036     if (!$VMS_STATUS_SUCCESS(status)) {
4037         SETERRNO(EVMSERR, status);
4038         return -1;
4039     }
4040
4041     /* If it does, then for now assume that we are on a workstation */
4042     /* Now verify that SYS$COMMAND is a terminal */
4043     /* for creating the debugger DECTerm */
4044
4045     items[0].len = 4;
4046     items[0].code = DVI$_DEVCLASS;
4047     items[0].bufadr = &devclass;
4048     items[0].retadr = NULL;
4049     items[1].len = 0;
4050     items[1].code = 0;
4051
4052     status = sys$getdviw
4053         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
4054
4055     if ($VMS_STATUS_SUCCESS(status)) {
4056         status = dvi_iosb[0];
4057     }
4058
4059     if (!$VMS_STATUS_SUCCESS(status)) {
4060         SETERRNO(EVMSERR, status);
4061         return -1;
4062     }
4063     else {
4064         if (devclass == DC$_TERM) {
4065             return 0;
4066         }
4067     }
4068     return -1;
4069 }
4070
4071 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
4072 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
4073 {
4074     int status;
4075     int ret_stat;
4076     char * ret_char;
4077     char device_name[65];
4078     unsigned short device_name_len;
4079     struct dsc$descriptor_s customization_dsc;
4080     struct dsc$descriptor_s device_name_dsc;
4081     const char * cptr;
4082     char * tptr;
4083     char customization[200];
4084     char title[40];
4085     pInfo info = NULL;
4086     char mbx1[64];
4087     unsigned short p_chan;
4088     int n;
4089     unsigned short iosb[4];
4090     struct item_list_3 items[2];
4091     const char * cust_str =
4092         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
4093     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
4094                                           DSC$K_CLASS_S, mbx1};
4095
4096      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
4097     /*---------------------------------------*/
4098     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
4099
4100
4101     /* Make sure that this is from the Perl debugger */
4102     ret_char = strstr(cmd," xterm ");
4103     if (ret_char == NULL)
4104         return NULL;
4105     cptr = ret_char + 7;
4106     ret_char = strstr(cmd,"tty");
4107     if (ret_char == NULL)
4108         return NULL;
4109     ret_char = strstr(cmd,"sleep");
4110     if (ret_char == NULL)
4111         return NULL;
4112
4113     if (decw_term_port == 0) {
4114         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
4115         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
4116         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
4117
4118        status = lib$find_image_symbol
4119                                (&filename1_dsc,
4120                                 &decw_term_port_dsc,
4121                                 (void *)&decw_term_port,
4122                                 NULL,
4123                                 0);
4124
4125         /* Try again with the other image name */
4126         if (!$VMS_STATUS_SUCCESS(status)) {
4127
4128            status = lib$find_image_symbol
4129                                (&filename2_dsc,
4130                                 &decw_term_port_dsc,
4131                                 (void *)&decw_term_port,
4132                                 NULL,
4133                                 0);
4134
4135         }
4136
4137     }
4138
4139
4140     /* No decw$term_port, give it up */
4141     if (!$VMS_STATUS_SUCCESS(status))
4142         return NULL;
4143
4144     /* Are we on a workstation? */
4145     /* to do: capture the rows / columns and pass their properties */
4146     ret_stat = vms_is_syscommand_xterm();
4147     if (ret_stat < 0)
4148         return NULL;
4149
4150     /* Make the title: */
4151     ret_char = strstr(cptr,"-title");
4152     if (ret_char != NULL) {
4153         while ((*cptr != 0) && (*cptr != '\"')) {
4154             cptr++;
4155         }
4156         if (*cptr == '\"')
4157             cptr++;
4158         n = 0;
4159         while ((*cptr != 0) && (*cptr != '\"')) {
4160             title[n] = *cptr;
4161             n++;
4162             if (n == 39) {
4163                 title[39] == 0;
4164                 break;
4165             }
4166             cptr++;
4167         }
4168         title[n] = 0;
4169     }
4170     else {
4171             /* Default title */
4172             strcpy(title,"Perl Debug DECTerm");
4173     }
4174     sprintf(customization, cust_str, title);
4175
4176     customization_dsc.dsc$a_pointer = customization;
4177     customization_dsc.dsc$w_length = strlen(customization);
4178     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4179     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
4180
4181     device_name_dsc.dsc$a_pointer = device_name;
4182     device_name_dsc.dsc$w_length = sizeof device_name -1;
4183     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4184     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
4185
4186     device_name_len = 0;
4187
4188     /* Try to create the window */
4189      status = (*decw_term_port)
4190        (NULL,
4191         NULL,
4192         &customization_dsc,
4193         &device_name_dsc,
4194         &device_name_len,
4195         NULL,
4196         NULL,
4197         NULL);
4198     if (!$VMS_STATUS_SUCCESS(status)) {
4199         SETERRNO(EVMSERR, status);
4200         return NULL;
4201     }
4202
4203     device_name[device_name_len] = '\0';
4204
4205     /* Need to set this up to look like a pipe for cleanup */
4206     n = sizeof(Info);
4207     status = lib$get_vm(&n, &info);
4208     if (!$VMS_STATUS_SUCCESS(status)) {
4209         SETERRNO(ENOMEM, status);
4210         return NULL;
4211     }
4212
4213     info->mode = *mode;
4214     info->done = FALSE;
4215     info->completion = 0;
4216     info->closing    = FALSE;
4217     info->in         = 0;
4218     info->out        = 0;
4219     info->err        = 0;
4220     info->fp         = NULL;
4221     info->useFILE    = 0;
4222     info->waiting    = 0;
4223     info->in_done    = TRUE;
4224     info->out_done   = TRUE;
4225     info->err_done   = TRUE;
4226
4227     /* Assign a channel on this so that it will persist, and not login */
4228     /* We stash this channel in the info structure for reference. */
4229     /* The created xterm self destructs when the last channel is removed */
4230     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4231     /* So leave this assigned. */
4232     device_name_dsc.dsc$w_length = device_name_len;
4233     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4234     if (!$VMS_STATUS_SUCCESS(status)) {
4235         SETERRNO(EVMSERR, status);
4236         return NULL;
4237     }
4238     info->xchan_valid = 1;
4239
4240     /* Now create a mailbox to be read by the application */
4241
4242     create_mbx(&p_chan, &d_mbx1);
4243
4244     /* write the name of the created terminal to the mailbox */
4245     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4246             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4247
4248     if (!$VMS_STATUS_SUCCESS(status)) {
4249         SETERRNO(EVMSERR, status);
4250         return NULL;
4251     }
4252
4253     info->fp  = PerlIO_open(mbx1, mode);
4254
4255     /* Done with this channel */
4256     sys$dassgn(p_chan);
4257
4258     /* If any errors, then clean up */
4259     if (!info->fp) {
4260         n = sizeof(Info);
4261         _ckvmssts_noperl(lib$free_vm(&n, &info));
4262         return NULL;
4263         }
4264
4265     /* All done */
4266     return info->fp;
4267 }
4268
4269 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4270
4271 static PerlIO *
4272 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4273 {
4274     static int handler_set_up = FALSE;
4275     PerlIO * ret_fp;
4276     unsigned long int sts, flags = CLI$M_NOWAIT;
4277     /* The use of a GLOBAL table (as was done previously) rendered
4278      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4279      * environment.  Hence we've switched to LOCAL symbol table.
4280      */
4281     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4282     int j, wait = 0, n;
4283     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4284     char *in, *out, *err, mbx[512];
4285     FILE *tpipe = 0;
4286     char tfilebuf[NAM$C_MAXRSS+1];
4287     pInfo info = NULL;
4288     char cmd_sym_name[20];
4289     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4290                                       DSC$K_CLASS_S, symbol};
4291     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4292                                       DSC$K_CLASS_S, 0};
4293     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4294                                       DSC$K_CLASS_S, cmd_sym_name};
4295     struct dsc$descriptor_s *vmscmd;
4296     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4297     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4298     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4299
4300     /* Check here for Xterm create request.  This means looking for
4301      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4302      *  is possible to create an xterm.
4303      */
4304     if (*in_mode == 'r') {
4305         PerlIO * xterm_fd;
4306
4307 #if defined(PERL_IMPLICIT_CONTEXT)
4308         /* Can not fork an xterm with a NULL context */
4309         /* This probably could never happen */
4310         xterm_fd = NULL;
4311         if (aTHX != NULL)
4312 #endif
4313         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4314         if (xterm_fd != NULL)
4315             return xterm_fd;
4316     }
4317
4318     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4319
4320     /* once-per-program initialization...
4321        note that the SETAST calls and the dual test of pipe_ef
4322        makes sure that only the FIRST thread through here does
4323        the initialization...all other threads wait until it's
4324        done.
4325
4326        Yeah, uglier than a pthread call, it's got all the stuff inline
4327        rather than in a separate routine.
4328     */
4329
4330     if (!pipe_ef) {
4331         _ckvmssts_noperl(sys$setast(0));
4332         if (!pipe_ef) {
4333             unsigned long int pidcode = JPI$_PID;
4334             $DESCRIPTOR(d_delay, RETRY_DELAY);
4335             _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4336             _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4337             _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4338         }
4339         if (!handler_set_up) {
4340           _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4341           handler_set_up = TRUE;
4342         }
4343         _ckvmssts_noperl(sys$setast(1));
4344     }
4345
4346     /* see if we can find a VMSPIPE.COM */
4347
4348     tfilebuf[0] = '@';
4349     vmspipe = find_vmspipe(aTHX);
4350     if (vmspipe) {
4351         strcpy(tfilebuf+1,vmspipe);
4352     } else {        /* uh, oh...we're in tempfile hell */
4353         tpipe = vmspipe_tempfile(aTHX);
4354         if (!tpipe) {       /* a fish popular in Boston */
4355             if (ckWARN(WARN_PIPE)) {
4356                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4357             }
4358         return NULL;
4359         }
4360         fgetname(tpipe,tfilebuf+1,1);
4361     }
4362     vmspipedsc.dsc$a_pointer = tfilebuf;
4363     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4364
4365     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4366     if (!(sts & 1)) {
4367       switch (sts) {
4368         case RMS$_FNF:  case RMS$_DNF:
4369           set_errno(ENOENT); break;
4370         case RMS$_DIR:
4371           set_errno(ENOTDIR); break;
4372         case RMS$_DEV:
4373           set_errno(ENODEV); break;
4374         case RMS$_PRV:
4375           set_errno(EACCES); break;
4376         case RMS$_SYN:
4377           set_errno(EINVAL); break;
4378         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4379           set_errno(E2BIG); break;
4380         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4381           _ckvmssts_noperl(sts); /* fall through */
4382         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4383           set_errno(EVMSERR);
4384       }
4385       set_vaxc_errno(sts);
4386       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4387         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4388       }
4389       *psts = sts;
4390       return NULL;
4391     }
4392     n = sizeof(Info);
4393     _ckvmssts_noperl(lib$get_vm(&n, &info));
4394
4395     strcpy(mode,in_mode);
4396     info->mode = *mode;
4397     info->done = FALSE;
4398     info->completion = 0;
4399     info->closing    = FALSE;
4400     info->in         = 0;
4401     info->out        = 0;
4402     info->err        = 0;
4403     info->fp         = NULL;
4404     info->useFILE    = 0;
4405     info->waiting    = 0;
4406     info->in_done    = TRUE;
4407     info->out_done   = TRUE;
4408     info->err_done   = TRUE;
4409     info->xchan      = 0;
4410     info->xchan_valid = 0;
4411
4412     in = PerlMem_malloc(VMS_MAXRSS);
4413     if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4414     out = PerlMem_malloc(VMS_MAXRSS);
4415     if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4416     err = PerlMem_malloc(VMS_MAXRSS);
4417     if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4418
4419     in[0] = out[0] = err[0] = '\0';
4420
4421     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4422         info->useFILE = 1;
4423         strcpy(p,p+1);
4424     }
4425     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4426         wait = 1;
4427         strcpy(p,p+1);
4428     }
4429
4430     if (*mode == 'r') {             /* piping from subroutine */
4431
4432         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4433         if (info->out) {
4434             info->out->pipe_done = &info->out_done;
4435             info->out_done = FALSE;
4436             info->out->info = info;
4437         }
4438         if (!info->useFILE) {
4439             info->fp  = PerlIO_open(mbx, mode);
4440         } else {
4441             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4442             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4443         }
4444
4445         if (!info->fp && info->out) {
4446             sys$cancel(info->out->chan_out);
4447
4448             while (!info->out_done) {
4449                 int done;
4450                 _ckvmssts_noperl(sys$setast(0));
4451                 done = info->out_done;
4452                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4453                 _ckvmssts_noperl(sys$setast(1));
4454                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4455             }
4456
4457             if (info->out->buf) {
4458                 n = info->out->bufsize * sizeof(char);
4459                 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4460             }
4461             n = sizeof(Pipe);
4462             _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4463             n = sizeof(Info);
4464             _ckvmssts_noperl(lib$free_vm(&n, &info));
4465             *psts = RMS$_FNF;
4466             return NULL;
4467         }
4468
4469         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4470         if (info->err) {
4471             info->err->pipe_done = &info->err_done;
4472             info->err_done = FALSE;
4473             info->err->info = info;
4474         }
4475
4476     } else if (*mode == 'w') {      /* piping to subroutine */
4477
4478         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4479         if (info->out) {
4480             info->out->pipe_done = &info->out_done;
4481             info->out_done = FALSE;
4482             info->out->info = info;
4483         }
4484
4485         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4486         if (info->err) {
4487             info->err->pipe_done = &info->err_done;
4488             info->err_done = FALSE;
4489             info->err->info = info;
4490         }
4491
4492         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4493         if (!info->useFILE) {
4494             info->fp  = PerlIO_open(mbx, mode);
4495         } else {
4496             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4497             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4498         }
4499
4500         if (info->in) {
4501             info->in->pipe_done = &info->in_done;
4502             info->in_done = FALSE;
4503             info->in->info = info;
4504         }
4505
4506         /* error cleanup */
4507         if (!info->fp && info->in) {
4508             info->done = TRUE;
4509             _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4510                                       0, 0, 0, 0, 0, 0, 0, 0));
4511
4512             while (!info->in_done) {
4513                 int done;
4514                 _ckvmssts_noperl(sys$setast(0));
4515                 done = info->in_done;
4516                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4517                 _ckvmssts_noperl(sys$setast(1));
4518                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4519             }
4520
4521             if (info->in->buf) {
4522                 n = info->in->bufsize * sizeof(char);
4523                 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4524             }
4525             n = sizeof(Pipe);
4526             _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4527             n = sizeof(Info);
4528             _ckvmssts_noperl(lib$free_vm(&n, &info));
4529             *psts = RMS$_FNF;
4530             return NULL;
4531         }
4532
4533
4534     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4535         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4536         if (info->out) {
4537             info->out->pipe_done = &info->out_done;
4538             info->out_done = FALSE;
4539             info->out->info = info;
4540         }
4541
4542         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4543         if (info->err) {
4544             info->err->pipe_done = &info->err_done;
4545             info->err_done = FALSE;
4546             info->err->info = info;
4547         }
4548     }
4549
4550     symbol[MAX_DCL_SYMBOL] = '\0';
4551
4552     strncpy(symbol, in, MAX_DCL_SYMBOL);
4553     d_symbol.dsc$w_length = strlen(symbol);
4554     _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4555
4556     strncpy(symbol, err, MAX_DCL_SYMBOL);
4557     d_symbol.dsc$w_length = strlen(symbol);
4558     _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4559
4560     strncpy(symbol, out, MAX_DCL_SYMBOL);
4561     d_symbol.dsc$w_length = strlen(symbol);
4562     _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4563
4564     /* Done with the names for the pipes */
4565     PerlMem_free(err);
4566     PerlMem_free(out);
4567     PerlMem_free(in);
4568
4569     p = vmscmd->dsc$a_pointer;
4570     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4571     if (*p == '$') p++;                         /* remove leading $ */
4572     while (*p == ' ' || *p == '\t') p++;
4573
4574     for (j = 0; j < 4; j++) {
4575         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4576         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4577
4578     strncpy(symbol, p, MAX_DCL_SYMBOL);
4579     d_symbol.dsc$w_length = strlen(symbol);
4580     _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4581
4582         if (strlen(p) > MAX_DCL_SYMBOL) {
4583             p += MAX_DCL_SYMBOL;
4584         } else {
4585             p += strlen(p);
4586         }
4587     }
4588     _ckvmssts_noperl(sys$setast(0));
4589     info->next=open_pipes;  /* prepend to list */
4590     open_pipes=info;
4591     _ckvmssts_noperl(sys$setast(1));
4592     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4593      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4594      * have SYS$COMMAND if we need it.
4595      */
4596     _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4597                       0, &info->pid, &info->completion,
4598                       0, popen_completion_ast,info,0,0,0));
4599
4600     /* if we were using a tempfile, close it now */
4601
4602     if (tpipe) fclose(tpipe);
4603
4604     /* once the subprocess is spawned, it has copied the symbols and
4605        we can get rid of ours */
4606
4607     for (j = 0; j < 4; j++) {
4608         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4609         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4610     _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4611     }
4612     _ckvmssts_noperl(lib$delete_symbol(&d_sym_in,  &table));
4613     _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4614     _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4615     vms_execfree(vmscmd);
4616
4617 #ifdef PERL_IMPLICIT_CONTEXT
4618     if (aTHX)
4619 #endif
4620     PL_forkprocess = info->pid;
4621
4622     ret_fp = info->fp;
4623     if (wait) {
4624          dSAVEDERRNO;
4625          int done = 0;
4626          while (!done) {
4627              _ckvmssts_noperl(sys$setast(0));
4628              done = info->done;
4629              if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4630              _ckvmssts_noperl(sys$setast(1));
4631              if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4632          }
4633         *psts = info->completion;
4634 /* Caller thinks it is open and tries to close it. */
4635 /* This causes some problems, as it changes the error status */
4636 /*        my_pclose(info->fp); */
4637
4638          /* If we did not have a file pointer open, then we have to */
4639          /* clean up here or eventually we will run out of something */
4640          SAVE_ERRNO;
4641          if (info->fp == NULL) {
4642              my_pclose_pinfo(aTHX_ info);
4643          }
4644          RESTORE_ERRNO;
4645
4646     } else {
4647         *psts = info->pid;
4648     }
4649     return ret_fp;
4650 }  /* end of safe_popen */
4651
4652
4653 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4654 PerlIO *
4655 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4656 {
4657     int sts;
4658     TAINT_ENV();
4659     TAINT_PROPER("popen");
4660     PERL_FLUSHALL_FOR_CHILD;
4661     return safe_popen(aTHX_ cmd,mode,&sts);
4662 }
4663
4664 /*}}}*/
4665
4666
4667 /* Routine to close and cleanup a pipe info structure */
4668
4669 static I32 my_pclose_pinfo(pTHX_ pInfo info) {
4670
4671     unsigned long int retsts;
4672     int done, iss, n;
4673     int status;
4674     pInfo next, last;
4675
4676     /* If we were writing to a subprocess, insure that someone reading from
4677      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4678      * produce an EOF record in the mailbox.
4679      *
4680      *  well, at least sometimes it *does*, so we have to watch out for
4681      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4682      */
4683      if (info->fp) {
4684         if (!info->useFILE
4685 #if defined(USE_ITHREADS)
4686           && my_perl
4687 #endif
4688           && PL_perlio_fd_refcnt)
4689             PerlIO_flush(info->fp);
4690         else
4691             fflush((FILE *)info->fp);
4692     }
4693
4694     _ckvmssts(sys$setast(0));
4695      info->closing = TRUE;
4696      done = info->done && info->in_done && info->out_done && info->err_done;
4697      /* hanging on write to Perl's input? cancel it */
4698      if (info->mode == 'r' && info->out && !info->out_done) {
4699         if (info->out->chan_out) {
4700             _ckvmssts(sys$cancel(info->out->chan_out));
4701             if (!info->out->chan_in) {   /* EOF generation, need AST */
4702                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4703             }
4704         }
4705      }
4706      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4707          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4708                            0, 0, 0, 0, 0, 0));
4709     _ckvmssts(sys$setast(1));
4710     if (info->fp) {
4711      if (!info->useFILE
4712 #if defined(USE_ITHREADS)
4713          && my_perl
4714 #endif
4715          && PL_perlio_fd_refcnt)
4716         PerlIO_close(info->fp);
4717      else
4718         fclose((FILE *)info->fp);
4719     }
4720      /*
4721         we have to wait until subprocess completes, but ALSO wait until all
4722         the i/o completes...otherwise we'll be freeing the "info" structure
4723         that the i/o ASTs could still be using...
4724      */
4725
4726      while (!done) {
4727          _ckvmssts(sys$setast(0));
4728          done = info->done && info->in_done && info->out_done && info->err_done;
4729          if (!done) _ckvmssts(sys$clref(pipe_ef));
4730          _ckvmssts(sys$setast(1));
4731          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4732      }
4733      retsts = info->completion;
4734
4735     /* remove from list of open pipes */
4736     _ckvmssts(sys$setast(0));
4737     last = NULL;
4738     for (next = open_pipes; next != NULL; last = next, next = next->next) {
4739         if (next == info)
4740             break;
4741     }
4742
4743     if (last)
4744         last->next = info->next;
4745     else
4746         open_pipes = info->next;
4747     _ckvmssts(sys$setast(1));
4748
4749     /* free buffers and structures */
4750
4751     if (info->in) {
4752         if (info->in->buf) {
4753             n = info->in->bufsize * sizeof(char);
4754             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4755         }
4756         n = sizeof(Pipe);
4757         _ckvmssts(lib$free_vm(&n, &info->in));
4758     }
4759     if (info->out) {
4760         if (info->out->buf) {
4761             n = info->out->bufsize * sizeof(char);
4762             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4763         }
4764         n = sizeof(Pipe);
4765         _ckvmssts(lib$free_vm(&n, &info->out));
4766     }
4767     if (info->err) {
4768         if (info->err->buf) {
4769             n = info->err->bufsize * sizeof(char);
4770             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4771         }
4772         n = sizeof(Pipe);
4773         _ckvmssts(lib$free_vm(&n, &info->err));
4774     }
4775     n = sizeof(Info);
4776     _ckvmssts(lib$free_vm(&n, &info));
4777
4778     return retsts;
4779 }
4780
4781
4782 /*{{{  I32 my_pclose(PerlIO *fp)*/
4783 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4784 {
4785     pInfo info, last = NULL;
4786     I32 ret_status;
4787
4788     /* Fixme - need ast and mutex protection here */
4789     for (info = open_pipes; info != NULL; last = info, info = info->next)
4790         if (info->fp == fp) break;
4791
4792     if (info == NULL) {  /* no such pipe open */
4793       set_errno(ECHILD); /* quoth POSIX */
4794       set_vaxc_errno(SS$_NONEXPR);
4795       return -1;
4796     }
4797
4798     ret_status = my_pclose_pinfo(aTHX_ info);
4799
4800     return ret_status;
4801
4802 }  /* end of my_pclose() */
4803
4804 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4805   /* Roll our own prototype because we want this regardless of whether
4806    * _VMS_WAIT is defined.
4807    */
4808   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4809 #endif
4810 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4811    created with popen(); otherwise partially emulate waitpid() unless
4812    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4813    Also check processes not considered by the CRTL waitpid().
4814  */
4815 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4816 Pid_t
4817 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4818 {
4819     pInfo info;
4820     int done;
4821     int sts;
4822     int j;
4823
4824     if (statusp) *statusp = 0;
4825
4826     for (info = open_pipes; info != NULL; info = info->next)
4827         if (info->pid == pid) break;
4828
4829     if (info != NULL) {  /* we know about this child */
4830       while (!info->done) {
4831           _ckvmssts(sys$setast(0));
4832           done = info->done;
4833           if (!done) _ckvmssts(sys$clref(pipe_ef));
4834           _ckvmssts(sys$setast(1));
4835           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4836       }
4837
4838       if (statusp) *statusp = info->completion;
4839       return pid;
4840     }
4841
4842     /* child that already terminated? */
4843
4844     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4845         if (closed_list[j].pid == pid) {
4846             if (statusp) *statusp = closed_list[j].completion;
4847             return pid;
4848         }
4849     }
4850
4851     /* fall through if this child is not one of our own pipe children */
4852
4853 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4854
4855       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4856        * in 7.2 did we get a version that fills in the VMS completion
4857        * status as Perl has always tried to do.
4858        */
4859
4860       sts = __vms_waitpid( pid, statusp, flags );
4861
4862       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4863          return sts;
4864
4865       /* If the real waitpid tells us the child does not exist, we
4866        * fall through here to implement waiting for a child that
4867        * was created by some means other than exec() (say, spawned
4868        * from DCL) or to wait for a process that is not a subprocess
4869        * of the current process.
4870        */
4871
4872 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4873
4874     {
4875       $DESCRIPTOR(intdsc,"0 00:00:01");
4876       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4877       unsigned long int pidcode = JPI$_PID, mypid;
4878       unsigned long int interval[2];
4879       unsigned int jpi_iosb[2];
4880       struct itmlst_3 jpilist[2] = {
4881           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4882           {                      0,         0,                 0, 0}
4883       };
4884
4885       if (pid <= 0) {
4886         /* Sorry folks, we don't presently implement rooting around for
4887            the first child we can find, and we definitely don't want to
4888            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4889          */
4890         set_errno(ENOTSUP);
4891         return -1;
4892       }
4893
4894       /* Get the owner of the child so I can warn if it's not mine. If the
4895        * process doesn't exist or I don't have the privs to look at it,
4896        * I can go home early.
4897        */
4898       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4899       if (sts & 1) sts = jpi_iosb[0];
4900       if (!(sts & 1)) {
4901         switch (sts) {
4902             case SS$_NONEXPR:
4903                 set_errno(ECHILD);
4904                 break;
4905             case SS$_NOPRIV:
4906                 set_errno(EACCES);
4907                 break;
4908             default:
4909                 _ckvmssts(sts);
4910         }
4911         set_vaxc_errno(sts);
4912         return -1;
4913       }
4914
4915       if (ckWARN(WARN_EXEC)) {
4916         /* remind folks they are asking for non-standard waitpid behavior */
4917         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4918         if (ownerpid != mypid)
4919           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4920                       "waitpid: process %x is not a child of process %x",
4921                       pid,mypid);
4922       }
4923
4924       /* simply check on it once a second until it's not there anymore. */
4925
4926       _ckvmssts(sys$bintim(&intdsc,interval));
4927       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4928             _ckvmssts(sys$schdwk(0,0,interval,0));
4929             _ckvmssts(sys$hiber());
4930       }
4931       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4932
4933       _ckvmssts(sts);
4934       return pid;
4935     }
4936 }  /* end of waitpid() */
4937 /*}}}*/
4938 /*}}}*/
4939 /*}}}*/
4940
4941 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4942 char *
4943 my_gconvert(double val, int ndig, int trail, char *buf)
4944 {
4945   static char __gcvtbuf[DBL_DIG+1];
4946   char *loc;
4947
4948   loc = buf ? buf : __gcvtbuf;
4949
4950 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4951   if (val < 1) {
4952     sprintf(loc,"%.*g",ndig,val);
4953     return loc;
4954   }
4955 #endif
4956
4957   if (val) {
4958     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4959     return gcvt(val,ndig,loc);
4960   }
4961   else {
4962     loc[0] = '0'; loc[1] = '\0';
4963     return loc;
4964   }
4965
4966 }
4967 /*}}}*/
4968
4969 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4970 static int rms_free_search_context(struct FAB * fab)
4971 {
4972 struct NAM * nam;
4973
4974     nam = fab->fab$l_nam;
4975     nam->nam$b_nop |= NAM$M_SYNCHK;
4976     nam->nam$l_rlf = NULL;
4977     fab->fab$b_dns = 0;
4978     return sys$parse(fab, NULL, NULL);
4979 }
4980
4981 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4982 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4983 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4984 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4985 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4986 #define rms_nam_esll(nam) nam.nam$b_esl
4987 #define rms_nam_esl(nam) nam.nam$b_esl
4988 #define rms_nam_name(nam) nam.nam$l_name
4989 #define rms_nam_namel(nam) nam.nam$l_name
4990 #define rms_nam_type(nam) nam.nam$l_type
4991 #define rms_nam_typel(nam) nam.nam$l_type
4992 #define rms_nam_ver(nam) nam.nam$l_ver
4993 #define rms_nam_verl(nam) nam.nam$l_ver
4994 #define rms_nam_rsll(nam) nam.nam$b_rsl
4995 #define rms_nam_rsl(nam) nam.nam$b_rsl
4996 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4997 #define rms_set_fna(fab, nam, name, size) \
4998         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4999 #define rms_get_fna(fab, nam) fab.fab$l_fna
5000 #define rms_set_dna(fab, nam, name, size) \
5001         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
5002 #define rms_nam_dns(fab, nam) fab.fab$b_dns
5003 #define rms_set_esa(nam, name, size) \
5004         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
5005 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
5006         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
5007 #define rms_set_rsa(nam, name, size) \
5008         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
5009 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
5010         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
5011 #define rms_nam_name_type_l_size(nam) \
5012         (nam.nam$b_name + nam.nam$b_type)
5013 #else
5014 static int rms_free_search_context(struct FAB * fab)
5015 {
5016 struct NAML * nam;
5017
5018     nam = fab->fab$l_naml;
5019     nam->naml$b_nop |= NAM$M_SYNCHK;
5020     nam->naml$l_rlf = NULL;
5021     nam->naml$l_long_defname_size = 0;
5022
5023     fab->fab$b_dns = 0;
5024     return sys$parse(fab, NULL, NULL);
5025 }
5026
5027 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
5028 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
5029 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
5030 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
5031 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
5032 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
5033 #define rms_nam_esl(nam) nam.naml$b_esl
5034 #define rms_nam_name(nam) nam.naml$l_name
5035 #define rms_nam_namel(nam) nam.naml$l_long_name
5036 #define rms_nam_type(nam) nam.naml$l_type
5037 #define rms_nam_typel(nam) nam.naml$l_long_type
5038 #define rms_nam_ver(nam) nam.naml$l_ver
5039 #define rms_nam_verl(nam) nam.naml$l_long_ver
5040 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
5041 #define rms_nam_rsl(nam) nam.naml$b_rsl
5042 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
5043 #define rms_set_fna(fab, nam, name, size) \
5044         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
5045         nam.naml$l_long_filename_size = size; \
5046         nam.naml$l_long_filename = name;}
5047 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
5048 #define rms_set_dna(fab, nam, name, size) \
5049         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
5050         nam.naml$l_long_defname_size = size; \
5051         nam.naml$l_long_defname = name; }
5052 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
5053 #define rms_set_esa(nam, name, size) \
5054         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
5055         nam.naml$l_long_expand_alloc = size; \
5056         nam.naml$l_long_expand = name; }
5057 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
5058         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
5059         nam.naml$l_long_expand = l_name; \
5060         nam.naml$l_long_expand_alloc = l_size; }
5061 #define rms_set_rsa(nam, name, size) \
5062         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
5063         nam.naml$l_long_result = name; \
5064         nam.naml$l_long_result_alloc = size; }
5065 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
5066         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
5067         nam.naml$l_long_result = l_name; \
5068         nam.naml$l_long_result_alloc = l_size; }
5069 #define rms_nam_name_type_l_size(nam) \
5070         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
5071 #endif
5072
5073
5074 /* rms_erase
5075  * The CRTL for 8.3 and later can create symbolic links in any mode,
5076  * however in 8.3 the unlink/remove/delete routines will only properly handle
5077  * them if one of the PCP modes is active.
5078  */
5079 static int rms_erase(const char * vmsname)
5080 {
5081   int status;
5082   struct FAB myfab = cc$rms_fab;
5083   rms_setup_nam(mynam);
5084
5085   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
5086   rms_bind_fab_nam(myfab, mynam);
5087
5088 #ifdef NAML$M_OPEN_SPECIAL
5089   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5090 #endif
5091
5092   status = sys$erase(&myfab, 0, 0);
5093
5094   return status;
5095 }
5096
5097
5098 static int
5099 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
5100                     const struct dsc$descriptor_s * vms_dst_dsc,
5101                     unsigned long flags)
5102 {
5103     /*  VMS and UNIX handle file permissions differently and the
5104      * the same ACL trick may be needed for renaming files,
5105      * especially if they are directories.
5106      */
5107
5108    /* todo: get kill_file and rename to share common code */
5109    /* I can not find online documentation for $change_acl
5110     * it appears to be replaced by $set_security some time ago */
5111
5112 const unsigned int access_mode = 0;
5113 $DESCRIPTOR(obj_file_dsc,"FILE");
5114 char *vmsname;
5115 char *rslt;
5116 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
5117 int aclsts, fndsts, rnsts = -1;
5118 unsigned int ctx = 0;
5119 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5120 struct dsc$descriptor_s * clean_dsc;
5121
5122 struct myacedef {
5123     unsigned char myace$b_length;
5124     unsigned char myace$b_type;
5125     unsigned short int myace$w_flags;
5126     unsigned long int myace$l_access;
5127     unsigned long int myace$l_ident;
5128 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
5129              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
5130              0},
5131              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
5132
5133 struct item_list_3
5134         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
5135                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
5136                       {0,0,0,0}},
5137         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
5138         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
5139                      {0,0,0,0}};
5140
5141
5142     /* Expand the input spec using RMS, since we do not want to put
5143      * ACLs on the target of a symbolic link */
5144     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
5145     if (vmsname == NULL)
5146         return SS$_INSFMEM;
5147
5148     rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
5149                         vmsname,
5150                         PERL_RMSEXPAND_M_SYMLINK);
5151     if (rslt == NULL) {
5152         PerlMem_free(vmsname);
5153         return SS$_INSFMEM;
5154     }
5155
5156     /* So we get our own UIC to use as a rights identifier,
5157      * and the insert an ACE at the head of the ACL which allows us
5158      * to delete the file.
5159      */
5160     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
5161
5162     fildsc.dsc$w_length = strlen(vmsname);
5163     fildsc.dsc$a_pointer = vmsname;
5164     ctx = 0;
5165     newace.myace$l_ident = oldace.myace$l_ident;
5166     rnsts = SS$_ABORT;
5167
5168     /* Grab any existing ACEs with this identifier in case we fail */
5169     clean_dsc = &fildsc;
5170     aclsts = fndsts = sys$get_security(&obj_file_dsc,
5171                                &fildsc,
5172                                NULL,
5173                                OSS$M_WLOCK,
5174                                findlst,
5175                                &ctx,
5176                                &access_mode);
5177
5178     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
5179         /* Add the new ACE . . . */
5180
5181         /* if the sys$get_security succeeded, then ctx is valid, and the
5182          * object/file descriptors will be ignored.  But otherwise they
5183          * are needed
5184          */
5185         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
5186                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
5187         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5188             set_errno(EVMSERR);
5189             set_vaxc_errno(aclsts);
5190             PerlMem_free(vmsname);
5191             return aclsts;
5192         }
5193
5194         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5195                                 NULL, NULL,
5196                                 &flags,
5197                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5198
5199         if ($VMS_STATUS_SUCCESS(rnsts)) {
5200             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5201         }
5202
5203         /* Put things back the way they were. */
5204         ctx = 0;
5205         aclsts = sys$get_security(&obj_file_dsc,
5206                                   clean_dsc,
5207                                   NULL,
5208                                   OSS$M_WLOCK,
5209                                   findlst,
5210                                   &ctx,
5211                                   &access_mode);
5212
5213         if ($VMS_STATUS_SUCCESS(aclsts)) {
5214         int sec_flags;
5215
5216             sec_flags = 0;
5217             if (!$VMS_STATUS_SUCCESS(fndsts))
5218                 sec_flags = OSS$M_RELCTX;
5219
5220             /* Get rid of the new ACE */
5221             aclsts = sys$set_security(NULL, NULL, NULL,
5222                                   sec_flags, dellst, &ctx, &access_mode);
5223
5224             /* If there was an old ACE, put it back */
5225             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5226                 addlst[0].bufadr = &oldace;
5227                 aclsts = sys$set_security(NULL, NULL, NULL,
5228                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
5229                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5230                     set_errno(EVMSERR);
5231                     set_vaxc_errno(aclsts);
5232                     rnsts = aclsts;
5233                 }
5234             } else {
5235             int aclsts2;
5236
5237                 /* Try to clear the lock on the ACL list */
5238                 aclsts2 = sys$set_security(NULL, NULL, NULL,
5239                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
5240
5241                 /* Rename errors are most important */
5242                 if (!$VMS_STATUS_SUCCESS(rnsts))
5243                     aclsts = rnsts;
5244                 set_errno(EVMSERR);
5245                 set_vaxc_errno(aclsts);
5246                 rnsts = aclsts;
5247             }
5248         }
5249         else {
5250             if (aclsts != SS$_ACLEMPTY)
5251                 rnsts = aclsts;
5252         }
5253     }
5254     else
5255         rnsts = fndsts;
5256
5257     PerlMem_free(vmsname);
5258     return rnsts;
5259 }
5260
5261
5262 /*{{{int rename(const char *, const char * */
5263 /* Not exactly what X/Open says to do, but doing it absolutely right
5264  * and efficiently would require a lot more work.  This should be close
5265  * enough to pass all but the most strict X/Open compliance test.
5266  */
5267 int
5268 Perl_rename(pTHX_ const char *src, const char * dst)
5269 {
5270 int retval;
5271 int pre_delete = 0;
5272 int src_sts;
5273 int dst_sts;
5274 Stat_t src_st;
5275 Stat_t dst_st;
5276
5277     /* Validate the source file */
5278     src_sts = flex_lstat(src, &src_st);
5279     if (src_sts != 0) {
5280
5281         /* No source file or other problem */
5282         return src_sts;
5283     }
5284     if (src_st.st_devnam[0] == 0)  {
5285         /* This may be possible so fail if it is seen. */
5286         errno = EIO;
5287         return -1;
5288     }
5289
5290     dst_sts = flex_lstat(dst, &dst_st);
5291     if (dst_sts == 0) {
5292
5293         if (dst_st.st_dev != src_st.st_dev) {
5294             /* Must be on the same device */
5295             errno = EXDEV;
5296             return -1;
5297         }
5298
5299         /* VMS_INO_T_COMPARE is true if the inodes are different
5300          * to match the output of memcmp
5301          */
5302
5303         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5304             /* That was easy, the files are the same! */
5305             return 0;
5306         }
5307
5308         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5309             /* If source is a directory, so must be dest */
5310                 errno = EISDIR;
5311                 return -1;
5312         }
5313
5314     }
5315
5316
5317     if ((dst_sts == 0) &&
5318         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5319
5320         /* We have issues here if vms_unlink_all_versions is set
5321          * If the destination exists, and is not a directory, then
5322          * we must delete in advance.
5323          *
5324          * If the src is a directory, then we must always pre-delete
5325          * the destination.
5326          *
5327          * If we successfully delete the dst in advance, and the rename fails
5328          * X/Open requires that errno be EIO.
5329          *
5330          */
5331
5332         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5333             int d_sts;
5334             d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam,
5335                                      S_ISDIR(dst_st.st_mode));
5336
5337            /* Need to delete all versions ? */
5338            if ((d_sts == 0) && (vms_unlink_all_versions == 1)) {
5339                 int i = 0;
5340
5341                 while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) {
5342                     d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 0);
5343                     if (d_sts != 0)
5344                         break;
5345                     i++;
5346
5347                     /* Make sure that we do not loop forever */
5348                     if (i > 32767) {
5349                         errno = EIO;
5350                         d_sts = -1;
5351                         break;
5352                     }
5353                 }
5354            }
5355
5356             if (d_sts != 0)
5357                 return d_sts;
5358
5359             /* We killed the destination, so only errno now is EIO */
5360             pre_delete = 1;
5361         }
5362     }
5363
5364     /* Originally the idea was to call the CRTL rename() and only
5365      * try the lib$rename_file if it failed.
5366      * It turns out that there are too many variants in what the
5367      * the CRTL rename might do, so only use lib$rename_file
5368      */
5369     retval = -1;
5370
5371     {
5372         /* Is the source and dest both in VMS format */
5373         /* if the source is a directory, then need to fileify */
5374         /*  and dest must be a directory or non-existant. */
5375
5376         char * vms_dst;
5377         int sts;
5378         char * ret_str;
5379         unsigned long flags;
5380         struct dsc$descriptor_s old_file_dsc;
5381         struct dsc$descriptor_s new_file_dsc;
5382
5383         /* We need to modify the src and dst depending
5384          * on if one or more of them are directories.
5385          */
5386
5387         vms_dst = PerlMem_malloc(VMS_MAXRSS);
5388         if (vms_dst == NULL)
5389             _ckvmssts_noperl(SS$_INSFMEM);
5390
5391         if (S_ISDIR(src_st.st_mode)) {
5392         char * ret_str;
5393         char * vms_dir_file;
5394
5395             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5396             if (vms_dir_file == NULL)
5397                 _ckvmssts_noperl(SS$_INSFMEM);
5398
5399             /* If the dest is a directory, we must remove it
5400             if (dst_sts == 0) {
5401                 int d_sts;
5402                 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1);
5403                 if (d_sts != 0) {
5404                     PerlMem_free(vms_dst);
5405                     errno = EIO;
5406                     return sts;
5407                 }
5408
5409                 pre_delete = 1;
5410             }
5411
5412            /* The dest must be a VMS file specification */
5413            ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5414            if (ret_str == NULL) {
5415                 PerlMem_free(vms_dst);
5416                 errno = EIO;
5417                 return -1;
5418            }
5419
5420             /* The source must be a file specification */
5421             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5422             if (vms_dir_file == NULL)
5423                 _ckvmssts_noperl(SS$_INSFMEM);
5424
5425             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5426             if (ret_str == NULL) {
5427                 PerlMem_free(vms_dst);
5428                 PerlMem_free(vms_dir_file);
5429                 errno = EIO;
5430                 return -1;
5431             }
5432             PerlMem_free(vms_dst);
5433             vms_dst = vms_dir_file;
5434
5435         } else {
5436             /* File to file or file to new dir */
5437
5438             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5439                 /* VMS pathify a dir target */
5440                 ret_str = int_tovmspath(dst, vms_dst, NULL);
5441                 if (ret_str == NULL) {
5442                     PerlMem_free(vms_dst);
5443                     errno = EIO;
5444                     return -1;
5445                 }
5446             } else {
5447                 char * v_spec, * r_spec, * d_spec, * n_spec;
5448                 char * e_spec, * vs_spec;
5449                 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5450
5451                 /* fileify a target VMS file specification */
5452                 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5453                 if (ret_str == NULL) {
5454                     PerlMem_free(vms_dst);
5455                     errno = EIO;
5456                     return -1;
5457                 }
5458
5459                 sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len,
5460                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5461                              &e_len, &vs_spec, &vs_len);
5462                 if (sts == 0) {
5463                      if (e_len == 0) {
5464                          /* Get rid of the version */
5465                          if (vs_len != 0) {
5466                              *vs_spec = '\0';
5467                          }
5468                          /* Need to specify a '.' so that the extension */
5469                          /* is not inherited */
5470                          strcat(vms_dst,".");
5471                      }
5472                 }
5473             }
5474         }
5475
5476         old_file_dsc.dsc$a_pointer = src_st.st_devnam;
5477         old_file_dsc.dsc$w_length = strlen(src_st.st_devnam);
5478         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5479         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5480
5481         new_file_dsc.dsc$a_pointer = vms_dst;
5482         new_file_dsc.dsc$w_length = strlen(vms_dst);
5483         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5484         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5485
5486         flags = 0;
5487 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5488         flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5489 #endif
5490
5491         sts = lib$rename_file(&old_file_dsc,
5492                               &new_file_dsc,
5493                               NULL, NULL,
5494                               &flags,
5495                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5496         if (!$VMS_STATUS_SUCCESS(sts)) {
5497
5498            /* We could have failed because VMS style permissions do not
5499             * permit renames that UNIX will allow.  Just like the hack
5500             * in for kill_file.
5501             */
5502            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5503         }
5504
5505         PerlMem_free(vms_dst);
5506         if (!$VMS_STATUS_SUCCESS(sts)) {
5507             errno = EIO;
5508             return -1;
5509         }
5510         retval = 0;
5511     }
5512
5513     if (vms_unlink_all_versions) {
5514         /* Now get rid of any previous versions of the source file that
5515          * might still exist
5516          */
5517         int i = 0;
5518         dSAVEDERRNO;
5519         SAVE_ERRNO;
5520         src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5521                                    S_ISDIR(src_st.st_mode));
5522         while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) {
5523              src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5524                                        S_ISDIR(src_st.st_mode));
5525              if (src_sts != 0)
5526                  break;
5527              i++;
5528
5529              /* Make sure that we do not loop forever */
5530              if (i > 32767) {
5531                  src_sts = -1;
5532                  break;
5533              }
5534         }
5535         RESTORE_ERRNO;
5536     }
5537
5538     /* We deleted the destination, so must force the error to be EIO */
5539     if ((retval != 0) && (pre_delete != 0))
5540         errno = EIO;
5541
5542     return retval;
5543 }
5544 /*}}}*/
5545
5546
5547 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5548 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5549  * to expand file specification.  Allows for a single default file
5550  * specification and a simple mask of options.  If outbuf is non-NULL,
5551  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5552  * the resultant file specification is placed.  If outbuf is NULL, the
5553  * resultant file specification is placed into a static buffer.
5554  * The third argument, if non-NULL, is taken to be a default file
5555  * specification string.  The fourth argument is unused at present.
5556  * rmesexpand() returns the address of the resultant string if
5557  * successful, and NULL on error.
5558  *
5559  * New functionality for previously unused opts value:
5560  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5561  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5562  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5563  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5564  */
5565 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5566
5567 static char *
5568 int_rmsexpand
5569    (const char *filespec,
5570     char *outbuf,
5571     const char *defspec,
5572     unsigned opts,
5573     int * fs_utf8,
5574     int * dfs_utf8)
5575 {
5576   char * ret_spec;
5577   const char * in_spec;
5578   char * spec_buf;
5579   const char * def_spec;
5580   char * vmsfspec, *vmsdefspec;
5581   char * esa;
5582   char * esal = NULL;
5583   char * outbufl;
5584   struct FAB myfab = cc$rms_fab;
5585   rms_setup_nam(mynam);
5586   STRLEN speclen;
5587   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5588   int sts;
5589
5590   /* temp hack until UTF8 is actually implemented */
5591   if (fs_utf8 != NULL)
5592     *fs_utf8 = 0;
5593
5594   if (!filespec || !*filespec) {
5595     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5596     return NULL;
5597   }
5598
5599   vmsfspec = NULL;
5600   vmsdefspec = NULL;
5601   outbufl = NULL;
5602
5603   in_spec = filespec;
5604   isunix = 0;
5605   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5606       char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5607       int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5608
5609       /* If this is a UNIX file spec, convert it to VMS */
5610       sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5611                            &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5612                            &e_len, &vs_spec, &vs_len);
5613       if (sts != 0) {
5614           isunix = 1;
5615           char * ret_spec;
5616
5617           vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5618           if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5619           ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5620           if (ret_spec == NULL) {
5621               PerlMem_free(vmsfspec);
5622               return NULL;
5623           }
5624           in_spec = (const char *)vmsfspec;
5625
5626           /* Unless we are forcing to VMS format, a UNIX input means
5627            * UNIX output, and that requires long names to be used
5628            */
5629           if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5630 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5631               opts |= PERL_RMSEXPAND_M_LONG;
5632 #else
5633               NOOP;
5634 #endif
5635           else
5636               isunix = 0;
5637       }
5638
5639   }
5640
5641   rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
5642   rms_bind_fab_nam(myfab, mynam);
5643
5644   /* Process the default file specification if present */
5645   def_spec = defspec;
5646   if (defspec && *defspec) {
5647     int t_isunix;
5648     t_isunix = is_unix_filespec(defspec);
5649     if (t_isunix) {
5650       vmsdefspec = PerlMem_malloc(VMS_MAXRSS);
5651       if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5652       ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5653
5654       if (ret_spec == NULL) {
5655           /* Clean up and bail */
5656           PerlMem_free(vmsdefspec);
5657           if (vmsfspec != NULL)
5658               PerlMem_free(vmsfspec);
5659               return NULL;
5660           }
5661           def_spec = (const char *)vmsdefspec;
5662       }
5663       rms_set_dna(myfab, mynam,
5664                   (char *)def_spec, strlen(def_spec)); /* cast ok */
5665   }
5666
5667   /* Now we need the expansion buffers */
5668   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5669   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5670 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5671   esal = PerlMem_malloc(VMS_MAXRSS);
5672   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5673 #endif
5674   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5675
5676   /* If a NAML block is used RMS always writes to the long and short
5677    * addresses unless you suppress the short name.
5678    */
5679 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5680   outbufl = PerlMem_malloc(VMS_MAXRSS);
5681   if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5682 #endif
5683    rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5684
5685 #ifdef NAM$M_NO_SHORT_UPCASE
5686   if (decc_efs_case_preserve)
5687     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5688 #endif
5689
5690    /* We may not want to follow symbolic links */
5691 #ifdef NAML$M_OPEN_SPECIAL
5692   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5693     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5694 #endif
5695
5696   /* First attempt to parse as an existing file */
5697   retsts = sys$parse(&myfab,0,0);
5698   if (!(retsts & STS$K_SUCCESS)) {
5699
5700     /* Could not find the file, try as syntax only if error is not fatal */
5701     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5702     if (retsts == RMS$_DNF ||
5703         retsts == RMS$_DIR ||
5704         retsts == RMS$_DEV ||
5705         retsts == RMS$_PRV) {
5706       retsts = sys$parse(&myfab,0,0);
5707       if (retsts & STS$K_SUCCESS) goto int_expanded;
5708     }
5709
5710      /* Still could not parse the file specification */
5711     /*----------------------------------------------*/
5712     sts = rms_free_search_context(&myfab); /* Free search context */
5713     if (vmsdefspec != NULL)
5714         PerlMem_free(vmsdefspec);
5715     if (vmsfspec != NULL)
5716         PerlMem_free(vmsfspec);
5717     if (outbufl != NULL)
5718         PerlMem_free(outbufl);
5719     PerlMem_free(esa);
5720     if (esal != NULL)
5721         PerlMem_free(esal);
5722     set_vaxc_errno(retsts);
5723     if      (retsts == RMS$_PRV) set_errno(EACCES);
5724     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5725     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5726     else                         set_errno(EVMSERR);
5727     return NULL;
5728   }
5729   retsts = sys$search(&myfab,0,0);
5730   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5731     sts = rms_free_search_context(&myfab); /* Free search context */
5732     if (vmsdefspec != NULL)
5733         PerlMem_free(vmsdefspec);
5734     if (vmsfspec != NULL)
5735         PerlMem_free(vmsfspec);
5736     if (outbufl != NULL)
5737         PerlMem_free(outbufl);
5738     PerlMem_free(esa);
5739     if (esal != NULL)
5740         PerlMem_free(esal);
5741     set_vaxc_errno(retsts);
5742     if      (retsts == RMS$_PRV) set_errno(EACCES);
5743     else                         set_errno(EVMSERR);
5744     return NULL;
5745   }
5746
5747   /* If the input filespec contained any lowercase characters,
5748    * downcase the result for compatibility with Unix-minded code. */
5749 int_expanded:
5750   if (!decc_efs_case_preserve) {
5751     char * tbuf;
5752     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5753       if (islower(*tbuf)) { haslower = 1; break; }
5754   }
5755
5756    /* Is a long or a short name expected */
5757   /*------------------------------------*/
5758   spec_buf = NULL;
5759 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5760   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5761     if (rms_nam_rsll(mynam)) {
5762         spec_buf = outbufl;
5763         speclen = rms_nam_rsll(mynam);
5764     }
5765     else {
5766         spec_buf = esal; /* Not esa */
5767         speclen = rms_nam_esll(mynam);
5768     }
5769   }
5770   else {
5771 #endif
5772     if (rms_nam_rsl(mynam)) {
5773         spec_buf = outbuf;
5774         speclen = rms_nam_rsl(mynam);
5775     }
5776     else {
5777         spec_buf = esa; /* Not esal */
5778         speclen = rms_nam_esl(mynam);
5779     }
5780 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5781   }
5782 #endif
5783   spec_buf[speclen] = '\0';
5784
5785   /* Trim off null fields added by $PARSE
5786    * If type > 1 char, must have been specified in original or default spec
5787    * (not true for version; $SEARCH may have added version of existing file).
5788    */
5789   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5790   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5791     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5792              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5793   }
5794   else {
5795     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5796              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5797   }
5798   if (trimver || trimtype) {
5799     if (defspec && *defspec) {
5800       char *defesal = NULL;
5801       char *defesa = NULL;
5802       defesa = PerlMem_malloc(VMS_MAXRSS + 1);
5803       if (defesa != NULL) {
5804         struct FAB deffab = cc$rms_fab;
5805 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5806         defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5807         if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5808 #endif
5809         rms_setup_nam(defnam);
5810
5811         rms_bind_fab_nam(deffab, defnam);
5812
5813         /* Cast ok */
5814         rms_set_fna
5815             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5816
5817         /* RMS needs the esa/esal as a work area if wildcards are involved */
5818         rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5819
5820         rms_clear_nam_nop(defnam);
5821         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5822 #ifdef NAM$M_NO_SHORT_UPCASE
5823         if (decc_efs_case_preserve)
5824           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5825 #endif
5826 #ifdef NAML$M_OPEN_SPECIAL
5827         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5828           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5829 #endif
5830         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5831           if (trimver) {
5832              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5833           }
5834           if (trimtype) {
5835             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5836           }
5837         }
5838         if (defesal != NULL)
5839             PerlMem_free(defesal);
5840         PerlMem_free(defesa);
5841       } else {
5842           _ckvmssts_noperl(SS$_INSFMEM);
5843       }
5844     }
5845     if (trimver) {
5846       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5847         if (*(rms_nam_verl(mynam)) != '\"')
5848           speclen = rms_nam_verl(mynam) - spec_buf;
5849       }
5850       else {
5851         if (*(rms_nam_ver(mynam)) != '\"')
5852           speclen = rms_nam_ver(mynam) - spec_buf;
5853       }
5854     }
5855     if (trimtype) {
5856       /* If we didn't already trim version, copy down */
5857       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5858         if (speclen > rms_nam_verl(mynam) - spec_buf)
5859           memmove
5860            (rms_nam_typel(mynam),
5861             rms_nam_verl(mynam),
5862             speclen - (rms_nam_verl(mynam) - spec_buf));
5863           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5864       }
5865       else {
5866         if (speclen > rms_nam_ver(mynam) - spec_buf)
5867           memmove
5868            (rms_nam_type(mynam),
5869             rms_nam_ver(mynam),
5870             speclen - (rms_nam_ver(mynam) - spec_buf));
5871           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5872       }
5873     }
5874   }
5875
5876    /* Done with these copies of the input files */
5877   /*-------------------------------------------*/
5878   if (vmsfspec != NULL)
5879         PerlMem_free(vmsfspec);
5880   if (vmsdefspec != NULL)
5881         PerlMem_free(vmsdefspec);
5882
5883   /* If we just had a directory spec on input, $PARSE "helpfully"
5884    * adds an empty name and type for us */
5885 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5886   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5887     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5888         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5889         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5890       speclen = rms_nam_namel(mynam) - spec_buf;
5891   }
5892   else
5893 #endif
5894   {
5895     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5896         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5897         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5898       speclen = rms_nam_name(mynam) - spec_buf;
5899   }
5900
5901   /* Posix format specifications must have matching quotes */
5902   if (speclen < (VMS_MAXRSS - 1)) {
5903     if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5904       if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5905         spec_buf[speclen] = '\"';
5906         speclen++;
5907       }
5908     }
5909   }
5910   spec_buf[speclen] = '\0';
5911   if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
5912
5913   /* Have we been working with an expanded, but not resultant, spec? */
5914   /* Also, convert back to Unix syntax if necessary. */
5915   {
5916   int rsl;
5917
5918 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5919     if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5920       rsl = rms_nam_rsll(mynam);
5921     } else
5922 #endif
5923     {
5924       rsl = rms_nam_rsl(mynam);
5925     }
5926     if (!rsl) {
5927       /* rsl is not present, it means that spec_buf is either */
5928       /* esa or esal, and needs to be copied to outbuf */
5929       /* convert to Unix if desired */
5930       if (isunix) {
5931         ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5932       } else {
5933         /* VMS file specs are not in UTF-8 */
5934         if (fs_utf8 != NULL)
5935             *fs_utf8 = 0;
5936         strcpy(outbuf, spec_buf);
5937         ret_spec = outbuf;
5938       }
5939     }
5940     else {
5941       /* Now spec_buf is either outbuf or outbufl */
5942       /* We need the result into outbuf */
5943       if (isunix) {
5944            /* If we need this in UNIX, then we need another buffer */
5945            /* to keep things in order */
5946            char * src;
5947            char * new_src = NULL;
5948            if (spec_buf == outbuf) {
5949                new_src = PerlMem_malloc(VMS_MAXRSS);
5950                strcpy(new_src, spec_buf);
5951            } else {
5952                src = spec_buf;
5953            }
5954            ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5955            if (new_src) {
5956                PerlMem_free(new_src);
5957            }
5958       } else {
5959            /* VMS file specs are not in UTF-8 */
5960            if (fs_utf8 != NULL)
5961                *fs_utf8 = 0;
5962
5963            /* Copy the buffer if needed */
5964            if (outbuf != spec_buf)
5965                strcpy(outbuf, spec_buf);
5966            ret_spec = outbuf;
5967       }
5968     }
5969   }
5970
5971   /* Need to clean up the search context */
5972   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5973   sts = rms_free_search_context(&myfab); /* Free search context */
5974
5975   /* Clean up the extra buffers */
5976   if (esal != NULL)
5977       PerlMem_free(esal);
5978   PerlMem_free(esa);
5979   if (outbufl != NULL)
5980      PerlMem_free(outbufl);
5981
5982   /* Return the result */
5983   return ret_spec;
5984 }
5985
5986 /* Common simple case - Expand an already VMS spec */
5987 static char *
5988 int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5989     opts |= PERL_RMSEXPAND_M_VMS_IN;
5990     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5991 }
5992
5993 /* Common simple case - Expand to a VMS spec */
5994 static char *
5995 int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5996     opts |= PERL_RMSEXPAND_M_VMS;
5997     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5998 }
5999
6000
6001 /* Entry point used by perl routines */
6002 static char *
6003 mp_do_rmsexpand
6004    (pTHX_ const char *filespec,
6005     char *outbuf,
6006     int ts,
6007     const char *defspec,
6008     unsigned opts,
6009     int * fs_utf8,
6010     int * dfs_utf8)
6011 {
6012     static char __rmsexpand_retbuf[VMS_MAXRSS];
6013     char * expanded, *ret_spec, *ret_buf;
6014
6015     expanded = NULL;
6016     ret_buf = outbuf;
6017     if (ret_buf == NULL) {
6018         if (ts) {
6019             Newx(expanded, VMS_MAXRSS, char);
6020             if (expanded == NULL)
6021                 _ckvmssts(SS$_INSFMEM);
6022             ret_buf = expanded;
6023         } else {
6024             ret_buf = __rmsexpand_retbuf;
6025         }
6026     }
6027
6028
6029     ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
6030                              opts, fs_utf8,  dfs_utf8);
6031
6032     if (ret_spec == NULL) {
6033        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6034        if (expanded)
6035            Safefree(expanded);
6036     }
6037
6038     return ret_spec;
6039 }
6040 /*}}}*/
6041 /* External entry points */
6042 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
6043 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
6044 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
6045 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
6046 char *Perl_rmsexpand_utf8
6047   (pTHX_ const char *spec, char *buf, const char *def,
6048    unsigned opt, int * fs_utf8, int * dfs_utf8)
6049 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
6050 char *Perl_rmsexpand_utf8_ts
6051   (pTHX_ const char *spec, char *buf, const char *def,
6052    unsigned opt, int * fs_utf8, int * dfs_utf8)
6053 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
6054
6055
6056 /*
6057 ** The following routines are provided to make life easier when
6058 ** converting among VMS-style and Unix-style directory specifications.
6059 ** All will take input specifications in either VMS or Unix syntax. On
6060 ** failure, all return NULL.  If successful, the routines listed below
6061 ** return a pointer to a buffer containing the appropriately
6062 ** reformatted spec (and, therefore, subsequent calls to that routine
6063 ** will clobber the result), while the routines of the same names with
6064 ** a _ts suffix appended will return a pointer to a mallocd string
6065 ** containing the appropriately reformatted spec.
6066 ** In all cases, only explicit syntax is altered; no check is made that
6067 ** the resulting string is valid or that the directory in question
6068 ** actually exists.
6069 **
6070 **   fileify_dirspec() - convert a directory spec into the name of the
6071 **     directory file (i.e. what you can stat() to see if it's a dir).
6072 **     The style (VMS or Unix) of the result is the same as the style
6073 **     of the parameter passed in.
6074 **   pathify_dirspec() - convert a directory spec into a path (i.e.
6075 **     what you prepend to a filename to indicate what directory it's in).
6076 **     The style (VMS or Unix) of the result is the same as the style
6077 **     of the parameter passed in.
6078 **   tounixpath() - convert a directory spec into a Unix-style path.
6079 **   tovmspath() - convert a directory spec into a VMS-style path.
6080 **   tounixspec() - convert any file spec into a Unix-style file spec.
6081 **   tovmsspec() - convert any file spec into a VMS-style spec.
6082 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
6083 **
6084 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
6085 ** Permission is given to distribute this code as part of the Perl
6086 ** standard distribution under the terms of the GNU General Public
6087 ** License or the Perl Artistic License.  Copies of each may be
6088 ** found in the Perl standard distribution.
6089  */
6090
6091 /*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6092 static char *
6093 int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
6094 {
6095     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
6096     char *cp1, *cp2, *lastdir;
6097     char *trndir, *vmsdir;
6098     unsigned short int trnlnm_iter_count;
6099     int is_vms = 0;
6100     int is_unix = 0;
6101     int sts;
6102     if (utf8_fl != NULL)
6103         *utf8_fl = 0;
6104
6105     if (!dir || !*dir) {
6106       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6107     }
6108     dirlen = strlen(dir);
6109     while (dirlen && dir[dirlen-1] == '/') --dirlen;
6110     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
6111       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
6112         dir = "/sys$disk";
6113         dirlen = 9;
6114       }
6115       else
6116         dirlen = 1;
6117     }
6118     if (dirlen > (VMS_MAXRSS - 1)) {
6119       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
6120       return NULL;
6121     }
6122     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
6123     if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6124     if (!strpbrk(dir+1,"/]>:")  &&
6125         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
6126       strcpy(trndir,*dir == '/' ? dir + 1: dir);
6127       trnlnm_iter_count = 0;
6128       while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
6129         trnlnm_iter_count++;
6130         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6131       }
6132       dirlen = strlen(trndir);
6133     }
6134     else {
6135       strncpy(trndir,dir,dirlen);
6136       trndir[dirlen] = '\0';
6137     }
6138
6139     /* At this point we are done with *dir and use *trndir which is a
6140      * copy that can be modified.  *dir must not be modified.
6141      */
6142
6143     /* If we were handed a rooted logical name or spec, treat it like a
6144      * simple directory, so that
6145      *    $ Define myroot dev:[dir.]
6146      *    ... do_fileify_dirspec("myroot",buf,1) ...
6147      * does something useful.
6148      */
6149     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
6150       trndir[--dirlen] = '\0';
6151       trndir[dirlen-1] = ']';
6152     }
6153     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
6154       trndir[--dirlen] = '\0';
6155       trndir[dirlen-1] = '>';
6156     }
6157
6158     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
6159       /* If we've got an explicit filename, we can just shuffle the string. */
6160       if (*(cp1+1)) hasfilename = 1;
6161       /* Similarly, we can just back up a level if we've got multiple levels
6162          of explicit directories in a VMS spec which ends with directories. */
6163       else {
6164         for (cp2 = cp1; cp2 > trndir; cp2--) {
6165           if (*cp2 == '.') {
6166             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
6167 /* fix-me, can not scan EFS file specs backward like this */
6168               *cp2 = *cp1; *cp1 = '\0';
6169               hasfilename = 1;
6170               break;
6171             }
6172           }
6173           if (*cp2 == '[' || *cp2 == '<') break;
6174         }
6175       }
6176     }
6177
6178     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
6179     if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6180     cp1 = strpbrk(trndir,"]:>");
6181     if (hasfilename || !cp1) { /* filename present or not VMS */
6182
6183       if (decc_efs_charset && !cp1) {
6184
6185           /* EFS handling for UNIX mode */
6186
6187           /* Just remove the trailing '/' and we should be done */
6188           STRLEN trndir_len;
6189           trndir_len = strlen(trndir);
6190
6191           if (trndir_len > 1) {
6192               trndir_len--;
6193               if (trndir[trndir_len] == '/') {
6194                   trndir[trndir_len] = '\0';
6195               }
6196           }
6197           strcpy(buf, trndir);
6198           PerlMem_free(trndir);
6199           PerlMem_free(vmsdir);
6200           return buf;
6201       }
6202
6203       /* For non-EFS mode, this is left for backwards compatibility */
6204       /* For EFS mode, this is only done for VMS format filespecs as */
6205       /* Perl programs generally have problems when a UNIX format spec */
6206       /* returns a VMS format spec */
6207       if (trndir[0] == '.') {
6208         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
6209           PerlMem_free(trndir);
6210           PerlMem_free(vmsdir);
6211           return int_fileify_dirspec("[]", buf, NULL);
6212         }
6213         else if (trndir[1] == '.' &&
6214                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
6215           PerlMem_free(trndir);
6216           PerlMem_free(vmsdir);
6217           return int_fileify_dirspec("[-]", buf, NULL);
6218         }
6219       }
6220       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
6221         dirlen -= 1;                 /* to last element */
6222         lastdir = strrchr(trndir,'/');
6223       }
6224       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
6225         /* If we have "/." or "/..", VMSify it and let the VMS code
6226          * below expand it, rather than repeating the code to handle
6227          * relative components of a filespec here */
6228         do {
6229           if (*(cp1+2) == '.') cp1++;
6230           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
6231             char * ret_chr;
6232             if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
6233                 PerlMem_free(trndir);
6234                 PerlMem_free(vmsdir);
6235                 return NULL;
6236             }
6237             if (strchr(vmsdir,'/') != NULL) {
6238               /* If int_tovmsspec() returned it, it must have VMS syntax
6239                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
6240                * the time to check this here only so we avoid a recursion
6241                * loop; otherwise, gigo.
6242                */
6243               PerlMem_free(trndir);
6244               PerlMem_free(vmsdir);
6245               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
6246               return NULL;
6247             }
6248             if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6249                 PerlMem_free(trndir);
6250                 PerlMem_free(vmsdir);
6251                 return NULL;
6252             }
6253             ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6254             PerlMem_free(trndir);
6255             PerlMem_free(vmsdir);
6256             return ret_chr;
6257           }
6258           cp1++;
6259         } while ((cp1 = strstr(cp1,"/.")) != NULL);
6260         lastdir = strrchr(trndir,'/');
6261       }
6262       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
6263         char * ret_chr;
6264         /* Ditto for specs that end in an MFD -- let the VMS code
6265          * figure out whether it's a real device or a rooted logical. */
6266
6267         /* This should not happen any more.  Allowing the fake /000000
6268          * in a UNIX pathname causes all sorts of problems when trying
6269          * to run in UNIX emulation.  So the VMS to UNIX conversions
6270          * now remove the fake /000000 directories.
6271          */
6272
6273         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6274         if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6275             PerlMem_free(trndir);
6276             PerlMem_free(vmsdir);
6277             return NULL;
6278         }
6279         if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6280             PerlMem_free(trndir);
6281             PerlMem_free(vmsdir);
6282             return NULL;
6283         }
6284         ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6285         PerlMem_free(trndir);
6286         PerlMem_free(vmsdir);
6287         return ret_chr;
6288       }
6289       else {
6290
6291         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6292              !(lastdir = cp1 = strrchr(trndir,']')) &&
6293              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6294
6295         cp2 = strrchr(cp1,'.');
6296         if (cp2) {
6297             int e_len, vs_len = 0;
6298             int is_dir = 0;
6299             char * cp3;
6300             cp3 = strchr(cp2,';');
6301             e_len = strlen(cp2);
6302             if (cp3) {
6303                 vs_len = strlen(cp3);
6304                 e_len = e_len - vs_len;
6305             }
6306             is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6307             if (!is_dir) {
6308                 if (!decc_efs_charset) {
6309                     /* If this is not EFS, then not a directory */
6310                     PerlMem_free(trndir);
6311                     PerlMem_free(vmsdir);
6312                     set_errno(ENOTDIR);
6313                     set_vaxc_errno(RMS$_DIR);
6314                     return NULL;
6315                 }
6316             } else {
6317                 /* Ok, here we have an issue, technically if a .dir shows */
6318                 /* from inside a directory, then we should treat it as */
6319                 /* xxx^.dir.dir.  But we do not have that context at this */
6320                 /* point unless this is totally restructured, so we remove */
6321                 /* The .dir for now, and fix this better later */
6322                 dirlen = cp2 - trndir;
6323             }
6324         }
6325
6326       }
6327
6328       retlen = dirlen + 6;
6329       memcpy(buf, trndir, dirlen);
6330       buf[dirlen] = '\0';
6331
6332       /* We've picked up everything up to the directory file name.
6333          Now just add the type and version, and we're set. */
6334
6335       /* We should only add type for VMS syntax, but historically Perl
6336          has added it for UNIX style also */
6337
6338       /* Fix me - we should not be using the same routine for VMS and
6339          UNIX format files.  Things are too tangled so we need to lookup
6340          what syntax the output is */
6341
6342       is_unix = 0;
6343       is_vms = 0;
6344       lastdir = strrchr(trndir,'/');
6345       if (lastdir) {
6346           is_unix = 1;
6347       } else {
6348           lastdir = strpbrk(trndir,"]:>");
6349           if (lastdir) {
6350               is_vms = 1;
6351           }
6352       }
6353
6354       if ((is_vms == 0) && (is_unix == 0)) {
6355           /* We still do not  know? */
6356           is_unix = decc_filename_unix_report;
6357           if (is_unix == 0)
6358               is_vms = 1;
6359       }
6360
6361       if ((is_unix && !decc_efs_charset) || is_vms) {
6362
6363            /* It is a bug to add a .dir to a UNIX format directory spec */
6364            /* However Perl on VMS may have programs that expect this so */
6365            /* If not using EFS character specifications allow it. */
6366
6367            if ((!decc_efs_case_preserve) && vms_process_case_tolerant) {
6368                /* Traditionally Perl expects filenames in lower case */
6369                strcat(buf, ".dir");
6370            } else {
6371                /* VMS expects the .DIR to be in upper case */
6372                strcat(buf, ".DIR");
6373            }
6374
6375            /* It is also a bug to put a VMS format version on a UNIX file */
6376            /* specification.  Perl self tests are looking for this */
6377            if (is_vms || !(decc_efs_charset || decc_filename_unix_report))
6378                strcat(buf, ";1");
6379       }
6380       PerlMem_free(trndir);
6381       PerlMem_free(vmsdir);
6382       return buf;
6383     }
6384     else {  /* VMS-style directory spec */
6385
6386       char *esa, *esal, term, *cp;
6387       char *my_esa;
6388       int my_esa_len;
6389       unsigned long int sts, cmplen, haslower = 0;
6390       unsigned int nam_fnb;
6391       char * nam_type;
6392       struct FAB dirfab = cc$rms_fab;
6393       rms_setup_nam(savnam);
6394       rms_setup_nam(dirnam);
6395
6396       esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6397       if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6398       esal = NULL;
6399 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6400       esal = PerlMem_malloc(VMS_MAXRSS);
6401       if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6402 #endif
6403       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6404       rms_bind_fab_nam(dirfab, dirnam);
6405       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6406       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6407 #ifdef NAM$M_NO_SHORT_UPCASE
6408       if (decc_efs_case_preserve)
6409         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6410 #endif
6411
6412       for (cp = trndir; *cp; cp++)
6413         if (islower(*cp)) { haslower = 1; break; }
6414       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6415         if ((dirfab.fab$l_sts == RMS$_DIR) ||
6416             (dirfab.fab$l_sts == RMS$_DNF) ||
6417             (dirfab.fab$l_sts == RMS$_PRV)) {
6418             rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6419             sts = sys$parse(&dirfab);
6420         }
6421         if (!sts) {
6422           PerlMem_free(esa);
6423           if (esal != NULL)
6424               PerlMem_free(esal);
6425           PerlMem_free(trndir);
6426           PerlMem_free(vmsdir);
6427           set_errno(EVMSERR);
6428           set_vaxc_errno(dirfab.fab$l_sts);
6429           return NULL;
6430         }
6431       }
6432       else {
6433         savnam = dirnam;
6434         /* Does the file really exist? */
6435         if (sys$search(&dirfab)& STS$K_SUCCESS) {
6436           /* Yes; fake the fnb bits so we'll check type below */
6437           rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6438         }
6439         else { /* No; just work with potential name */
6440           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6441           else {
6442             int fab_sts;
6443             fab_sts = dirfab.fab$l_sts;
6444             sts = rms_free_search_context(&dirfab);
6445             PerlMem_free(esa);
6446             if (esal != NULL)
6447                 PerlMem_free(esal);
6448             PerlMem_free(trndir);
6449             PerlMem_free(vmsdir);
6450             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
6451             return NULL;
6452           }
6453         }
6454       }
6455
6456       /* Make sure we are using the right buffer */
6457 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6458       if (esal != NULL) {
6459         my_esa = esal;
6460         my_esa_len = rms_nam_esll(dirnam);
6461       } else {
6462 #endif
6463         my_esa = esa;
6464         my_esa_len = rms_nam_esl(dirnam);
6465 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6466       }
6467 #endif
6468       my_esa[my_esa_len] = '\0';
6469       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6470         cp1 = strchr(my_esa,']');
6471         if (!cp1) cp1 = strchr(my_esa,'>');
6472         if (cp1) {  /* Should always be true */
6473           my_esa_len -= cp1 - my_esa - 1;
6474           memmove(my_esa, cp1 + 1, my_esa_len);
6475         }
6476       }
6477       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6478         /* Yep; check version while we're at it, if it's there. */
6479         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6480         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6481           /* Something other than .DIR[;1].  Bzzt. */
6482           sts = rms_free_search_context(&dirfab);
6483           PerlMem_free(esa);
6484           if (esal != NULL)
6485              PerlMem_free(esal);
6486           PerlMem_free(trndir);
6487           PerlMem_free(vmsdir);
6488           set_errno(ENOTDIR);
6489           set_vaxc_errno(RMS$_DIR);
6490           return NULL;
6491         }
6492       }
6493
6494       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6495         /* They provided at least the name; we added the type, if necessary, */
6496         strcpy(buf, my_esa);
6497         sts = rms_free_search_context(&dirfab);
6498         PerlMem_free(trndir);
6499         PerlMem_free(esa);
6500         if (esal != NULL)
6501             PerlMem_free(esal);
6502         PerlMem_free(vmsdir);
6503         return buf;
6504       }
6505       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6506         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6507         *cp1 = '\0';
6508         my_esa_len -= 9;
6509       }
6510       if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6511       if (cp1 == NULL) { /* should never happen */
6512         sts = rms_free_search_context(&dirfab);
6513         PerlMem_free(trndir);
6514         PerlMem_free(esa);
6515         if (esal != NULL)
6516             PerlMem_free(esal);
6517         PerlMem_free(vmsdir);
6518         return NULL;
6519       }
6520       term = *cp1;
6521       *cp1 = '\0';
6522       retlen = strlen(my_esa);
6523       cp1 = strrchr(my_esa,'.');
6524       /* ODS-5 directory specifications can have extra "." in them. */
6525       /* Fix-me, can not scan EFS file specifications backwards */
6526       while (cp1 != NULL) {
6527         if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6528           break;
6529         else {
6530            cp1--;
6531            while ((cp1 > my_esa) && (*cp1 != '.'))
6532              cp1--;
6533         }
6534         if (cp1 == my_esa)
6535           cp1 = NULL;
6536       }
6537
6538       if ((cp1) != NULL) {
6539         /* There's more than one directory in the path.  Just roll back. */
6540         *cp1 = term;
6541         strcpy(buf, my_esa);
6542       }
6543       else {
6544         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6545           /* Go back and expand rooted logical name */
6546           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6547 #ifdef NAM$M_NO_SHORT_UPCASE
6548           if (decc_efs_case_preserve)
6549             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6550 #endif
6551           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6552             sts = rms_free_search_context(&dirfab);
6553             PerlMem_free(esa);
6554             if (esal != NULL)
6555                 PerlMem_free(esal);
6556             PerlMem_free(trndir);
6557             PerlMem_free(vmsdir);
6558             set_errno(EVMSERR);
6559             set_vaxc_errno(dirfab.fab$l_sts);
6560             return NULL;
6561           }
6562
6563           /* This changes the length of the string of course */
6564           if (esal != NULL) {
6565               my_esa_len = rms_nam_esll(dirnam);
6566           } else {
6567               my_esa_len = rms_nam_esl(dirnam);
6568           }
6569
6570           retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6571           cp1 = strstr(my_esa,"][");
6572           if (!cp1) cp1 = strstr(my_esa,"]<");
6573           dirlen = cp1 - my_esa;
6574           memcpy(buf, my_esa, dirlen);
6575           if (!strncmp(cp1+2,"000000]",7)) {
6576             buf[dirlen-1] = '\0';
6577             /* fix-me Not full ODS-5, just extra dots in directories for now */
6578             cp1 = buf + dirlen - 1;
6579             while (cp1 > buf)
6580             {
6581               if (*cp1 == '[')
6582                 break;
6583               if (*cp1 == '.') {
6584                 if (*(cp1-1) != '^')
6585                   break;
6586               }
6587               cp1--;
6588             }
6589             if (*cp1 == '.') *cp1 = ']';
6590             else {
6591               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6592               memmove(cp1+1,"000000]",7);
6593             }
6594           }
6595           else {
6596             memmove(buf+dirlen, cp1+2, retlen-dirlen);
6597             buf[retlen] = '\0';
6598             /* Convert last '.' to ']' */
6599             cp1 = buf+retlen-1;
6600             while (*cp != '[') {
6601               cp1--;
6602               if (*cp1 == '.') {
6603                 /* Do not trip on extra dots in ODS-5 directories */
6604                 if ((cp1 == buf) || (*(cp1-1) != '^'))
6605                 break;
6606               }
6607             }
6608             if (*cp1 == '.') *cp1 = ']';
6609             else {
6610               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6611               memmove(cp1+1,"000000]",7);
6612             }
6613           }
6614         }
6615         else {  /* This is a top-level dir.  Add the MFD to the path. */
6616           cp1 = my_esa;
6617           cp2 = buf;
6618           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6619           strcpy(cp2,":[000000]");
6620           cp1 += 2;
6621           strcpy(cp2+9,cp1);
6622         }
6623       }
6624       sts = rms_free_search_context(&dirfab);
6625       /* We've set up the string up through the filename.  Add the
6626          type and version, and we're done. */
6627       strcat(buf,".DIR;1");
6628
6629       /* $PARSE may have upcased filespec, so convert output to lower
6630        * case if input contained any lowercase characters. */
6631       if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
6632       PerlMem_free(trndir);
6633       PerlMem_free(esa);
6634       if (esal != NULL)
6635         PerlMem_free(esal);
6636       PerlMem_free(vmsdir);
6637       return buf;
6638     }
6639 }  /* end of int_fileify_dirspec() */
6640
6641
6642 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6643 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
6644 {
6645     static char __fileify_retbuf[VMS_MAXRSS];
6646     char * fileified, *ret_spec, *ret_buf;
6647
6648     fileified = NULL;
6649     ret_buf = buf;
6650     if (ret_buf == NULL) {
6651         if (ts) {
6652             Newx(fileified, VMS_MAXRSS, char);
6653             if (fileified == NULL)
6654                 _ckvmssts(SS$_INSFMEM);
6655             ret_buf = fileified;
6656         } else {
6657             ret_buf = __fileify_retbuf;
6658         }
6659     }
6660
6661     ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6662
6663     if (ret_spec == NULL) {
6664        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6665        if (fileified)
6666            Safefree(fileified);
6667     }
6668
6669     return ret_spec;
6670 }  /* end of do_fileify_dirspec() */
6671 /*}}}*/
6672
6673 /* External entry points */
6674 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6675 { return do_fileify_dirspec(dir,buf,0,NULL); }
6676 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6677 { return do_fileify_dirspec(dir,buf,1,NULL); }
6678 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6679 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6680 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6681 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6682
6683 static char * int_pathify_dirspec_simple(const char * dir, char * buf,
6684     char * v_spec, int v_len, char * r_spec, int r_len,
6685     char * d_spec, int d_len, char * n_spec, int n_len,
6686     char * e_spec, int e_len, char * vs_spec, int vs_len) {
6687
6688     /* VMS specification - Try to do this the simple way */
6689     if ((v_len + r_len > 0) || (d_len > 0)) {
6690         int is_dir;
6691
6692         /* No name or extension component, already a directory */
6693         if ((n_len + e_len + vs_len) == 0) {
6694             strcpy(buf, dir);
6695             return buf;
6696         }
6697
6698         /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6699         /* This results from catfile() being used instead of catdir() */
6700         /* So even though it should not work, we need to allow it */
6701
6702         /* If this is .DIR;1 then do a simple conversion */
6703         is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6704         if (is_dir || (e_len == 0) && (d_len > 0)) {
6705              int len;
6706              len = v_len + r_len + d_len - 1;
6707              char dclose = d_spec[d_len - 1];
6708              strncpy(buf, dir, len);
6709              buf[len] = '.';
6710              len++;
6711              strncpy(&buf[len], n_spec, n_len);
6712              len += n_len;
6713              buf[len] = dclose;
6714              buf[len + 1] = '\0';
6715              return buf;
6716         }
6717
6718 #ifdef HAS_SYMLINK
6719         else if (d_len > 0) {
6720             /* In the olden days, a directory needed to have a .DIR */
6721             /* extension to be a valid directory, but now it could  */
6722             /* be a symbolic link */
6723             int len;
6724             len = v_len + r_len + d_len - 1;
6725             char dclose = d_spec[d_len - 1];
6726             strncpy(buf, dir, len);
6727             buf[len] = '.';
6728             len++;
6729             strncpy(&buf[len], n_spec, n_len);
6730             len += n_len;
6731             if (e_len > 0) {
6732                 if (decc_efs_charset) {
6733                     buf[len] = '^';
6734                     len++;
6735                     strncpy(&buf[len], e_spec, e_len);
6736                     len += e_len;
6737                 } else {
6738                     set_vaxc_errno(RMS$_DIR);
6739                     set_errno(ENOTDIR);
6740                     return NULL;
6741                 }
6742             }
6743             buf[len] = dclose;
6744             buf[len + 1] = '\0';
6745             return buf;
6746         }
6747 #else
6748         else {
6749             set_vaxc_errno(RMS$_DIR);
6750             set_errno(ENOTDIR);
6751             return NULL;
6752         }
6753 #endif
6754     }
6755     set_vaxc_errno(RMS$_DIR);
6756     set_errno(ENOTDIR);
6757     return NULL;
6758 }
6759
6760
6761 /* Internal routine to make sure or convert a directory to be in a */
6762 /* path specification.  No utf8 flag because it is not changed or used */
6763 static char *int_pathify_dirspec(const char *dir, char *buf)
6764 {
6765     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6766     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6767     char * exp_spec, *ret_spec;
6768     char * trndir;
6769     unsigned short int trnlnm_iter_count;
6770     STRLEN trnlen;
6771     int need_to_lower;
6772
6773     if (vms_debug_fileify) {
6774         if (dir == NULL)
6775             fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6776         else
6777             fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6778     }
6779
6780     /* We may need to lower case the result if we translated  */
6781     /* a logical name or got the current working directory */
6782     need_to_lower = 0;
6783
6784     if (!dir || !*dir) {
6785       set_errno(EINVAL);
6786       set_vaxc_errno(SS$_BADPARAM);
6787       return NULL;
6788     }
6789
6790     trndir = PerlMem_malloc(VMS_MAXRSS);
6791     if (trndir == NULL)
6792         _ckvmssts_noperl(SS$_INSFMEM);
6793
6794     /* If no directory specified use the current default */
6795     if (*dir)
6796         strcpy(trndir, dir);
6797     else {
6798         getcwd(trndir, VMS_MAXRSS - 1);
6799         need_to_lower = 1;
6800     }
6801
6802     /* now deal with bare names that could be logical names */
6803     trnlnm_iter_count = 0;
6804     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6805            && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6806         trnlnm_iter_count++;
6807         need_to_lower = 1;
6808         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6809             break;
6810         trnlen = strlen(trndir);
6811
6812         /* Trap simple rooted lnms, and return lnm:[000000] */
6813         if (!strcmp(trndir+trnlen-2,".]")) {
6814             strcpy(buf, dir);
6815             strcat(buf, ":[000000]");
6816             PerlMem_free(trndir);
6817
6818             if (vms_debug_fileify) {
6819                 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6820             }
6821             return buf;
6822         }
6823     }
6824
6825     /* At this point we do not work with *dir, but the copy in  *trndir */
6826
6827     if (need_to_lower && !decc_efs_case_preserve) {
6828         /* Legacy mode, lower case the returned value */
6829         __mystrtolower(trndir);
6830     }
6831
6832
6833     /* Some special cases, '..', '.' */
6834     sts = 0;
6835     if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6836        /* Force UNIX filespec */
6837        sts = 1;
6838
6839     } else {
6840         /* Is this Unix or VMS format? */
6841         sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6842                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6843                              &e_len, &vs_spec, &vs_len);
6844         if (sts == 0) {
6845
6846             /* Just a filename? */
6847             if ((v_len + r_len + d_len) == 0) {
6848
6849                 /* Now we have a problem, this could be Unix or VMS */
6850                 /* We have to guess.  .DIR usually means VMS */
6851
6852                 /* In UNIX report mode, the .DIR extension is removed */
6853                 /* if one shows up, it is for a non-directory or a directory */
6854                 /* in EFS charset mode */
6855
6856                 /* So if we are in Unix report mode, assume that this */
6857                 /* is a relative Unix directory specification */
6858
6859                 sts = 1;
6860                 if (!decc_filename_unix_report && decc_efs_charset) {
6861                     int is_dir;
6862                     is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6863
6864                     if (is_dir) {
6865                         /* Traditional mode, assume .DIR is directory */
6866                         buf[0] = '[';
6867                         buf[1] = '.';
6868                         strncpy(&buf[2], n_spec, n_len);
6869                         buf[n_len + 2] = ']';
6870                         buf[n_len + 3] = '\0';
6871                         PerlMem_free(trndir);
6872                         if (vms_debug_fileify) {
6873                             fprintf(stderr,
6874                                     "int_pathify_dirspec: buf = %s\n",
6875                                     buf);
6876                         }
6877                         return buf;
6878                     }
6879                 }
6880             }
6881         }
6882     }
6883     if (sts == 0) {
6884         ret_spec = int_pathify_dirspec_simple(trndir, buf,
6885             v_spec, v_len, r_spec, r_len,
6886             d_spec, d_len, n_spec, n_len,
6887             e_spec, e_len, vs_spec, vs_len);
6888
6889         if (ret_spec != NULL) {
6890             PerlMem_free(trndir);
6891             if (vms_debug_fileify) {
6892                 fprintf(stderr,
6893                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6894             }
6895             return ret_spec;
6896         }
6897
6898         /* Simple way did not work, which means that a logical name */
6899         /* was present for the directory specification.             */
6900         /* Need to use an rmsexpand variant to decode it completely */
6901         exp_spec = PerlMem_malloc(VMS_MAXRSS);
6902         if (exp_spec == NULL)
6903             _ckvmssts_noperl(SS$_INSFMEM);
6904
6905         ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6906         if (ret_spec != NULL) {
6907             sts = vms_split_path(exp_spec, &v_spec, &v_len,
6908                                  &r_spec, &r_len, &d_spec, &d_len,
6909                                  &n_spec, &n_len, &e_spec,
6910                                  &e_len, &vs_spec, &vs_len);
6911             if (sts == 0) {
6912                 ret_spec = int_pathify_dirspec_simple(
6913                     exp_spec, buf, v_spec, v_len, r_spec, r_len,
6914                     d_spec, d_len, n_spec, n_len,
6915                     e_spec, e_len, vs_spec, vs_len);
6916
6917                 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6918                     /* Legacy mode, lower case the returned value */
6919                     __mystrtolower(ret_spec);
6920                 }
6921             } else {
6922                 set_vaxc_errno(RMS$_DIR);
6923                 set_errno(ENOTDIR);
6924                 ret_spec = NULL;
6925             }
6926         }
6927         PerlMem_free(exp_spec);
6928         PerlMem_free(trndir);
6929         if (vms_debug_fileify) {
6930             if (ret_spec == NULL)
6931                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6932             else
6933                 fprintf(stderr,
6934                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6935         }
6936         return ret_spec;
6937
6938     } else {
6939         /* Unix specification, Could be trivial conversion */
6940         STRLEN dir_len;
6941         dir_len = strlen(trndir);
6942
6943         /* If the extended file character set is in effect */
6944         /* then pathify is simple */
6945
6946         if (!decc_efs_charset) {
6947             /* Have to deal with traiing '.dir' or extra '.' */
6948             /* that should not be there in legacy mode, but is */
6949
6950             char * lastdot;
6951             char * lastslash;
6952             int is_dir;
6953
6954             lastslash = strrchr(trndir, '/');
6955             if (lastslash == NULL)
6956                 lastslash = trndir;
6957             else
6958                 lastslash++;
6959
6960             lastdot = NULL;
6961
6962             /* '..' or '.' are valid directory components */
6963             is_dir = 0;
6964             if (lastslash[0] == '.') {
6965                 if (lastslash[1] == '\0') {
6966                    is_dir = 1;
6967                 } else if (lastslash[1] == '.') {
6968                     if (lastslash[2] == '\0') {
6969                         is_dir = 1;
6970                     } else {
6971                         /* And finally allow '...' */
6972                         if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
6973                             is_dir = 1;
6974                         }
6975                     }
6976                 }
6977             }
6978
6979             if (!is_dir) {
6980                lastdot = strrchr(lastslash, '.');
6981             }
6982             if (lastdot != NULL) {
6983                 STRLEN e_len;
6984
6985                 /* '.dir' is discarded, and any other '.' is invalid */
6986                 e_len = strlen(lastdot);
6987
6988                 is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
6989
6990                 if (is_dir) {
6991                     dir_len = dir_len - 4;
6992
6993                 }
6994             }
6995         }
6996
6997         strcpy(buf, trndir);
6998         if (buf[dir_len - 1] != '/') {
6999             buf[dir_len] = '/';
7000             buf[dir_len + 1] = '\0';
7001         }
7002
7003         /* Under ODS-2 rules, '.' becomes '_', so fix it up */
7004         if (!decc_efs_charset) {
7005              int dir_start = 0;
7006              char * str = buf;
7007              if (str[0] == '.') {
7008                  char * dots = str;
7009                  int cnt = 1;
7010                  while ((dots[cnt] == '.') && (cnt < 3))
7011                      cnt++;
7012                  if (cnt <= 3) {
7013                      if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
7014                          dir_start = 1;
7015                          str += cnt;
7016                      }
7017                  }
7018              }
7019              for (; *str; ++str) {
7020                  while (*str == '/') {
7021                      dir_start = 1;
7022                      *str++;
7023                  }
7024                  if (dir_start) {
7025
7026                      /* Have to skip up to three dots which could be */
7027                      /* directories, 3 dots being a VMS extension for Perl */
7028                      char * dots = str;
7029                      int cnt = 0;
7030                      while ((dots[cnt] == '.') && (cnt < 3)) {
7031                          cnt++;
7032                      }
7033                      if (dots[cnt] == '\0')
7034                          break;
7035                      if ((cnt > 1) && (dots[cnt] != '/')) {
7036                          dir_start = 0;
7037                      } else {
7038                          str += cnt;
7039                      }
7040
7041                      /* too many dots? */
7042                      if ((cnt == 0) || (cnt > 3)) {
7043                          dir_start = 0;
7044                      }
7045                  }
7046                  if (!dir_start && (*str == '.')) {
7047                      *str = '_';
7048                  }
7049              }
7050         }
7051         PerlMem_free(trndir);
7052         ret_spec = buf;
7053         if (vms_debug_fileify) {
7054             if (ret_spec == NULL)
7055                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
7056             else
7057                 fprintf(stderr,
7058                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
7059         }
7060         return ret_spec;
7061     }
7062 }
7063
7064 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
7065 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
7066 {
7067     static char __pathify_retbuf[VMS_MAXRSS];
7068     char * pathified, *ret_spec, *ret_buf;
7069
7070     pathified = NULL;
7071     ret_buf = buf;
7072     if (ret_buf == NULL) {
7073         if (ts) {
7074             Newx(pathified, VMS_MAXRSS, char);
7075             if (pathified == NULL)
7076                 _ckvmssts(SS$_INSFMEM);
7077             ret_buf = pathified;
7078         } else {
7079             ret_buf = __pathify_retbuf;
7080         }
7081     }
7082
7083     ret_spec = int_pathify_dirspec(dir, ret_buf);
7084
7085     if (ret_spec == NULL) {
7086        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7087        if (pathified)
7088            Safefree(pathified);
7089     }
7090
7091     return ret_spec;
7092
7093 }  /* end of do_pathify_dirspec() */
7094
7095
7096 /* External entry points */
7097 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
7098 { return do_pathify_dirspec(dir,buf,0,NULL); }
7099 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
7100 { return do_pathify_dirspec(dir,buf,1,NULL); }
7101 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
7102 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
7103 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
7104 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
7105
7106 /* Internal tounixspec routine that does not use a thread context */
7107 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
7108 static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
7109 {
7110   char *dirend, *cp1, *cp3, *tmp;
7111   const char *cp2;
7112   int devlen, dirlen, retlen = VMS_MAXRSS;
7113   int expand = 1; /* guarantee room for leading and trailing slashes */
7114   unsigned short int trnlnm_iter_count;
7115   int cmp_rslt;
7116   if (utf8_fl != NULL)
7117     *utf8_fl = 0;
7118
7119   if (vms_debug_fileify) {
7120       if (spec == NULL)
7121           fprintf(stderr, "int_tounixspec: spec = NULL\n");
7122       else
7123           fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
7124   }
7125
7126
7127   if (spec == NULL) {
7128       set_errno(EINVAL);
7129       set_vaxc_errno(SS$_BADPARAM);
7130       return NULL;
7131   }
7132   if (strlen(spec) > (VMS_MAXRSS-1)) {
7133       set_errno(E2BIG);
7134       set_vaxc_errno(SS$_BUFFEROVF);
7135       return NULL;
7136   }
7137
7138   /* New VMS specific format needs translation
7139    * glob passes filenames with trailing '\n' and expects this preserved.
7140    */
7141   if (decc_posix_compliant_pathnames) {
7142     if (strncmp(spec, "\"^UP^", 5) == 0) {
7143       char * uspec;
7144       char *tunix;
7145       int tunix_len;
7146       int nl_flag;
7147
7148       tunix = PerlMem_malloc(VMS_MAXRSS);
7149       if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7150       strcpy(tunix, spec);
7151       tunix_len = strlen(tunix);
7152       nl_flag = 0;
7153       if (tunix[tunix_len - 1] == '\n') {
7154         tunix[tunix_len - 1] = '\"';
7155         tunix[tunix_len] = '\0';
7156         tunix_len--;
7157         nl_flag = 1;
7158       }
7159       uspec = decc$translate_vms(tunix);
7160       PerlMem_free(tunix);
7161       if ((int)uspec > 0) {
7162         strcpy(rslt,uspec);
7163         if (nl_flag) {
7164           strcat(rslt,"\n");
7165         }
7166         else {
7167           /* If we can not translate it, makemaker wants as-is */
7168           strcpy(rslt, spec);
7169         }
7170         return rslt;
7171       }
7172     }
7173   }
7174
7175   cmp_rslt = 0; /* Presume VMS */
7176   cp1 = strchr(spec, '/');
7177   if (cp1 == NULL)
7178     cmp_rslt = 0;
7179
7180     /* Look for EFS ^/ */
7181     if (decc_efs_charset) {
7182       while (cp1 != NULL) {
7183         cp2 = cp1 - 1;
7184         if (*cp2 != '^') {
7185           /* Found illegal VMS, assume UNIX */
7186           cmp_rslt = 1;
7187           break;
7188         }
7189       cp1++;
7190       cp1 = strchr(cp1, '/');
7191     }
7192   }
7193
7194   /* Look for "." and ".." */
7195   if (decc_filename_unix_report) {
7196     if (spec[0] == '.') {
7197       if ((spec[1] == '\0') || (spec[1] == '\n')) {
7198         cmp_rslt = 1;
7199       }
7200       else {
7201         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
7202           cmp_rslt = 1;
7203         }
7204       }
7205     }
7206   }
7207   /* This is already UNIX or at least nothing VMS understands */
7208   if (cmp_rslt) {
7209     strcpy(rslt,spec);
7210     if (vms_debug_fileify) {
7211         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7212     }
7213     return rslt;
7214   }
7215
7216   cp1 = rslt;
7217   cp2 = spec;
7218   dirend = strrchr(spec,']');
7219   if (dirend == NULL) dirend = strrchr(spec,'>');
7220   if (dirend == NULL) dirend = strchr(spec,':');
7221   if (dirend == NULL) {
7222     strcpy(rslt,spec);
7223     if (vms_debug_fileify) {
7224         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7225     }
7226     return rslt;
7227   }
7228
7229   /* Special case 1 - sys$posix_root = / */
7230 #if __CRTL_VER >= 70000000
7231   if (!decc_disable_posix_root) {
7232     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
7233       *cp1 = '/';
7234       cp1++;
7235       cp2 = cp2 + 15;
7236       }
7237   }
7238 #endif
7239
7240   /* Special case 2 - Convert NLA0: to /dev/null */
7241 #if __CRTL_VER < 70000000
7242   cmp_rslt = strncmp(spec,"NLA0:", 5);
7243   if (cmp_rslt != 0)
7244      cmp_rslt = strncmp(spec,"nla0:", 5);
7245 #else
7246   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
7247 #endif
7248   if (cmp_rslt == 0) {
7249     strcpy(rslt, "/dev/null");
7250     cp1 = cp1 + 9;
7251     cp2 = cp2 + 5;
7252     if (spec[6] != '\0') {
7253       cp1[9] == '/';
7254       cp1++;
7255       cp2++;
7256     }
7257   }
7258
7259    /* Also handle special case "SYS$SCRATCH:" */
7260 #if __CRTL_VER < 70000000
7261   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
7262   if (cmp_rslt != 0)
7263      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
7264 #else
7265   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
7266 #endif
7267   tmp = PerlMem_malloc(VMS_MAXRSS);
7268   if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7269   if (cmp_rslt == 0) {
7270   int islnm;
7271
7272     islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
7273     if (!islnm) {
7274       strcpy(rslt, "/tmp");
7275       cp1 = cp1 + 4;
7276       cp2 = cp2 + 12;
7277       if (spec[12] != '\0') {
7278         cp1[4] == '/';
7279         cp1++;
7280         cp2++;
7281       }
7282     }
7283   }
7284
7285   if (*cp2 != '[' && *cp2 != '<') {
7286     *(cp1++) = '/';
7287   }
7288   else {  /* the VMS spec begins with directories */
7289     cp2++;
7290     if (*cp2 == ']' || *cp2 == '>') {
7291       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
7292       PerlMem_free(tmp);
7293       return rslt;
7294     }
7295     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
7296       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
7297         PerlMem_free(tmp);
7298         if (vms_debug_fileify) {
7299             fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7300         }
7301         return NULL;
7302       }
7303       trnlnm_iter_count = 0;
7304       do {
7305         cp3 = tmp;
7306         while (*cp3 != ':' && *cp3) cp3++;
7307         *(cp3++) = '\0';
7308         if (strchr(cp3,']') != NULL) break;
7309         trnlnm_iter_count++;
7310         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7311       } while (vmstrnenv(tmp,tmp,0,fildev,0));
7312       cp1 = rslt;
7313       cp3 = tmp;
7314       *(cp1++) = '/';
7315       while (*cp3) {
7316         *(cp1++) = *(cp3++);
7317         if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7318             PerlMem_free(tmp);
7319             set_errno(ENAMETOOLONG);
7320             set_vaxc_errno(SS$_BUFFEROVF);
7321             if (vms_debug_fileify) {
7322                 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7323             }
7324             return NULL; /* No room */
7325         }
7326       }
7327       *(cp1++) = '/';
7328     }
7329     if ((*cp2 == '^')) {
7330         /* EFS file escape, pass the next character as is */
7331         /* Fix me: HEX encoding for Unicode not implemented */
7332         cp2++;
7333     }
7334     else if ( *cp2 == '.') {
7335       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7336         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7337         cp2 += 3;
7338       }
7339       else cp2++;
7340     }
7341   }
7342   PerlMem_free(tmp);
7343   for (; cp2 <= dirend; cp2++) {
7344     if ((*cp2 == '^')) {
7345         /* EFS file escape, pass the next character as is */
7346         /* Fix me: HEX encoding for Unicode not implemented */
7347         *(cp1++) = *(++cp2);
7348         /* An escaped dot stays as is -- don't convert to slash */
7349         if (*cp2 == '.') cp2++;
7350     }
7351     if (*cp2 == ':') {
7352       *(cp1++) = '/';
7353       if (*(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7354     }
7355     else if (*cp2 == ']' || *cp2 == '>') {
7356       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7357     }
7358     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7359       *(cp1++) = '/';
7360       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7361         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7362                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7363         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7364             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7365       }
7366       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7367         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7368         cp2 += 2;
7369       }
7370     }
7371     else if (*cp2 == '-') {
7372       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7373         while (*cp2 == '-') {
7374           cp2++;
7375           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7376         }
7377         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7378                                                          /* filespecs like */
7379           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
7380           if (vms_debug_fileify) {
7381               fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7382           }
7383           return NULL;
7384         }
7385       }
7386       else *(cp1++) = *cp2;
7387     }
7388     else *(cp1++) = *cp2;
7389   }
7390   /* Translate the rest of the filename. */
7391   while (*cp2) {
7392       int dot_seen;
7393       dot_seen = 0;
7394       switch(*cp2) {
7395       /* Fixme - for compatibility with the CRTL we should be removing */
7396       /* spaces from the file specifications, but this may show that */
7397       /* some tests that were appearing to pass are not really passing */
7398       case '%':
7399           cp2++;
7400           *(cp1++) = '?';
7401           break;
7402       case '^':
7403           /* Fix me hex expansions not implemented */
7404           cp2++;  /* '^.' --> '.' and other. */
7405           if (*cp2) {
7406               if (*cp2 == '_') {
7407                   cp2++;
7408                   *(cp1++) = ' ';
7409               } else {
7410                   *(cp1++) = *(cp2++);
7411               }
7412           }
7413           break;
7414       case ';':
7415           if (decc_filename_unix_no_version) {
7416               /* Easy, drop the version */
7417               while (*cp2)
7418                   cp2++;
7419               break;
7420           } else {
7421               /* Punt - passing the version as a dot will probably */
7422               /* break perl in weird ways, but so did passing */
7423               /* through the ; as a version.  Follow the CRTL and */
7424               /* hope for the best. */
7425               cp2++;
7426               *(cp1++) = '.';
7427           }
7428           break;
7429       case '.':
7430           if (dot_seen) {
7431               /* We will need to fix this properly later */
7432               /* As Perl may be installed on an ODS-5 volume, but not */
7433               /* have the EFS_CHARSET enabled, it still may encounter */
7434               /* filenames with extra dots in them, and a precedent got */
7435               /* set which allowed them to work, that we will uphold here */
7436               /* If extra dots are present in a name and no ^ is on them */
7437               /* VMS assumes that the first one is the extension delimiter */
7438               /* the rest have an implied ^. */
7439
7440               /* this is also a conflict as the . is also a version */
7441               /* delimiter in VMS, */
7442
7443               *(cp1++) = *(cp2++);
7444               break;
7445           }
7446           dot_seen = 1;
7447           /* This is an extension */
7448           if (decc_readdir_dropdotnotype) {
7449               cp2++;
7450               if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7451                   /* Drop the dot for the extension */
7452                   break;
7453               } else {
7454                   *(cp1++) = '.';
7455               }
7456               break;
7457           }
7458       default:
7459           *(cp1++) = *(cp2++);
7460       }
7461   }
7462   *cp1 = '\0';
7463
7464   /* This still leaves /000000/ when working with a
7465    * VMS device root or concealed root.
7466    */
7467   {
7468   int ulen;
7469   char * zeros;
7470
7471       ulen = strlen(rslt);
7472
7473       /* Get rid of "000000/ in rooted filespecs */
7474       if (ulen > 7) {
7475         zeros = strstr(rslt, "/000000/");
7476         if (zeros != NULL) {
7477           int mlen;
7478           mlen = ulen - (zeros - rslt) - 7;
7479           memmove(zeros, &zeros[7], mlen);
7480           ulen = ulen - 7;
7481           rslt[ulen] = '\0';
7482         }
7483       }
7484   }
7485
7486   if (vms_debug_fileify) {
7487       fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7488   }
7489   return rslt;
7490
7491 }  /* end of int_tounixspec() */
7492
7493
7494 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7495 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7496 {
7497     static char __tounixspec_retbuf[VMS_MAXRSS];
7498     char * unixspec, *ret_spec, *ret_buf;
7499
7500     unixspec = NULL;
7501     ret_buf = buf;
7502     if (ret_buf == NULL) {
7503         if (ts) {
7504             Newx(unixspec, VMS_MAXRSS, char);
7505             if (unixspec == NULL)
7506                 _ckvmssts(SS$_INSFMEM);
7507             ret_buf = unixspec;
7508         } else {
7509             ret_buf = __tounixspec_retbuf;
7510         }
7511     }
7512
7513     ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7514
7515     if (ret_spec == NULL) {
7516        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7517        if (unixspec)
7518            Safefree(unixspec);
7519     }
7520
7521     return ret_spec;
7522
7523 }  /* end of do_tounixspec() */
7524 /*}}}*/
7525 /* External entry points */
7526 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
7527   { return do_tounixspec(spec,buf,0, NULL); }
7528 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7529   { return do_tounixspec(spec,buf,1, NULL); }
7530 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7531   { return do_tounixspec(spec,buf,0, utf8_fl); }
7532 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7533   { return do_tounixspec(spec,buf,1, utf8_fl); }
7534
7535 #if __CRTL_VER >= 70200000 && !defined(__VAX)
7536
7537 /*
7538  This procedure is used to identify if a path is based in either
7539  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7540  it returns the OpenVMS format directory for it.
7541
7542  It is expecting specifications of only '/' or '/xxxx/'
7543
7544  If a posix root does not exist, or 'xxxx' is not a directory
7545  in the posix root, it returns a failure.
7546
7547  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7548
7549  It is used only internally by posix_to_vmsspec_hardway().
7550  */
7551
7552 static int posix_root_to_vms
7553   (char *vmspath, int vmspath_len,
7554    const char *unixpath,
7555    const int * utf8_fl)
7556 {
7557 int sts;
7558 struct FAB myfab = cc$rms_fab;
7559 rms_setup_nam(mynam);
7560 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7561 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7562 char * esa, * esal, * rsa, * rsal;
7563 char *vms_delim;
7564 int dir_flag;
7565 int unixlen;
7566
7567     dir_flag = 0;
7568     vmspath[0] = '\0';
7569     unixlen = strlen(unixpath);
7570     if (unixlen == 0) {
7571       return RMS$_FNF;
7572     }
7573
7574 #if __CRTL_VER >= 80200000
7575   /* If not a posix spec already, convert it */
7576   if (decc_posix_compliant_pathnames) {
7577     if (strncmp(unixpath,"\"^UP^",5) != 0) {
7578       sprintf(vmspath,"\"^UP^%s\"",unixpath);
7579     }
7580     else {
7581       /* This is already a VMS specification, no conversion */
7582       unixlen--;
7583       strncpy(vmspath,unixpath, vmspath_len);
7584     }
7585   }
7586   else
7587 #endif
7588   {
7589   int path_len;
7590   int i,j;
7591
7592      /* Check to see if this is under the POSIX root */
7593      if (decc_disable_posix_root) {
7594         return RMS$_FNF;
7595      }
7596
7597      /* Skip leading / */
7598      if (unixpath[0] == '/') {
7599         unixpath++;
7600         unixlen--;
7601      }
7602
7603
7604      strcpy(vmspath,"SYS$POSIX_ROOT:");
7605
7606      /* If this is only the / , or blank, then... */
7607      if (unixpath[0] == '\0') {
7608         /* by definition, this is the answer */
7609         return SS$_NORMAL;
7610      }
7611
7612      /* Need to look up a directory */
7613      vmspath[15] = '[';
7614      vmspath[16] = '\0';
7615
7616      /* Copy and add '^' escape characters as needed */
7617      j = 16;
7618      i = 0;
7619      while (unixpath[i] != 0) {
7620      int k;
7621
7622         j += copy_expand_unix_filename_escape
7623             (&vmspath[j], &unixpath[i], &k, utf8_fl);
7624         i += k;
7625      }
7626
7627      path_len = strlen(vmspath);
7628      if (vmspath[path_len - 1] == '/')
7629         path_len--;
7630      vmspath[path_len] = ']';
7631      path_len++;
7632      vmspath[path_len] = '\0';
7633
7634   }
7635   vmspath[vmspath_len] = 0;
7636   if (unixpath[unixlen - 1] == '/')
7637   dir_flag = 1;
7638   esal = PerlMem_malloc(VMS_MAXRSS);
7639   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7640   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7641   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7642   rsal = PerlMem_malloc(VMS_MAXRSS);
7643   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7644   rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7645   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7646   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7647   rms_bind_fab_nam(myfab, mynam);
7648   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7649   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7650   if (decc_efs_case_preserve)
7651     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7652 #ifdef NAML$M_OPEN_SPECIAL
7653   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7654 #endif
7655
7656   /* Set up the remaining naml fields */
7657   sts = sys$parse(&myfab);
7658
7659   /* It failed! Try again as a UNIX filespec */
7660   if (!(sts & 1)) {
7661     PerlMem_free(esal);
7662     PerlMem_free(esa);
7663     PerlMem_free(rsal);
7664     PerlMem_free(rsa);
7665     return sts;
7666   }
7667
7668    /* get the Device ID and the FID */
7669    sts = sys$search(&myfab);
7670
7671    /* These are no longer needed */
7672    PerlMem_free(esa);
7673    PerlMem_free(rsal);
7674    PerlMem_free(rsa);
7675
7676    /* on any failure, returned the POSIX ^UP^ filespec */
7677    if (!(sts & 1)) {
7678       PerlMem_free(esal);
7679       return sts;
7680    }
7681    specdsc.dsc$a_pointer = vmspath;
7682    specdsc.dsc$w_length = vmspath_len;
7683
7684    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7685    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7686    sts = lib$fid_to_name
7687       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7688
7689   /* on any failure, returned the POSIX ^UP^ filespec */
7690   if (!(sts & 1)) {
7691      /* This can happen if user does not have permission to read directories */
7692      if (strncmp(unixpath,"\"^UP^",5) != 0)
7693        sprintf(vmspath,"\"^UP^%s\"",unixpath);
7694      else
7695        strcpy(vmspath, unixpath);
7696   }
7697   else {
7698     vmspath[specdsc.dsc$w_length] = 0;
7699
7700     /* Are we expecting a directory? */
7701     if (dir_flag != 0) {
7702     int i;
7703     char *eptr;
7704
7705       eptr = NULL;
7706
7707       i = specdsc.dsc$w_length - 1;
7708       while (i > 0) {
7709       int zercnt;
7710         zercnt = 0;
7711         /* Version must be '1' */
7712         if (vmspath[i--] != '1')
7713           break;
7714         /* Version delimiter is one of ".;" */
7715         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7716           break;
7717         i--;
7718         if (vmspath[i--] != 'R')
7719           break;
7720         if (vmspath[i--] != 'I')
7721           break;
7722         if (vmspath[i--] != 'D')
7723           break;
7724         if (vmspath[i--] != '.')
7725           break;
7726         eptr = &vmspath[i+1];
7727         while (i > 0) {
7728           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7729             if (vmspath[i-1] != '^') {
7730               if (zercnt != 6) {
7731                 *eptr = vmspath[i];
7732                 eptr[1] = '\0';
7733                 vmspath[i] = '.';
7734                 break;
7735               }
7736               else {
7737                 /* Get rid of 6 imaginary zero directory filename */
7738                 vmspath[i+1] = '\0';
7739               }
7740             }
7741           }
7742           if (vmspath[i] == '0')
7743             zercnt++;
7744           else
7745             zercnt = 10;
7746           i--;
7747         }
7748         break;
7749       }
7750     }
7751   }
7752   PerlMem_free(esal);
7753   return sts;
7754 }
7755
7756 /* /dev/mumble needs to be handled special.
7757    /dev/null becomes NLA0:, And there is the potential for other stuff
7758    like /dev/tty which may need to be mapped to something.
7759 */
7760
7761 static int
7762 slash_dev_special_to_vms
7763    (const char * unixptr,
7764     char * vmspath,
7765     int vmspath_len)
7766 {
7767 char * nextslash;
7768 int len;
7769 int cmp;
7770 int islnm;
7771
7772     unixptr += 4;
7773     nextslash = strchr(unixptr, '/');
7774     len = strlen(unixptr);
7775     if (nextslash != NULL)
7776         len = nextslash - unixptr;
7777     cmp = strncmp("null", unixptr, 5);
7778     if (cmp == 0) {
7779         if (vmspath_len >= 6) {
7780             strcpy(vmspath, "_NLA0:");
7781             return SS$_NORMAL;
7782         }
7783     }
7784 }
7785
7786
7787 /* The built in routines do not understand perl's special needs, so
7788     doing a manual conversion from UNIX to VMS
7789
7790     If the utf8_fl is not null and points to a non-zero value, then
7791     treat 8 bit characters as UTF-8.
7792
7793     The sequence starting with '$(' and ending with ')' will be passed
7794     through with out interpretation instead of being escaped.
7795
7796   */
7797 static int posix_to_vmsspec_hardway
7798   (char *vmspath, int vmspath_len,
7799    const char *unixpath,
7800    int dir_flag,
7801    int * utf8_fl) {
7802
7803 char *esa;
7804 const char *unixptr;
7805 const char *unixend;
7806 char *vmsptr;
7807 const char *lastslash;
7808 const char *lastdot;
7809 int unixlen;
7810 int vmslen;
7811 int dir_start;
7812 int dir_dot;
7813 int quoted;
7814 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7815 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7816
7817   if (utf8_fl != NULL)
7818     *utf8_fl = 0;
7819
7820   unixptr = unixpath;
7821   dir_dot = 0;
7822
7823   /* Ignore leading "/" characters */
7824   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7825     unixptr++;
7826   }
7827   unixlen = strlen(unixptr);
7828
7829   /* Do nothing with blank paths */
7830   if (unixlen == 0) {
7831     vmspath[0] = '\0';
7832     return SS$_NORMAL;
7833   }
7834
7835   quoted = 0;
7836   /* This could have a "^UP^ on the front */
7837   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7838     quoted = 1;
7839     unixptr+= 5;
7840     unixlen-= 5;
7841   }
7842
7843   lastslash = strrchr(unixptr,'/');
7844   lastdot = strrchr(unixptr,'.');
7845   unixend = strrchr(unixptr,'\"');
7846   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7847     unixend = unixptr + unixlen;
7848   }
7849
7850   /* last dot is last dot or past end of string */
7851   if (lastdot == NULL)
7852     lastdot = unixptr + unixlen;
7853
7854   /* if no directories, set last slash to beginning of string */
7855   if (lastslash == NULL) {
7856     lastslash = unixptr;
7857   }
7858   else {
7859     /* Watch out for trailing "." after last slash, still a directory */
7860     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7861       lastslash = unixptr + unixlen;
7862     }
7863
7864     /* Watch out for traiing ".." after last slash, still a directory */
7865     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7866       lastslash = unixptr + unixlen;
7867     }
7868
7869     /* dots in directories are aways escaped */
7870     if (lastdot < lastslash)
7871       lastdot = unixptr + unixlen;
7872   }
7873
7874   /* if (unixptr < lastslash) then we are in a directory */
7875
7876   dir_start = 0;
7877
7878   vmsptr = vmspath;
7879   vmslen = 0;
7880
7881   /* Start with the UNIX path */
7882   if (*unixptr != '/') {
7883     /* relative paths */
7884
7885     /* If allowing logical names on relative pathnames, then handle here */
7886     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7887         !decc_posix_compliant_pathnames) {
7888     char * nextslash;
7889     int seg_len;
7890     char * trn;
7891     int islnm;
7892
7893         /* Find the next slash */
7894         nextslash = strchr(unixptr,'/');
7895
7896         esa = PerlMem_malloc(vmspath_len);
7897         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7898
7899         trn = PerlMem_malloc(VMS_MAXRSS);
7900         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7901
7902         if (nextslash != NULL) {
7903
7904             seg_len = nextslash - unixptr;
7905             strncpy(esa, unixptr, seg_len);
7906             esa[seg_len] = 0;
7907         }
7908         else {
7909             strcpy(esa, unixptr);
7910             seg_len = strlen(unixptr);
7911         }
7912         /* trnlnm(section) */
7913         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7914
7915         if (islnm) {
7916             /* Now fix up the directory */
7917
7918             /* Split up the path to find the components */
7919             sts = vms_split_path
7920                   (trn,
7921                    &v_spec,
7922                    &v_len,
7923                    &r_spec,
7924                    &r_len,
7925                    &d_spec,
7926                    &d_len,
7927                    &n_spec,
7928                    &n_len,
7929                    &e_spec,
7930                    &e_len,
7931                    &vs_spec,
7932                    &vs_len);
7933
7934             while (sts == 0) {
7935             char * strt;
7936             int cmp;
7937
7938                 /* A logical name must be a directory  or the full
7939                    specification.  It is only a full specification if
7940                    it is the only component */
7941                 if ((unixptr[seg_len] == '\0') ||
7942                     (unixptr[seg_len+1] == '\0')) {
7943
7944                     /* Is a directory being required? */
7945                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7946                         /* Not a logical name */
7947                         break;
7948                     }
7949
7950
7951                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7952                         /* This must be a directory */
7953                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7954                             strcpy(vmsptr, esa);
7955                             vmslen=strlen(vmsptr);
7956                             vmsptr[vmslen] = ':';
7957                             vmslen++;
7958                             vmsptr[vmslen] = '\0';
7959                             return SS$_NORMAL;
7960                         }
7961                     }
7962
7963                 }
7964
7965
7966                 /* must be dev/directory - ignore version */
7967                 if ((n_len + e_len) != 0)
7968                     break;
7969
7970                 /* transfer the volume */
7971                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7972                     strncpy(vmsptr, v_spec, v_len);
7973                     vmsptr += v_len;
7974                     vmsptr[0] = '\0';
7975                     vmslen += v_len;
7976                 }
7977
7978                 /* unroot the rooted directory */
7979                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7980                     r_spec[0] = '[';
7981                     r_spec[r_len - 1] = ']';
7982
7983                     /* This should not be there, but nothing is perfect */
7984                     if (r_len > 9) {
7985                         cmp = strcmp(&r_spec[1], "000000.");
7986                         if (cmp == 0) {
7987                             r_spec += 7;
7988                             r_spec[7] = '[';
7989                             r_len -= 7;
7990                             if (r_len == 2)
7991                                 r_len = 0;
7992                         }
7993                     }
7994                     if (r_len > 0) {
7995                         strncpy(vmsptr, r_spec, r_len);
7996                         vmsptr += r_len;
7997                         vmslen += r_len;
7998                         vmsptr[0] = '\0';
7999                     }
8000                 }
8001                 /* Bring over the directory. */
8002                 if ((d_len > 0) &&
8003                     ((d_len + vmslen) < vmspath_len)) {
8004                     d_spec[0] = '[';
8005                     d_spec[d_len - 1] = ']';
8006                     if (d_len > 9) {
8007                         cmp = strcmp(&d_spec[1], "000000.");
8008                         if (cmp == 0) {
8009                             d_spec += 7;
8010                             d_spec[7] = '[';
8011                             d_len -= 7;
8012                             if (d_len == 2)
8013                                 d_len = 0;
8014                         }
8015                     }
8016
8017                     if (r_len > 0) {
8018                         /* Remove the redundant root */
8019                         if (r_len > 0) {
8020                             /* remove the ][ */
8021                             vmsptr--;
8022                             vmslen--;
8023                             d_spec++;
8024                             d_len--;
8025                         }
8026                         strncpy(vmsptr, d_spec, d_len);
8027                             vmsptr += d_len;
8028                             vmslen += d_len;
8029                             vmsptr[0] = '\0';
8030                     }
8031                 }
8032                 break;
8033             }
8034         }
8035
8036         PerlMem_free(esa);
8037         PerlMem_free(trn);
8038     }
8039
8040     if (lastslash > unixptr) {
8041     int dotdir_seen;
8042
8043       /* skip leading ./ */
8044       dotdir_seen = 0;
8045       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
8046         dotdir_seen = 1;
8047         unixptr++;
8048         unixptr++;
8049       }
8050
8051       /* Are we still in a directory? */
8052       if (unixptr <= lastslash) {
8053         *vmsptr++ = '[';
8054         vmslen = 1;
8055         dir_start = 1;
8056
8057         /* if not backing up, then it is relative forward. */
8058         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
8059               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
8060           *vmsptr++ = '.';
8061           vmslen++;
8062           dir_dot = 1;
8063           }
8064        }
8065        else {
8066          if (dotdir_seen) {
8067            /* Perl wants an empty directory here to tell the difference
8068             * between a DCL commmand and a filename
8069             */
8070           *vmsptr++ = '[';
8071           *vmsptr++ = ']';
8072           vmslen = 2;
8073         }
8074       }
8075     }
8076     else {
8077       /* Handle two special files . and .. */
8078       if (unixptr[0] == '.') {
8079         if (&unixptr[1] == unixend) {
8080           *vmsptr++ = '[';
8081           *vmsptr++ = ']';
8082           vmslen += 2;
8083           *vmsptr++ = '\0';
8084           return SS$_NORMAL;
8085         }
8086         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
8087           *vmsptr++ = '[';
8088           *vmsptr++ = '-';
8089           *vmsptr++ = ']';
8090           vmslen += 3;
8091           *vmsptr++ = '\0';
8092           return SS$_NORMAL;
8093         }
8094       }
8095     }
8096   }
8097   else {        /* Absolute PATH handling */
8098   int sts;
8099   char * nextslash;
8100   int seg_len;
8101     /* Need to find out where root is */
8102
8103     /* In theory, this procedure should never get an absolute POSIX pathname
8104      * that can not be found on the POSIX root.
8105      * In practice, that can not be relied on, and things will show up
8106      * here that are a VMS device name or concealed logical name instead.
8107      * So to make things work, this procedure must be tolerant.
8108      */
8109     esa = PerlMem_malloc(vmspath_len);
8110     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8111
8112     sts = SS$_NORMAL;
8113     nextslash = strchr(&unixptr[1],'/');
8114     seg_len = 0;
8115     if (nextslash != NULL) {
8116     int cmp;
8117       seg_len = nextslash - &unixptr[1];
8118       strncpy(vmspath, unixptr, seg_len + 1);
8119       vmspath[seg_len+1] = 0;
8120       cmp = 1;
8121       if (seg_len == 3) {
8122         cmp = strncmp(vmspath, "dev", 4);
8123         if (cmp == 0) {
8124             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
8125             if (sts = SS$_NORMAL)
8126                 return SS$_NORMAL;
8127         }
8128       }
8129       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
8130     }
8131
8132     if ($VMS_STATUS_SUCCESS(sts)) {
8133       /* This is verified to be a real path */
8134
8135       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
8136       if ($VMS_STATUS_SUCCESS(sts)) {
8137         strcpy(vmspath, esa);
8138         vmslen = strlen(vmspath);
8139         vmsptr = vmspath + vmslen;
8140         unixptr++;
8141         if (unixptr < lastslash) {
8142         char * rptr;
8143           vmsptr--;
8144           *vmsptr++ = '.';
8145           dir_start = 1;
8146           dir_dot = 1;
8147           if (vmslen > 7) {
8148           int cmp;
8149             rptr = vmsptr - 7;
8150             cmp = strcmp(rptr,"000000.");
8151             if (cmp == 0) {
8152               vmslen -= 7;
8153               vmsptr -= 7;
8154               vmsptr[1] = '\0';
8155             } /* removing 6 zeros */
8156           } /* vmslen < 7, no 6 zeros possible */
8157         } /* Not in a directory */
8158       } /* Posix root found */
8159       else {
8160         /* No posix root, fall back to default directory */
8161         strcpy(vmspath, "SYS$DISK:[");
8162         vmsptr = &vmspath[10];
8163         vmslen = 10;
8164         if (unixptr > lastslash) {
8165            *vmsptr = ']';
8166            vmsptr++;
8167            vmslen++;
8168         }
8169         else {
8170            dir_start = 1;
8171         }
8172       }
8173     } /* end of verified real path handling */
8174     else {
8175     int add_6zero;
8176     int islnm;
8177
8178       /* Ok, we have a device or a concealed root that is not in POSIX
8179        * or we have garbage.  Make the best of it.
8180        */
8181
8182       /* Posix to VMS destroyed this, so copy it again */
8183       strncpy(vmspath, &unixptr[1], seg_len);
8184       vmspath[seg_len] = 0;
8185       vmslen = seg_len;
8186       vmsptr = &vmsptr[vmslen];
8187       islnm = 0;
8188
8189       /* Now do we need to add the fake 6 zero directory to it? */
8190       add_6zero = 1;
8191       if ((*lastslash == '/') && (nextslash < lastslash)) {
8192         /* No there is another directory */
8193         add_6zero = 0;
8194       }
8195       else {
8196       int trnend;
8197       int cmp;
8198
8199         /* now we have foo:bar or foo:[000000]bar to decide from */
8200         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
8201
8202         if (!islnm && !decc_posix_compliant_pathnames) {
8203
8204             cmp = strncmp("bin", vmspath, 4);
8205             if (cmp == 0) {
8206                 /* bin => SYS$SYSTEM: */
8207                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
8208             }
8209             else {
8210                 /* tmp => SYS$SCRATCH: */
8211                 cmp = strncmp("tmp", vmspath, 4);
8212                 if (cmp == 0) {
8213                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
8214                 }
8215             }
8216         }
8217
8218         trnend = islnm ? islnm - 1 : 0;
8219
8220         /* if this was a logical name, ']' or '>' must be present */
8221         /* if not a logical name, then assume a device and hope. */
8222         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
8223
8224         /* if log name and trailing '.' then rooted - treat as device */
8225         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
8226
8227         /* Fix me, if not a logical name, a device lookup should be
8228          * done to see if the device is file structured.  If the device
8229          * is not file structured, the 6 zeros should not be put on.
8230          *
8231          * As it is, perl is occasionally looking for dev:[000000]tty.
8232          * which looks a little strange.
8233          *
8234          * Not that easy to detect as "/dev" may be file structured with
8235          * special device files.
8236          */
8237
8238         if (!islnm && (add_6zero == 0) && (*nextslash == '/') &&
8239             (&nextslash[1] == unixend)) {
8240           /* No real directory present */
8241           add_6zero = 1;
8242         }
8243       }
8244
8245       /* Put the device delimiter on */
8246       *vmsptr++ = ':';
8247       vmslen++;
8248       unixptr = nextslash;
8249       unixptr++;
8250
8251       /* Start directory if needed */
8252       if (!islnm || add_6zero) {
8253         *vmsptr++ = '[';
8254         vmslen++;
8255         dir_start = 1;
8256       }
8257
8258       /* add fake 000000] if needed */
8259       if (add_6zero) {
8260         *vmsptr++ = '0';
8261         *vmsptr++ = '0';
8262         *vmsptr++ = '0';
8263         *vmsptr++ = '0';
8264         *vmsptr++ = '0';
8265         *vmsptr++ = '0';
8266         *vmsptr++ = ']';
8267         vmslen += 7;
8268         dir_start = 0;
8269       }
8270
8271     } /* non-POSIX translation */
8272     PerlMem_free(esa);
8273   } /* End of relative/absolute path handling */
8274
8275   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
8276   int dash_flag;
8277   int in_cnt;
8278   int out_cnt;
8279
8280     dash_flag = 0;
8281
8282     if (dir_start != 0) {
8283
8284       /* First characters in a directory are handled special */
8285       while ((*unixptr == '/') ||
8286              ((*unixptr == '.') &&
8287               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8288                 (&unixptr[1]==unixend)))) {
8289       int loop_flag;
8290
8291         loop_flag = 0;
8292
8293         /* Skip redundant / in specification */
8294         while ((*unixptr == '/') && (dir_start != 0)) {
8295           loop_flag = 1;
8296           unixptr++;
8297           if (unixptr == lastslash)
8298             break;
8299         }
8300         if (unixptr == lastslash)
8301           break;
8302
8303         /* Skip redundant ./ characters */
8304         while ((*unixptr == '.') &&
8305                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8306           loop_flag = 1;
8307           unixptr++;
8308           if (unixptr == lastslash)
8309             break;
8310           if (*unixptr == '/')
8311             unixptr++;
8312         }
8313         if (unixptr == lastslash)
8314           break;
8315
8316         /* Skip redundant ../ characters */
8317         while ((*unixptr == '.') && (unixptr[1] == '.') &&
8318              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8319           /* Set the backing up flag */
8320           loop_flag = 1;
8321           dir_dot = 0;
8322           dash_flag = 1;
8323           *vmsptr++ = '-';
8324           vmslen++;
8325           unixptr++; /* first . */
8326           unixptr++; /* second . */
8327           if (unixptr == lastslash)
8328             break;
8329           if (*unixptr == '/') /* The slash */
8330             unixptr++;
8331         }
8332         if (unixptr == lastslash)
8333           break;
8334
8335         /* To do: Perl expects /.../ to be translated to [...] on VMS */
8336         /* Not needed when VMS is pretending to be UNIX. */
8337
8338         /* Is this loop stuck because of too many dots? */
8339         if (loop_flag == 0) {
8340           /* Exit the loop and pass the rest through */
8341           break;
8342         }
8343       }
8344
8345       /* Are we done with directories yet? */
8346       if (unixptr >= lastslash) {
8347
8348         /* Watch out for trailing dots */
8349         if (dir_dot != 0) {
8350             vmslen --;
8351             vmsptr--;
8352         }
8353         *vmsptr++ = ']';
8354         vmslen++;
8355         dash_flag = 0;
8356         dir_start = 0;
8357         if (*unixptr == '/')
8358           unixptr++;
8359       }
8360       else {
8361         /* Have we stopped backing up? */
8362         if (dash_flag) {
8363           *vmsptr++ = '.';
8364           vmslen++;
8365           dash_flag = 0;
8366           /* dir_start continues to be = 1 */
8367         }
8368         if (*unixptr == '-') {
8369           *vmsptr++ = '^';
8370           *vmsptr++ = *unixptr++;
8371           vmslen += 2;
8372           dir_start = 0;
8373
8374           /* Now are we done with directories yet? */
8375           if (unixptr >= lastslash) {
8376
8377             /* Watch out for trailing dots */
8378             if (dir_dot != 0) {
8379               vmslen --;
8380               vmsptr--;
8381             }
8382
8383             *vmsptr++ = ']';
8384             vmslen++;
8385             dash_flag = 0;
8386             dir_start = 0;
8387           }
8388         }
8389       }
8390     }
8391
8392     /* All done? */
8393     if (unixptr >= unixend)
8394       break;
8395
8396     /* Normal characters - More EFS work probably needed */
8397     dir_start = 0;
8398     dir_dot = 0;
8399
8400     switch(*unixptr) {
8401     case '/':
8402         /* remove multiple / */
8403         while (unixptr[1] == '/') {
8404            unixptr++;
8405         }
8406         if (unixptr == lastslash) {
8407           /* Watch out for trailing dots */
8408           if (dir_dot != 0) {
8409             vmslen --;
8410             vmsptr--;
8411           }
8412           *vmsptr++ = ']';
8413         }
8414         else {
8415           dir_start = 1;
8416           *vmsptr++ = '.';
8417           dir_dot = 1;
8418
8419           /* To do: Perl expects /.../ to be translated to [...] on VMS */
8420           /* Not needed when VMS is pretending to be UNIX. */
8421
8422         }
8423         dash_flag = 0;
8424         if (unixptr != unixend)
8425           unixptr++;
8426         vmslen++;
8427         break;
8428     case '.':
8429         if ((unixptr < lastdot) || (unixptr < lastslash) ||
8430             (&unixptr[1] == unixend)) {
8431           *vmsptr++ = '^';
8432           *vmsptr++ = '.';
8433           vmslen += 2;
8434           unixptr++;
8435
8436           /* trailing dot ==> '^..' on VMS */
8437           if (unixptr == unixend) {
8438             *vmsptr++ = '.';
8439             vmslen++;
8440             unixptr++;
8441           }
8442           break;
8443         }
8444
8445         *vmsptr++ = *unixptr++;
8446         vmslen ++;
8447         break;
8448     case '"':
8449         if (quoted && (&unixptr[1] == unixend)) {
8450             unixptr++;
8451             break;
8452         }
8453         in_cnt = copy_expand_unix_filename_escape
8454                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8455         vmsptr += out_cnt;
8456         unixptr += in_cnt;
8457         break;
8458     case '~':
8459     case ';':
8460     case '\\':
8461     case '?':
8462     case ' ':
8463     default:
8464         in_cnt = copy_expand_unix_filename_escape
8465                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8466         vmsptr += out_cnt;
8467         unixptr += in_cnt;
8468         break;
8469     }
8470   }
8471
8472   /* Make sure directory is closed */
8473   if (unixptr == lastslash) {
8474     char *vmsptr2;
8475     vmsptr2 = vmsptr - 1;
8476
8477     if (*vmsptr2 != ']') {
8478       *vmsptr2--;
8479
8480       /* directories do not end in a dot bracket */
8481       if (*vmsptr2 == '.') {
8482         vmsptr2--;
8483
8484         /* ^. is allowed */
8485         if (*vmsptr2 != '^') {
8486           vmsptr--; /* back up over the dot */
8487         }
8488       }
8489       *vmsptr++ = ']';
8490     }
8491   }
8492   else {
8493     char *vmsptr2;
8494     /* Add a trailing dot if a file with no extension */
8495     vmsptr2 = vmsptr - 1;
8496     if ((vmslen > 1) &&
8497         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8498         (*vmsptr2 != ')') && (*lastdot != '.') && (*vmsptr2 != ':')) {
8499         *vmsptr++ = '.';
8500         vmslen++;
8501     }
8502   }
8503
8504   *vmsptr = '\0';
8505   return SS$_NORMAL;
8506 }
8507 #endif
8508
8509  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
8510 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
8511 {
8512 char * result;
8513 int utf8_flag;
8514
8515    /* If a UTF8 flag is being passed, honor it */
8516    utf8_flag = 0;
8517    if (utf8_fl != NULL) {
8518      utf8_flag = *utf8_fl;
8519     *utf8_fl = 0;
8520    }
8521
8522    if (utf8_flag) {
8523      /* If there is a possibility of UTF8, then if any UTF8 characters
8524         are present, then they must be converted to VTF-7
8525       */
8526      result = strcpy(rslt, path); /* FIX-ME */
8527    }
8528    else
8529      result = strcpy(rslt, path);
8530
8531    return result;
8532 }
8533
8534
8535
8536 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8537 static char *int_tovmsspec
8538    (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
8539   char *dirend;
8540   char *lastdot;
8541   char *vms_delim;
8542   register char *cp1;
8543   const char *cp2;
8544   unsigned long int infront = 0, hasdir = 1;
8545   int rslt_len;
8546   int no_type_seen;
8547   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8548   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8549
8550   if (vms_debug_fileify) {
8551       if (path == NULL)
8552           fprintf(stderr, "int_tovmsspec: path = NULL\n");
8553       else
8554           fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8555   }
8556
8557   if (path == NULL) {
8558       /* If we fail, we should be setting errno */
8559       set_errno(EINVAL);
8560       set_vaxc_errno(SS$_BADPARAM);
8561       return NULL;
8562   }
8563   rslt_len = VMS_MAXRSS-1;
8564
8565   /* '.' and '..' are "[]" and "[-]" for a quick check */
8566   if (path[0] == '.') {
8567     if (path[1] == '\0') {
8568       strcpy(rslt,"[]");
8569       if (utf8_flag != NULL)
8570         *utf8_flag = 0;
8571       return rslt;
8572     }
8573     else {
8574       if (path[1] == '.' && path[2] == '\0') {
8575         strcpy(rslt,"[-]");
8576         if (utf8_flag != NULL)
8577            *utf8_flag = 0;
8578         return rslt;
8579       }
8580     }
8581   }
8582
8583    /* Posix specifications are now a native VMS format */
8584   /*--------------------------------------------------*/
8585 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8586   if (decc_posix_compliant_pathnames) {
8587     if (strncmp(path,"\"^UP^",5) == 0) {
8588       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8589       return rslt;
8590     }
8591   }
8592 #endif
8593
8594   /* This is really the only way to see if this is already in VMS format */
8595   sts = vms_split_path
8596        (path,
8597         &v_spec,
8598         &v_len,
8599         &r_spec,
8600         &r_len,
8601         &d_spec,
8602         &d_len,
8603         &n_spec,
8604         &n_len,
8605         &e_spec,
8606         &e_len,
8607         &vs_spec,
8608         &vs_len);
8609   if (sts == 0) {
8610     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8611        replacement, because the above parse just took care of most of
8612        what is needed to do vmspath when the specification is already
8613        in VMS format.
8614
8615        And if it is not already, it is easier to do the conversion as
8616        part of this routine than to call this routine and then work on
8617        the result.
8618      */
8619
8620     /* If VMS punctuation was found, it is already VMS format */
8621     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8622       if (utf8_flag != NULL)
8623         *utf8_flag = 0;
8624       strcpy(rslt, path);
8625       if (vms_debug_fileify) {
8626           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8627       }
8628       return rslt;
8629     }
8630     /* Now, what to do with trailing "." cases where there is no
8631        extension?  If this is a UNIX specification, and EFS characters
8632        are enabled, then the trailing "." should be converted to a "^.".
8633        But if this was already a VMS specification, then it should be
8634        left alone.
8635
8636        So in the case of ambiguity, leave the specification alone.
8637      */
8638
8639
8640     /* If there is a possibility of UTF8, then if any UTF8 characters
8641         are present, then they must be converted to VTF-7
8642      */
8643     if (utf8_flag != NULL)
8644       *utf8_flag = 0;
8645     strcpy(rslt, path);
8646     if (vms_debug_fileify) {
8647         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8648     }
8649     return rslt;
8650   }
8651
8652   dirend = strrchr(path,'/');
8653
8654   if (dirend == NULL) {
8655      char *macro_start;
8656      int has_macro;
8657
8658      /* If we get here with no UNIX directory delimiters, then this is
8659         not a complete file specification, either garbage a UNIX glob
8660         specification that can not be converted to a VMS wildcard, or
8661         it a UNIX shell macro.  MakeMaker wants shell macros passed
8662         through AS-IS,
8663
8664         utf8 flag setting needs to be preserved.
8665       */
8666       hasdir = 0;
8667
8668       has_macro = 0;
8669       macro_start = strchr(path,'$');
8670       if (macro_start != NULL) {
8671           if (macro_start[1] == '(') {
8672               has_macro = 1;
8673           }
8674       }
8675       if ((decc_efs_charset == 0) || (has_macro)) {
8676           strcpy(rslt, path);
8677           if (vms_debug_fileify) {
8678               fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8679           }
8680           return rslt;
8681       }
8682   }
8683
8684 /* If EFS charset mode active, handle the conversion */
8685 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8686   if (decc_efs_charset) {
8687     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8688     if (vms_debug_fileify) {
8689         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8690     }
8691     return rslt;
8692   }
8693 #endif
8694
8695   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
8696     if (!*(dirend+2)) dirend +=2;
8697     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8698     if (decc_efs_charset == 0) {
8699       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8700     }
8701   }
8702
8703   cp1 = rslt;
8704   cp2 = path;
8705   lastdot = strrchr(cp2,'.');
8706   if (*cp2 == '/') {
8707     char *trndev;
8708     int islnm, rooted;
8709     STRLEN trnend;
8710
8711     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8712     if (!*(cp2+1)) {
8713       if (decc_disable_posix_root) {
8714         strcpy(rslt,"sys$disk:[000000]");
8715       }
8716       else {
8717         strcpy(rslt,"sys$posix_root:[000000]");
8718       }
8719       if (utf8_flag != NULL)
8720         *utf8_flag = 0;
8721       if (vms_debug_fileify) {
8722           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8723       }
8724       return rslt;
8725     }
8726     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8727     *cp1 = '\0';
8728     trndev = PerlMem_malloc(VMS_MAXRSS);
8729     if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8730     islnm =  simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8731
8732      /* DECC special handling */
8733     if (!islnm) {
8734       if (strcmp(rslt,"bin") == 0) {
8735         strcpy(rslt,"sys$system");
8736         cp1 = rslt + 10;
8737         *cp1 = 0;
8738         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8739       }
8740       else if (strcmp(rslt,"tmp") == 0) {
8741         strcpy(rslt,"sys$scratch");
8742         cp1 = rslt + 11;
8743         *cp1 = 0;
8744         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8745       }
8746       else if (!decc_disable_posix_root) {
8747         strcpy(rslt, "sys$posix_root");
8748         cp1 = rslt + 14;
8749         *cp1 = 0;
8750         cp2 = path;
8751         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8752         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8753       }
8754       else if (strcmp(rslt,"dev") == 0) {
8755         if (strncmp(cp2,"/null", 5) == 0) {
8756           if ((cp2[5] == 0) || (cp2[5] == '/')) {
8757             strcpy(rslt,"NLA0");
8758             cp1 = rslt + 4;
8759             *cp1 = 0;
8760             cp2 = cp2 + 5;
8761             islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8762           }
8763         }
8764       }
8765     }
8766
8767     trnend = islnm ? strlen(trndev) - 1 : 0;
8768     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8769     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8770     /* If the first element of the path is a logical name, determine
8771      * whether it has to be translated so we can add more directories. */
8772     if (!islnm || rooted) {
8773       *(cp1++) = ':';
8774       *(cp1++) = '[';
8775       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8776       else cp2++;
8777     }
8778     else {
8779       if (cp2 != dirend) {
8780         strcpy(rslt,trndev);
8781         cp1 = rslt + trnend;
8782         if (*cp2 != 0) {
8783           *(cp1++) = '.';
8784           cp2++;
8785         }
8786       }
8787       else {
8788         if (decc_disable_posix_root) {
8789           *(cp1++) = ':';
8790           hasdir = 0;
8791         }
8792       }
8793     }
8794     PerlMem_free(trndev);
8795   }
8796   else {
8797     *(cp1++) = '[';
8798     if (*cp2 == '.') {
8799       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8800         cp2 += 2;         /* skip over "./" - it's redundant */
8801         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8802       }
8803       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8804         *(cp1++) = '-';                                 /* "../" --> "-" */
8805         cp2 += 3;
8806       }
8807       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8808                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8809         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8810         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8811         cp2 += 4;
8812       }
8813       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8814         /* Escape the extra dots in EFS file specifications */
8815         *(cp1++) = '^';
8816       }
8817       if (cp2 > dirend) cp2 = dirend;
8818     }
8819     else *(cp1++) = '.';
8820   }
8821   for (; cp2 < dirend; cp2++) {
8822     if (*cp2 == '/') {
8823       if (*(cp2-1) == '/') continue;
8824       if (*(cp1-1) != '.') *(cp1++) = '.';
8825       infront = 0;
8826     }
8827     else if (!infront && *cp2 == '.') {
8828       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8829       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8830       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8831         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8832         else if (*(cp1-2) == '[') *(cp1-1) = '-';
8833         else {  /* back up over previous directory name */
8834           cp1--;
8835           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
8836           if (*(cp1-1) == '[') {
8837             memcpy(cp1,"000000.",7);
8838             cp1 += 7;
8839           }
8840         }
8841         cp2 += 2;
8842         if (cp2 == dirend) break;
8843       }
8844       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8845                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8846         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8847         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8848         if (!*(cp2+3)) {
8849           *(cp1++) = '.';  /* Simulate trailing '/' */
8850           cp2 += 2;  /* for loop will incr this to == dirend */
8851         }
8852         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8853       }
8854       else {
8855         if (decc_efs_charset == 0)
8856           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8857         else {
8858           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
8859           *(cp1++) = '.';
8860         }
8861       }
8862     }
8863     else {
8864       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
8865       if (*cp2 == '.') {
8866         if (decc_efs_charset == 0)
8867           *(cp1++) = '_';
8868         else {
8869           *(cp1++) = '^';
8870           *(cp1++) = '.';
8871         }
8872       }
8873       else                  *(cp1++) =  *cp2;
8874       infront = 1;
8875     }
8876   }
8877   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8878   if (hasdir) *(cp1++) = ']';
8879   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
8880   /* fixme for ODS5 */
8881   no_type_seen = 0;
8882   if (cp2 > lastdot)
8883     no_type_seen = 1;
8884   while (*cp2) {
8885     switch(*cp2) {
8886     case '?':
8887         if (decc_efs_charset == 0)
8888           *(cp1++) = '%';
8889         else
8890           *(cp1++) = '?';
8891         cp2++;
8892     case ' ':
8893         *(cp1)++ = '^';
8894         *(cp1)++ = '_';
8895         cp2++;
8896         break;
8897     case '.':
8898         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8899             decc_readdir_dropdotnotype) {
8900           *(cp1)++ = '^';
8901           *(cp1)++ = '.';
8902           cp2++;
8903
8904           /* trailing dot ==> '^..' on VMS */
8905           if (*cp2 == '\0') {
8906             *(cp1++) = '.';
8907             no_type_seen = 0;
8908           }
8909         }
8910         else {
8911           *(cp1++) = *(cp2++);
8912           no_type_seen = 0;
8913         }
8914         break;
8915     case '$':
8916          /* This could be a macro to be passed through */
8917         *(cp1++) = *(cp2++);
8918         if (*cp2 == '(') {
8919         const char * save_cp2;
8920         char * save_cp1;
8921         int is_macro;
8922
8923             /* paranoid check */
8924             save_cp2 = cp2;
8925             save_cp1 = cp1;
8926             is_macro = 0;
8927
8928             /* Test through */
8929             *(cp1++) = *(cp2++);
8930             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8931                 *(cp1++) = *(cp2++);
8932                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8933                     *(cp1++) = *(cp2++);
8934                 }
8935                 if (*cp2 == ')') {
8936                     *(cp1++) = *(cp2++);
8937                     is_macro = 1;
8938                 }
8939             }
8940             if (is_macro == 0) {
8941                 /* Not really a macro - never mind */
8942                 cp2 = save_cp2;
8943                 cp1 = save_cp1;
8944             }
8945         }
8946         break;
8947     case '\"':
8948     case '~':
8949     case '`':
8950     case '!':
8951     case '#':
8952     case '%':
8953     case '^':
8954         /* Don't escape again if following character is
8955          * already something we escape.
8956          */
8957         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8958             *(cp1++) = *(cp2++);
8959             break;
8960         }
8961         /* But otherwise fall through and escape it. */
8962     case '&':
8963     case '(':
8964     case ')':
8965     case '=':
8966     case '+':
8967     case '\'':
8968     case '@':
8969     case '[':
8970     case ']':
8971     case '{':
8972     case '}':
8973     case ':':
8974     case '\\':
8975     case '|':
8976     case '<':
8977     case '>':
8978         *(cp1++) = '^';
8979         *(cp1++) = *(cp2++);
8980         break;
8981     case ';':
8982         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8983          * which is wrong.  UNIX notation should be ".dir." unless
8984          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8985          * changing this behavior could break more things at this time.
8986          * efs character set effectively does not allow "." to be a version
8987          * delimiter as a further complication about changing this.
8988          */
8989         if (decc_filename_unix_report != 0) {
8990           *(cp1++) = '^';
8991         }
8992         *(cp1++) = *(cp2++);
8993         break;
8994     default:
8995         *(cp1++) = *(cp2++);
8996     }
8997   }
8998   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8999   char *lcp1;
9000     lcp1 = cp1;
9001     lcp1--;
9002      /* Fix me for "^]", but that requires making sure that you do
9003       * not back up past the start of the filename
9004       */
9005     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
9006       *cp1++ = '.';
9007   }
9008   *cp1 = '\0';
9009
9010   if (utf8_flag != NULL)
9011     *utf8_flag = 0;
9012   if (vms_debug_fileify) {
9013       fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
9014   }
9015   return rslt;
9016
9017 }  /* end of int_tovmsspec() */
9018
9019
9020 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
9021 static char *mp_do_tovmsspec
9022    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
9023   static char __tovmsspec_retbuf[VMS_MAXRSS];
9024     char * vmsspec, *ret_spec, *ret_buf;
9025
9026     vmsspec = NULL;
9027     ret_buf = buf;
9028     if (ret_buf == NULL) {
9029         if (ts) {
9030             Newx(vmsspec, VMS_MAXRSS, char);
9031             if (vmsspec == NULL)
9032                 _ckvmssts(SS$_INSFMEM);
9033             ret_buf = vmsspec;
9034         } else {
9035             ret_buf = __tovmsspec_retbuf;
9036         }
9037     }
9038
9039     ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
9040
9041     if (ret_spec == NULL) {
9042        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
9043        if (vmsspec)
9044            Safefree(vmsspec);
9045     }
9046
9047     return ret_spec;
9048
9049 }  /* end of mp_do_tovmsspec() */
9050 /*}}}*/
9051 /* External entry points */
9052 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
9053   { return do_tovmsspec(path,buf,0,NULL); }
9054 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
9055   { return do_tovmsspec(path,buf,1,NULL); }
9056 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9057   { return do_tovmsspec(path,buf,0,utf8_fl); }
9058 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9059   { return do_tovmsspec(path,buf,1,utf8_fl); }
9060
9061 /*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
9062 /* Internal routine for use with out an explict context present */
9063 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl) {
9064
9065     char * ret_spec, *pathified;
9066
9067     if (path == NULL)
9068         return NULL;
9069
9070     pathified = PerlMem_malloc(VMS_MAXRSS);
9071     if (pathified == NULL)
9072         _ckvmssts_noperl(SS$_INSFMEM);
9073
9074     ret_spec = int_pathify_dirspec(path, pathified);
9075
9076     if (ret_spec == NULL) {
9077         PerlMem_free(pathified);
9078         return NULL;
9079     }
9080
9081     ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
9082
9083     PerlMem_free(pathified);
9084     return ret_spec;
9085
9086 }
9087
9088 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
9089 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
9090   static char __tovmspath_retbuf[VMS_MAXRSS];
9091   int vmslen;
9092   char *pathified, *vmsified, *cp;
9093
9094   if (path == NULL) return NULL;
9095   pathified = PerlMem_malloc(VMS_MAXRSS);
9096   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
9097   if (int_pathify_dirspec(path, pathified) == NULL) {
9098     PerlMem_free(pathified);
9099     return NULL;
9100   }
9101
9102   vmsified = NULL;
9103   if (buf == NULL)
9104      Newx(vmsified, VMS_MAXRSS, char);
9105   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
9106     PerlMem_free(pathified);
9107     if (vmsified) Safefree(vmsified);
9108     return NULL;
9109   }
9110   PerlMem_free(pathified);
9111   if (buf) {
9112     return buf;
9113   }
9114   else if (ts) {
9115     vmslen = strlen(vmsified);
9116     Newx(cp,vmslen+1,char);
9117     memcpy(cp,vmsified,vmslen);
9118     cp[vmslen] = '\0';
9119     Safefree(vmsified);
9120     return cp;
9121   }
9122   else {
9123     strcpy(__tovmspath_retbuf,vmsified);
9124     Safefree(vmsified);
9125     return __tovmspath_retbuf;
9126   }
9127
9128 }  /* end of do_tovmspath() */
9129 /*}}}*/
9130 /* External entry points */
9131 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
9132   { return do_tovmspath(path,buf,0, NULL); }
9133 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
9134   { return do_tovmspath(path,buf,1, NULL); }
9135 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
9136   { return do_tovmspath(path,buf,0,utf8_fl); }
9137 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
9138   { return do_tovmspath(path,buf,1,utf8_fl); }
9139
9140
9141 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
9142 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
9143   static char __tounixpath_retbuf[VMS_MAXRSS];
9144   int unixlen;
9145   char *pathified, *unixified, *cp;
9146
9147   if (path == NULL) return NULL;
9148   pathified = PerlMem_malloc(VMS_MAXRSS);
9149   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
9150   if (int_pathify_dirspec(path, pathified) == NULL) {
9151     PerlMem_free(pathified);
9152     return NULL;
9153   }
9154
9155   unixified = NULL;
9156   if (buf == NULL) {
9157       Newx(unixified, VMS_MAXRSS, char);
9158   }
9159   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
9160     PerlMem_free(pathified);
9161     if (unixified) Safefree(unixified);
9162     return NULL;
9163   }
9164   PerlMem_free(pathified);
9165   if (buf) {
9166     return buf;
9167   }
9168   else if (ts) {
9169     unixlen = strlen(unixified);
9170     Newx(cp,unixlen+1,char);
9171     memcpy(cp,unixified,unixlen);
9172     cp[unixlen] = '\0';
9173     Safefree(unixified);
9174     return cp;
9175   }
9176   else {
9177     strcpy(__tounixpath_retbuf,unixified);
9178     Safefree(unixified);
9179     return __tounixpath_retbuf;
9180   }
9181
9182 }  /* end of do_tounixpath() */
9183 /*}}}*/
9184 /* External entry points */
9185 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
9186   { return do_tounixpath(path,buf,0,NULL); }
9187 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
9188   { return do_tounixpath(path,buf,1,NULL); }
9189 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9190   { return do_tounixpath(path,buf,0,utf8_fl); }
9191 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9192   { return do_tounixpath(path,buf,1,utf8_fl); }
9193
9194 /*
9195  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
9196  *
9197  *****************************************************************************
9198  *                                                                           *
9199  *  Copyright (C) 1989-1994, 2007 by                                         *
9200  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
9201  *                                                                           *
9202  *  Permission is hereby granted for the reproduction of this software       *
9203  *  on condition that this copyright notice is included in source            *
9204  *  distributions of the software.  The code may be modified and             *
9205  *  distributed under the same terms as Perl itself.                         *
9206  *                                                                           *
9207  *  27-Aug-1994 Modified for inclusion in perl5                              *
9208  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
9209  *****************************************************************************
9210  */
9211
9212 /*
9213  * getredirection() is intended to aid in porting C programs
9214  * to VMS (Vax-11 C).  The native VMS environment does not support
9215  * '>' and '<' I/O redirection, or command line wild card expansion,
9216  * or a command line pipe mechanism using the '|' AND background
9217  * command execution '&'.  All of these capabilities are provided to any
9218  * C program which calls this procedure as the first thing in the
9219  * main program.
9220  * The piping mechanism will probably work with almost any 'filter' type
9221  * of program.  With suitable modification, it may useful for other
9222  * portability problems as well.
9223  *
9224  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
9225  */
9226 struct list_item
9227     {
9228     struct list_item *next;
9229     char *value;
9230     };
9231
9232 static void add_item(struct list_item **head,
9233                      struct list_item **tail,
9234                      char *value,
9235                      int *count);
9236
9237 static void mp_expand_wild_cards(pTHX_ char *item,
9238                                 struct list_item **head,
9239                                 struct list_item **tail,
9240                                 int *count);
9241
9242 static int background_process(pTHX_ int argc, char **argv);
9243
9244 static void pipe_and_fork(pTHX_ char **cmargv);
9245
9246 /*{{{ void getredirection(int *ac, char ***av)*/
9247 static void
9248 mp_getredirection(pTHX_ int *ac, char ***av)
9249 /*
9250  * Process vms redirection arg's.  Exit if any error is seen.
9251  * If getredirection() processes an argument, it is erased
9252  * from the vector.  getredirection() returns a new argc and argv value.
9253  * In the event that a background command is requested (by a trailing "&"),
9254  * this routine creates a background subprocess, and simply exits the program.
9255  *
9256  * Warning: do not try to simplify the code for vms.  The code
9257  * presupposes that getredirection() is called before any data is
9258  * read from stdin or written to stdout.
9259  *
9260  * Normal usage is as follows:
9261  *
9262  *      main(argc, argv)
9263  *      int             argc;
9264  *      char            *argv[];
9265  *      {
9266  *              getredirection(&argc, &argv);
9267  *      }
9268  */
9269 {
9270     int                 argc = *ac;     /* Argument Count         */
9271     char                **argv = *av;   /* Argument Vector        */
9272     char                *ap;            /* Argument pointer       */
9273     int                 j;              /* argv[] index           */
9274     int                 item_count = 0; /* Count of Items in List */
9275     struct list_item    *list_head = 0; /* First Item in List       */
9276     struct list_item    *list_tail;     /* Last Item in List        */
9277     char                *in = NULL;     /* Input File Name          */
9278     char                *out = NULL;    /* Output File Name         */
9279     char                *outmode = "w"; /* Mode to Open Output File */
9280     char                *err = NULL;    /* Error File Name          */
9281     char                *errmode = "w"; /* Mode to Open Error File  */
9282     int                 cmargc = 0;     /* Piped Command Arg Count  */
9283     char                **cmargv = NULL;/* Piped Command Arg Vector */
9284
9285     /*
9286      * First handle the case where the last thing on the line ends with
9287      * a '&'.  This indicates the desire for the command to be run in a
9288      * subprocess, so we satisfy that desire.
9289      */
9290     ap = argv[argc-1];
9291     if (0 == strcmp("&", ap))
9292        exit(background_process(aTHX_ --argc, argv));
9293     if (*ap && '&' == ap[strlen(ap)-1])
9294         {
9295         ap[strlen(ap)-1] = '\0';
9296        exit(background_process(aTHX_ argc, argv));
9297         }
9298     /*
9299      * Now we handle the general redirection cases that involve '>', '>>',
9300      * '<', and pipes '|'.
9301      */
9302     for (j = 0; j < argc; ++j)
9303         {
9304         if (0 == strcmp("<", argv[j]))
9305             {
9306             if (j+1 >= argc)
9307                 {
9308                 fprintf(stderr,"No input file after < on command line");
9309                 exit(LIB$_WRONUMARG);
9310                 }
9311             in = argv[++j];
9312             continue;
9313             }
9314         if ('<' == *(ap = argv[j]))
9315             {
9316             in = 1 + ap;
9317             continue;
9318             }
9319         if (0 == strcmp(">", ap))
9320             {
9321             if (j+1 >= argc)
9322                 {
9323                 fprintf(stderr,"No output file after > on command line");
9324                 exit(LIB$_WRONUMARG);
9325                 }
9326             out = argv[++j];
9327             continue;
9328             }
9329         if ('>' == *ap)
9330             {
9331             if ('>' == ap[1])
9332                 {
9333                 outmode = "a";
9334                 if ('\0' == ap[2])
9335                     out = argv[++j];
9336                 else
9337                     out = 2 + ap;
9338                 }
9339             else
9340                 out = 1 + ap;
9341             if (j >= argc)
9342                 {
9343                 fprintf(stderr,"No output file after > or >> on command line");
9344                 exit(LIB$_WRONUMARG);
9345                 }
9346             continue;
9347             }
9348         if (('2' == *ap) && ('>' == ap[1]))
9349             {
9350             if ('>' == ap[2])
9351                 {
9352                 errmode = "a";
9353                 if ('\0' == ap[3])
9354                     err = argv[++j];
9355                 else
9356                     err = 3 + ap;
9357                 }
9358             else
9359                 if ('\0' == ap[2])
9360                     err = argv[++j];
9361                 else
9362                     err = 2 + ap;
9363             if (j >= argc)
9364                 {
9365                 fprintf(stderr,"No output file after 2> or 2>> on command line");
9366                 exit(LIB$_WRONUMARG);
9367                 }
9368             continue;
9369             }
9370         if (0 == strcmp("|", argv[j]))
9371             {
9372             if (j+1 >= argc)
9373                 {
9374                 fprintf(stderr,"No command into which to pipe on command line");
9375                 exit(LIB$_WRONUMARG);
9376                 }
9377             cmargc = argc-(j+1);
9378             cmargv = &argv[j+1];
9379             argc = j;
9380             continue;
9381             }
9382         if ('|' == *(ap = argv[j]))
9383             {
9384             ++argv[j];
9385             cmargc = argc-j;
9386             cmargv = &argv[j];
9387             argc = j;
9388             continue;
9389             }
9390         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9391         }
9392     /*
9393      * Allocate and fill in the new argument vector, Some Unix's terminate
9394      * the list with an extra null pointer.
9395      */
9396     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9397     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9398     *av = argv;
9399     for (j = 0; j < item_count; ++j, list_head = list_head->next)
9400         argv[j] = list_head->value;
9401     *ac = item_count;
9402     if (cmargv != NULL)
9403         {
9404         if (out != NULL)
9405             {
9406             fprintf(stderr,"'|' and '>' may not both be specified on command line");
9407             exit(LIB$_INVARGORD);
9408             }
9409         pipe_and_fork(aTHX_ cmargv);
9410         }
9411
9412     /* Check for input from a pipe (mailbox) */
9413
9414     if (in == NULL && 1 == isapipe(0))
9415         {
9416         char mbxname[L_tmpnam];
9417         long int bufsize;
9418         long int dvi_item = DVI$_DEVBUFSIZ;
9419         $DESCRIPTOR(mbxnam, "");
9420         $DESCRIPTOR(mbxdevnam, "");
9421
9422         /* Input from a pipe, reopen it in binary mode to disable       */
9423         /* carriage control processing.                                 */
9424
9425         fgetname(stdin, mbxname, 1);
9426         mbxnam.dsc$a_pointer = mbxname;
9427         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9428         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9429         mbxdevnam.dsc$a_pointer = mbxname;
9430         mbxdevnam.dsc$w_length = sizeof(mbxname);
9431         dvi_item = DVI$_DEVNAM;
9432         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9433         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9434         set_errno(0);
9435         set_vaxc_errno(1);
9436         freopen(mbxname, "rb", stdin);
9437         if (errno != 0)
9438             {
9439             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9440             exit(vaxc$errno);
9441             }
9442         }
9443     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9444         {
9445         fprintf(stderr,"Can't open input file %s as stdin",in);
9446         exit(vaxc$errno);
9447         }
9448     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9449         {
9450         fprintf(stderr,"Can't open output file %s as stdout",out);
9451         exit(vaxc$errno);
9452         }
9453         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
9454
9455     if (err != NULL) {
9456         if (strcmp(err,"&1") == 0) {
9457             dup2(fileno(stdout), fileno(stderr));
9458             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
9459         } else {
9460         FILE *tmperr;
9461         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9462             {
9463             fprintf(stderr,"Can't open error file %s as stderr",err);
9464             exit(vaxc$errno);
9465             }
9466             fclose(tmperr);
9467            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9468                 {
9469                 exit(vaxc$errno);
9470                 }
9471             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
9472         }
9473         }
9474 #ifdef ARGPROC_DEBUG
9475     PerlIO_printf(Perl_debug_log, "Arglist:\n");
9476     for (j = 0; j < *ac;  ++j)
9477         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9478 #endif
9479    /* Clear errors we may have hit expanding wildcards, so they don't
9480       show up in Perl's $! later */
9481    set_errno(0); set_vaxc_errno(1);
9482 }  /* end of getredirection() */
9483 /*}}}*/
9484
9485 static void add_item(struct list_item **head,
9486                      struct list_item **tail,
9487                      char *value,
9488                      int *count)
9489 {
9490     if (*head == 0)
9491         {
9492         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9493         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9494         *tail = *head;
9495         }
9496     else {
9497         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9498         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9499         *tail = (*tail)->next;
9500         }
9501     (*tail)->value = value;
9502     ++(*count);
9503 }
9504
9505 static void mp_expand_wild_cards(pTHX_ char *item,
9506                               struct list_item **head,
9507                               struct list_item **tail,
9508                               int *count)
9509 {
9510 int expcount = 0;
9511 unsigned long int context = 0;
9512 int isunix = 0;
9513 int item_len = 0;
9514 char *had_version;
9515 char *had_device;
9516 int had_directory;
9517 char *devdir,*cp;
9518 char *vmsspec;
9519 $DESCRIPTOR(filespec, "");
9520 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9521 $DESCRIPTOR(resultspec, "");
9522 unsigned long int lff_flags = 0;
9523 int sts;
9524 int rms_sts;
9525
9526 #ifdef VMS_LONGNAME_SUPPORT
9527     lff_flags = LIB$M_FIL_LONG_NAMES;
9528 #endif
9529
9530     for (cp = item; *cp; cp++) {
9531         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9532         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9533     }
9534     if (!*cp || isspace(*cp))
9535         {
9536         add_item(head, tail, item, count);
9537         return;
9538         }
9539     else
9540         {
9541      /* "double quoted" wild card expressions pass as is */
9542      /* From DCL that means using e.g.:                  */
9543      /* perl program """perl.*"""                        */
9544      item_len = strlen(item);
9545      if ( '"' == *item && '"' == item[item_len-1] )
9546        {
9547        item++;
9548        item[item_len-2] = '\0';
9549        add_item(head, tail, item, count);
9550        return;
9551        }
9552      }
9553     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9554     resultspec.dsc$b_class = DSC$K_CLASS_D;
9555     resultspec.dsc$a_pointer = NULL;
9556     vmsspec = PerlMem_malloc(VMS_MAXRSS);
9557     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9558     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9559       filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9560     if (!isunix || !filespec.dsc$a_pointer)
9561       filespec.dsc$a_pointer = item;
9562     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9563     /*
9564      * Only return version specs, if the caller specified a version
9565      */
9566     had_version = strchr(item, ';');
9567     /*
9568      * Only return device and directory specs, if the caller specifed either.
9569      */
9570     had_device = strchr(item, ':');
9571     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9572
9573     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9574                                  (&filespec, &resultspec, &context,
9575                                   &defaultspec, 0, &rms_sts, &lff_flags)))
9576         {
9577         char *string;
9578         char *c;
9579
9580         string = PerlMem_malloc(resultspec.dsc$w_length+1);
9581         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9582         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
9583         string[resultspec.dsc$w_length] = '\0';
9584         if (NULL == had_version)
9585             *(strrchr(string, ';')) = '\0';
9586         if ((!had_directory) && (had_device == NULL))
9587             {
9588             if (NULL == (devdir = strrchr(string, ']')))
9589                 devdir = strrchr(string, '>');
9590             strcpy(string, devdir + 1);
9591             }
9592         /*
9593          * Be consistent with what the C RTL has already done to the rest of
9594          * the argv items and lowercase all of these names.
9595          */
9596         if (!decc_efs_case_preserve) {
9597             for (c = string; *c; ++c)
9598             if (isupper(*c))
9599                 *c = tolower(*c);
9600         }
9601         if (isunix) trim_unixpath(string,item,1);
9602         add_item(head, tail, string, count);
9603         ++expcount;
9604     }
9605     PerlMem_free(vmsspec);
9606     if (sts != RMS$_NMF)
9607         {
9608         set_vaxc_errno(sts);
9609         switch (sts)
9610             {
9611             case RMS$_FNF: case RMS$_DNF:
9612                 set_errno(ENOENT); break;
9613             case RMS$_DIR:
9614                 set_errno(ENOTDIR); break;
9615             case RMS$_DEV:
9616                 set_errno(ENODEV); break;
9617             case RMS$_FNM: case RMS$_SYN:
9618                 set_errno(EINVAL); break;
9619             case RMS$_PRV:
9620                 set_errno(EACCES); break;
9621             default:
9622                 _ckvmssts_noperl(sts);
9623             }
9624         }
9625     if (expcount == 0)
9626         add_item(head, tail, item, count);
9627     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9628     _ckvmssts_noperl(lib$find_file_end(&context));
9629 }
9630
9631 static int child_st[2];/* Event Flag set when child process completes   */
9632
9633 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
9634
9635 static unsigned long int exit_handler(int *status)
9636 {
9637 short iosb[4];
9638
9639     if (0 == child_st[0])
9640         {
9641 #ifdef ARGPROC_DEBUG
9642         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
9643 #endif
9644         fflush(stdout);     /* Have to flush pipe for binary data to    */
9645                             /* terminate properly -- <tp@mccall.com>    */
9646         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
9647         sys$dassgn(child_chan);
9648         fclose(stdout);
9649         sys$synch(0, child_st);
9650         }
9651     return(1);
9652 }
9653
9654 static void sig_child(int chan)
9655 {
9656 #ifdef ARGPROC_DEBUG
9657     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
9658 #endif
9659     if (child_st[0] == 0)
9660         child_st[0] = 1;
9661 }
9662
9663 static struct exit_control_block exit_block =
9664     {
9665     0,
9666     exit_handler,
9667     1,
9668     &exit_block.exit_status,
9669     0
9670     };
9671
9672 static void
9673 pipe_and_fork(pTHX_ char **cmargv)
9674 {
9675     PerlIO *fp;
9676     struct dsc$descriptor_s *vmscmd;
9677     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9678     int sts, j, l, ismcr, quote, tquote = 0;
9679
9680     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9681     vms_execfree(vmscmd);
9682
9683     j = l = 0;
9684     p = subcmd;
9685     q = cmargv[0];
9686     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
9687               && toupper(*(q+2)) == 'R' && !*(q+3);
9688
9689     while (q && l < MAX_DCL_LINE_LENGTH) {
9690         if (!*q) {
9691             if (j > 0 && quote) {
9692                 *p++ = '"';
9693                 l++;
9694             }
9695             q = cmargv[++j];
9696             if (q) {
9697                 if (ismcr && j > 1) quote = 1;
9698                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
9699                 *p++ = ' ';
9700                 l++;
9701                 if (quote || tquote) {
9702                     *p++ = '"';
9703                     l++;
9704                 }
9705             }
9706         } else {
9707             if ((quote||tquote) && *q == '"') {
9708                 *p++ = '"';
9709                 l++;
9710             }
9711             *p++ = *q++;
9712             l++;
9713         }
9714     }
9715     *p = '\0';
9716
9717     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9718     if (fp == NULL) {
9719         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9720     }
9721 }
9722
9723 static int background_process(pTHX_ int argc, char **argv)
9724 {
9725 char command[MAX_DCL_SYMBOL + 1] = "$";
9726 $DESCRIPTOR(value, "");
9727 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9728 static $DESCRIPTOR(null, "NLA0:");
9729 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9730 char pidstring[80];
9731 $DESCRIPTOR(pidstr, "");
9732 int pid;
9733 unsigned long int flags = 17, one = 1, retsts;
9734 int len;
9735
9736     strcat(command, argv[0]);
9737     len = strlen(command);
9738     while (--argc && (len < MAX_DCL_SYMBOL))
9739         {
9740         strcat(command, " \"");
9741         strcat(command, *(++argv));
9742         strcat(command, "\"");
9743         len = strlen(command);
9744         }
9745     value.dsc$a_pointer = command;
9746     value.dsc$w_length = strlen(value.dsc$a_pointer);
9747     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9748     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9749     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9750         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9751     }
9752     else {
9753         _ckvmssts_noperl(retsts);
9754     }
9755 #ifdef ARGPROC_DEBUG
9756     PerlIO_printf(Perl_debug_log, "%s\n", command);
9757 #endif
9758     sprintf(pidstring, "%08X", pid);
9759     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9760     pidstr.dsc$a_pointer = pidstring;
9761     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9762     lib$set_symbol(&pidsymbol, &pidstr);
9763     return(SS$_NORMAL);
9764 }
9765 /*}}}*/
9766 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9767
9768
9769 /* OS-specific initialization at image activation (not thread startup) */
9770 /* Older VAXC header files lack these constants */
9771 #ifndef JPI$_RIGHTS_SIZE
9772 #  define JPI$_RIGHTS_SIZE 817
9773 #endif
9774 #ifndef KGB$M_SUBSYSTEM
9775 #  define KGB$M_SUBSYSTEM 0x8
9776 #endif
9777
9778 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9779
9780 /*{{{void vms_image_init(int *, char ***)*/
9781 void
9782 vms_image_init(int *argcp, char ***argvp)
9783 {
9784   int status;
9785   char eqv[LNM$C_NAMLENGTH+1] = "";
9786   unsigned int len, tabct = 8, tabidx = 0;
9787   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9788   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9789   unsigned short int dummy, rlen;
9790   struct dsc$descriptor_s **tabvec;
9791 #if defined(PERL_IMPLICIT_CONTEXT)
9792   pTHX = NULL;
9793 #endif
9794   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
9795                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
9796                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9797                                  {          0,                0,    0,      0} };
9798
9799 #ifdef KILL_BY_SIGPRC
9800     Perl_csighandler_init();
9801 #endif
9802
9803 #if __CRTL_VER >= 70300000 && !defined(__VAX)
9804     /* This was moved from the pre-image init handler because on threaded */
9805     /* Perl it was always returning 0 for the default value. */
9806     status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9807     if (status > 0) {
9808         int s;
9809         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9810         if (s > 0) {
9811             int initial;
9812             initial = decc$feature_get_value(s, 4);
9813             if (initial > 0) {
9814                 /* initial is: 0 if nothing has set the feature */
9815                 /*            -1 if initialized to default */
9816                 /*             1 if set by logical name */
9817                 /*             2 if set by decc$feature_set_value */
9818                 decc_disable_posix_root = decc$feature_get_value(s, 1);
9819
9820                 /* If the value is not valid, force the feature off */
9821                 if (decc_disable_posix_root < 0) {
9822                     decc$feature_set_value(s, 1, 1);
9823                     decc_disable_posix_root = 1;
9824                 }
9825             }
9826             else {
9827                 /* Nothing has asked for it explicitly, so use our own default. */
9828                 decc_disable_posix_root = 1;
9829                 decc$feature_set_value(s, 1, 1);
9830             }
9831         }
9832     }
9833 #endif
9834
9835   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9836   _ckvmssts_noperl(iosb[0]);
9837   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9838     if (iprv[i]) {           /* Running image installed with privs? */
9839       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
9840       will_taint = TRUE;
9841       break;
9842     }
9843   }
9844   /* Rights identifiers might trigger tainting as well. */
9845   if (!will_taint && (rlen || rsz)) {
9846     while (rlen < rsz) {
9847       /* We didn't get all the identifiers on the first pass.  Allocate a
9848        * buffer much larger than $GETJPI wants (rsz is size in bytes that
9849        * were needed to hold all identifiers at time of last call; we'll
9850        * allocate that many unsigned long ints), and go back and get 'em.
9851        * If it gave us less than it wanted to despite ample buffer space,
9852        * something's broken.  Is your system missing a system identifier?
9853        */
9854       if (rsz <= jpilist[1].buflen) {
9855          /* Perl_croak accvios when used this early in startup. */
9856          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9857                          rsz, (unsigned long) jpilist[1].buflen,
9858                          "Check your rights database for corruption.\n");
9859          exit(SS$_ABORT);
9860       }
9861       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9862       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9863       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9864       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9865       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9866       _ckvmssts_noperl(iosb[0]);
9867     }
9868     mask = jpilist[1].bufadr;
9869     /* Check attribute flags for each identifier (2nd longword); protected
9870      * subsystem identifiers trigger tainting.
9871      */
9872     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9873       if (mask[i] & KGB$M_SUBSYSTEM) {
9874         will_taint = TRUE;
9875         break;
9876       }
9877     }
9878     if (mask != rlst) PerlMem_free(mask);
9879   }
9880
9881   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9882    * logical, some versions of the CRTL will add a phanthom /000000/
9883    * directory.  This needs to be removed.
9884    */
9885   if (decc_filename_unix_report) {
9886   char * zeros;
9887   int ulen;
9888     ulen = strlen(argvp[0][0]);
9889     if (ulen > 7) {
9890       zeros = strstr(argvp[0][0], "/000000/");
9891       if (zeros != NULL) {
9892         int mlen;
9893         mlen = ulen - (zeros - argvp[0][0]) - 7;
9894         memmove(zeros, &zeros[7], mlen);
9895         ulen = ulen - 7;
9896         argvp[0][0][ulen] = '\0';
9897       }
9898     }
9899     /* It also may have a trailing dot that needs to be removed otherwise
9900      * it will be converted to VMS mode incorrectly.
9901      */
9902     ulen--;
9903     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9904       argvp[0][0][ulen] = '\0';
9905   }
9906
9907   /* We need to use this hack to tell Perl it should run with tainting,
9908    * since its tainting flag may be part of the PL_curinterp struct, which
9909    * hasn't been allocated when vms_image_init() is called.
9910    */
9911   if (will_taint) {
9912     char **newargv, **oldargv;
9913     oldargv = *argvp;
9914     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9915     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9916     newargv[0] = oldargv[0];
9917     newargv[1] = PerlMem_malloc(3 * sizeof(char));
9918     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9919     strcpy(newargv[1], "-T");
9920     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9921     (*argcp)++;
9922     newargv[*argcp] = NULL;
9923     /* We orphan the old argv, since we don't know where it's come from,
9924      * so we don't know how to free it.
9925      */
9926     *argvp = newargv;
9927   }
9928   else {  /* Did user explicitly request tainting? */
9929     int i;
9930     char *cp, **av = *argvp;
9931     for (i = 1; i < *argcp; i++) {
9932       if (*av[i] != '-') break;
9933       for (cp = av[i]+1; *cp; cp++) {
9934         if (*cp == 'T') { will_taint = 1; break; }
9935         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9936                   strchr("DFIiMmx",*cp)) break;
9937       }
9938       if (will_taint) break;
9939     }
9940   }
9941
9942   for (tabidx = 0;
9943        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9944        tabidx++) {
9945     if (!tabidx) {
9946       tabvec = (struct dsc$descriptor_s **)
9947             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9948       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9949     }
9950     else if (tabidx >= tabct) {
9951       tabct += 8;
9952       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9953       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9954     }
9955     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9956     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9957     tabvec[tabidx]->dsc$w_length  = 0;
9958     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9959     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
9960     tabvec[tabidx]->dsc$a_pointer = NULL;
9961     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9962   }
9963   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9964
9965   getredirection(argcp,argvp);
9966 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9967   {
9968 # include <reentrancy.h>
9969   decc$set_reentrancy(C$C_MULTITHREAD);
9970   }
9971 #endif
9972   return;
9973 }
9974 /*}}}*/
9975
9976
9977 /* trim_unixpath()
9978  * Trim Unix-style prefix off filespec, so it looks like what a shell
9979  * glob expansion would return (i.e. from specified prefix on, not
9980  * full path).  Note that returned filespec is Unix-style, regardless
9981  * of whether input filespec was VMS-style or Unix-style.
9982  *
9983  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9984  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9985  * vector of options; at present, only bit 0 is used, and if set tells
9986  * trim unixpath to try the current default directory as a prefix when
9987  * presented with a possibly ambiguous ... wildcard.
9988  *
9989  * Returns !=0 on success, with trimmed filespec replacing contents of
9990  * fspec, and 0 on failure, with contents of fpsec unchanged.
9991  */
9992 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9993 int
9994 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9995 {
9996   char *unixified, *unixwild,
9997        *template, *base, *end, *cp1, *cp2;
9998   register int tmplen, reslen = 0, dirs = 0;
9999
10000   if (!wildspec || !fspec) return 0;
10001
10002   unixwild = PerlMem_malloc(VMS_MAXRSS);
10003   if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10004   template = unixwild;
10005   if (strpbrk(wildspec,"]>:") != NULL) {
10006     if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
10007         PerlMem_free(unixwild);
10008         return 0;
10009     }
10010   }
10011   else {
10012     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
10013     unixwild[VMS_MAXRSS-1] = 0;
10014   }
10015   unixified = PerlMem_malloc(VMS_MAXRSS);
10016   if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10017   if (strpbrk(fspec,"]>:") != NULL) {
10018     if (int_tounixspec(fspec, unixified, NULL) == NULL) {
10019         PerlMem_free(unixwild);
10020         PerlMem_free(unixified);
10021         return 0;
10022     }
10023     else base = unixified;
10024     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
10025      * check to see that final result fits into (isn't longer than) fspec */
10026     reslen = strlen(fspec);
10027   }
10028   else base = fspec;
10029
10030   /* No prefix or absolute path on wildcard, so nothing to remove */
10031   if (!*template || *template == '/') {
10032     PerlMem_free(unixwild);
10033     if (base == fspec) {
10034         PerlMem_free(unixified);
10035         return 1;
10036     }
10037     tmplen = strlen(unixified);
10038     if (tmplen > reslen) {
10039         PerlMem_free(unixified);
10040         return 0;  /* not enough space */
10041     }
10042     /* Copy unixified resultant, including trailing NUL */
10043     memmove(fspec,unixified,tmplen+1);
10044     PerlMem_free(unixified);
10045     return 1;
10046   }
10047
10048   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
10049   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
10050     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
10051     for (cp1 = end ;cp1 >= base; cp1--)
10052       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
10053         { cp1++; break; }
10054     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
10055     PerlMem_free(unixified);
10056     PerlMem_free(unixwild);
10057     return 1;
10058   }
10059   else {
10060     char *tpl, *lcres;
10061     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
10062     int ells = 1, totells, segdirs, match;
10063     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
10064                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10065
10066     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
10067     totells = ells;
10068     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
10069     tpl = PerlMem_malloc(VMS_MAXRSS);
10070     if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10071     if (ellipsis == template && opts & 1) {
10072       /* Template begins with an ellipsis.  Since we can't tell how many
10073        * directory names at the front of the resultant to keep for an
10074        * arbitrary starting point, we arbitrarily choose the current
10075        * default directory as a starting point.  If it's there as a prefix,
10076        * clip it off.  If not, fall through and act as if the leading
10077        * ellipsis weren't there (i.e. return shortest possible path that
10078        * could match template).
10079        */
10080       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
10081           PerlMem_free(tpl);
10082           PerlMem_free(unixified);
10083           PerlMem_free(unixwild);
10084           return 0;
10085       }
10086       if (!decc_efs_case_preserve) {
10087         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
10088           if (_tolower(*cp1) != _tolower(*cp2)) break;
10089       }
10090       segdirs = dirs - totells;  /* Min # of dirs we must have left */
10091       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
10092       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
10093         memmove(fspec,cp2+1,end - cp2);
10094         PerlMem_free(tpl);
10095         PerlMem_free(unixified);
10096         PerlMem_free(unixwild);
10097         return 1;
10098       }
10099     }
10100     /* First off, back up over constant elements at end of path */
10101     if (dirs) {
10102       for (front = end ; front >= base; front--)
10103          if (*front == '/' && !dirs--) { front++; break; }
10104     }
10105     lcres = PerlMem_malloc(VMS_MAXRSS);
10106     if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10107     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
10108          cp1++,cp2++) {
10109             if (!decc_efs_case_preserve) {
10110                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
10111             }
10112             else {
10113                 *cp2 = *cp1;
10114             }
10115     }
10116     if (cp1 != '\0') {
10117         PerlMem_free(tpl);
10118         PerlMem_free(unixified);
10119         PerlMem_free(unixwild);
10120         PerlMem_free(lcres);
10121         return 0;  /* Path too long. */
10122     }
10123     lcend = cp2;
10124     *cp2 = '\0';  /* Pick up with memcpy later */
10125     lcfront = lcres + (front - base);
10126     /* Now skip over each ellipsis and try to match the path in front of it. */
10127     while (ells--) {
10128       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
10129         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
10130             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
10131       if (cp1 < template) break; /* template started with an ellipsis */
10132       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
10133         ellipsis = cp1; continue;
10134       }
10135       wilddsc.dsc$a_pointer = tpl;
10136       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
10137       nextell = cp1;
10138       for (segdirs = 0, cp2 = tpl;
10139            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
10140            cp1++, cp2++) {
10141          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
10142          else {
10143             if (!decc_efs_case_preserve) {
10144               *cp2 = _tolower(*cp1);  /* else lowercase for match */
10145             }
10146             else {
10147               *cp2 = *cp1;  /* else preserve case for match */
10148             }
10149          }
10150          if (*cp2 == '/') segdirs++;
10151       }
10152       if (cp1 != ellipsis - 1) {
10153           PerlMem_free(tpl);
10154           PerlMem_free(unixified);
10155           PerlMem_free(unixwild);
10156           PerlMem_free(lcres);
10157           return 0; /* Path too long */
10158       }
10159       /* Back up at least as many dirs as in template before matching */
10160       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
10161         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
10162       for (match = 0; cp1 > lcres;) {
10163         resdsc.dsc$a_pointer = cp1;
10164         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
10165           match++;
10166           if (match == 1) lcfront = cp1;
10167         }
10168         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
10169       }
10170       if (!match) {
10171         PerlMem_free(tpl);
10172         PerlMem_free(unixified);
10173         PerlMem_free(unixwild);
10174         PerlMem_free(lcres);
10175         return 0;  /* Can't find prefix ??? */
10176       }
10177       if (match > 1 && opts & 1) {
10178         /* This ... wildcard could cover more than one set of dirs (i.e.
10179          * a set of similar dir names is repeated).  If the template
10180          * contains more than 1 ..., upstream elements could resolve the
10181          * ambiguity, but it's not worth a full backtracking setup here.
10182          * As a quick heuristic, clip off the current default directory
10183          * if it's present to find the trimmed spec, else use the
10184          * shortest string that this ... could cover.
10185          */
10186         char def[NAM$C_MAXRSS+1], *st;
10187
10188         if (getcwd(def, sizeof def,0) == NULL) {
10189             PerlMem_free(unixified);
10190             PerlMem_free(unixwild);
10191             PerlMem_free(lcres);
10192             PerlMem_free(tpl);
10193             return 0;
10194         }
10195         if (!decc_efs_case_preserve) {
10196           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
10197             if (_tolower(*cp1) != _tolower(*cp2)) break;
10198         }
10199         segdirs = dirs - totells;  /* Min # of dirs we must have left */
10200         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
10201         if (*cp1 == '\0' && *cp2 == '/') {
10202           memmove(fspec,cp2+1,end - cp2);
10203           PerlMem_free(tpl);
10204           PerlMem_free(unixified);
10205           PerlMem_free(unixwild);
10206           PerlMem_free(lcres);
10207           return 1;
10208         }
10209         /* Nope -- stick with lcfront from above and keep going. */
10210       }
10211     }
10212     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
10213     PerlMem_free(tpl);
10214     PerlMem_free(unixified);
10215     PerlMem_free(unixwild);
10216     PerlMem_free(lcres);
10217     return 1;
10218     ellipsis = nextell;
10219   }
10220
10221 }  /* end of trim_unixpath() */
10222 /*}}}*/
10223
10224
10225 /*
10226  *  VMS readdir() routines.
10227  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
10228  *
10229  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
10230  *  Minor modifications to original routines.
10231  */
10232
10233 /* readdir may have been redefined by reentr.h, so make sure we get
10234  * the local version for what we do here.
10235  */
10236 #ifdef readdir
10237 # undef readdir
10238 #endif
10239 #if !defined(PERL_IMPLICIT_CONTEXT)
10240 # define readdir Perl_readdir
10241 #else
10242 # define readdir(a) Perl_readdir(aTHX_ a)
10243 #endif
10244
10245     /* Number of elements in vms_versions array */
10246 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
10247
10248 /*
10249  *  Open a directory, return a handle for later use.
10250  */
10251 /*{{{ DIR *opendir(char*name) */
10252 DIR *
10253 Perl_opendir(pTHX_ const char *name)
10254 {
10255     DIR *dd;
10256     char *dir;
10257     Stat_t sb;
10258
10259     Newx(dir, VMS_MAXRSS, char);
10260     if (int_tovmspath(name, dir, NULL) == NULL) {
10261       Safefree(dir);
10262       return NULL;
10263     }
10264     /* Check access before stat; otherwise stat does not
10265      * accurately report whether it's a directory.
10266      */
10267     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
10268       /* cando_by_name has already set errno */
10269       Safefree(dir);
10270       return NULL;
10271     }
10272     if (flex_stat(dir,&sb) == -1) return NULL;
10273     if (!S_ISDIR(sb.st_mode)) {
10274       Safefree(dir);
10275       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
10276       return NULL;
10277     }
10278     /* Get memory for the handle, and the pattern. */
10279     Newx(dd,1,DIR);
10280     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
10281
10282     /* Fill in the fields; mainly playing with the descriptor. */
10283     sprintf(dd->pattern, "%s*.*",dir);
10284     Safefree(dir);
10285     dd->context = 0;
10286     dd->count = 0;
10287     dd->flags = 0;
10288     /* By saying we always want the result of readdir() in unix format, we
10289      * are really saying we want all the escapes removed.  Otherwise the caller,
10290      * having no way to know whether it's already in VMS format, might send it
10291      * through tovmsspec again, thus double escaping.
10292      */
10293     dd->flags = PERL_VMSDIR_M_UNIXSPECS;
10294     dd->pat.dsc$a_pointer = dd->pattern;
10295     dd->pat.dsc$w_length = strlen(dd->pattern);
10296     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
10297     dd->pat.dsc$b_class = DSC$K_CLASS_S;
10298 #if defined(USE_ITHREADS)
10299     Newx(dd->mutex,1,perl_mutex);
10300     MUTEX_INIT( (perl_mutex *) dd->mutex );
10301 #else
10302     dd->mutex = NULL;
10303 #endif
10304
10305     return dd;
10306 }  /* end of opendir() */
10307 /*}}}*/
10308
10309 /*
10310  *  Set the flag to indicate we want versions or not.
10311  */
10312 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10313 void
10314 vmsreaddirversions(DIR *dd, int flag)
10315 {
10316     if (flag)
10317         dd->flags |= PERL_VMSDIR_M_VERSIONS;
10318     else
10319         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10320 }
10321 /*}}}*/
10322
10323 /*
10324  *  Free up an opened directory.
10325  */
10326 /*{{{ void closedir(DIR *dd)*/
10327 void
10328 Perl_closedir(DIR *dd)
10329 {
10330     int sts;
10331
10332     sts = lib$find_file_end(&dd->context);
10333     Safefree(dd->pattern);
10334 #if defined(USE_ITHREADS)
10335     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10336     Safefree(dd->mutex);
10337 #endif
10338     Safefree(dd);
10339 }
10340 /*}}}*/
10341
10342 /*
10343  *  Collect all the version numbers for the current file.
10344  */
10345 static void
10346 collectversions(pTHX_ DIR *dd)
10347 {
10348     struct dsc$descriptor_s     pat;
10349     struct dsc$descriptor_s     res;
10350     struct dirent *e;
10351     char *p, *text, *buff;
10352     int i;
10353     unsigned long context, tmpsts;
10354
10355     /* Convenient shorthand. */
10356     e = &dd->entry;
10357
10358     /* Add the version wildcard, ignoring the "*.*" put on before */
10359     i = strlen(dd->pattern);
10360     Newx(text,i + e->d_namlen + 3,char);
10361     strcpy(text, dd->pattern);
10362     sprintf(&text[i - 3], "%s;*", e->d_name);
10363
10364     /* Set up the pattern descriptor. */
10365     pat.dsc$a_pointer = text;
10366     pat.dsc$w_length = i + e->d_namlen - 1;
10367     pat.dsc$b_dtype = DSC$K_DTYPE_T;
10368     pat.dsc$b_class = DSC$K_CLASS_S;
10369
10370     /* Set up result descriptor. */
10371     Newx(buff, VMS_MAXRSS, char);
10372     res.dsc$a_pointer = buff;
10373     res.dsc$w_length = VMS_MAXRSS - 1;
10374     res.dsc$b_dtype = DSC$K_DTYPE_T;
10375     res.dsc$b_class = DSC$K_CLASS_S;
10376
10377     /* Read files, collecting versions. */
10378     for (context = 0, e->vms_verscount = 0;
10379          e->vms_verscount < VERSIZE(e);
10380          e->vms_verscount++) {
10381         unsigned long rsts;
10382         unsigned long flags = 0;
10383
10384 #ifdef VMS_LONGNAME_SUPPORT
10385         flags = LIB$M_FIL_LONG_NAMES;
10386 #endif
10387         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10388         if (tmpsts == RMS$_NMF || context == 0) break;
10389         _ckvmssts(tmpsts);
10390         buff[VMS_MAXRSS - 1] = '\0';
10391         if ((p = strchr(buff, ';')))
10392             e->vms_versions[e->vms_verscount] = atoi(p + 1);
10393         else
10394             e->vms_versions[e->vms_verscount] = -1;
10395     }
10396
10397     _ckvmssts(lib$find_file_end(&context));
10398     Safefree(text);
10399     Safefree(buff);
10400
10401 }  /* end of collectversions() */
10402
10403 /*
10404  *  Read the next entry from the directory.
10405  */
10406 /*{{{ struct dirent *readdir(DIR *dd)*/
10407 struct dirent *
10408 Perl_readdir(pTHX_ DIR *dd)
10409 {
10410     struct dsc$descriptor_s     res;
10411     char *p, *buff;
10412     unsigned long int tmpsts;
10413     unsigned long rsts;
10414     unsigned long flags = 0;
10415     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10416     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10417
10418     /* Set up result descriptor, and get next file. */
10419     Newx(buff, VMS_MAXRSS, char);
10420     res.dsc$a_pointer = buff;
10421     res.dsc$w_length = VMS_MAXRSS - 1;
10422     res.dsc$b_dtype = DSC$K_DTYPE_T;
10423     res.dsc$b_class = DSC$K_CLASS_S;
10424
10425 #ifdef VMS_LONGNAME_SUPPORT
10426     flags = LIB$M_FIL_LONG_NAMES;
10427 #endif
10428
10429     tmpsts = lib$find_file
10430         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10431     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
10432     if (!(tmpsts & 1)) {
10433       set_vaxc_errno(tmpsts);
10434       switch (tmpsts) {
10435         case RMS$_PRV:
10436           set_errno(EACCES); break;
10437         case RMS$_DEV:
10438           set_errno(ENODEV); break;
10439         case RMS$_DIR:
10440           set_errno(ENOTDIR); break;
10441         case RMS$_FNF: case RMS$_DNF:
10442           set_errno(ENOENT); break;
10443         default:
10444           set_errno(EVMSERR);
10445       }
10446       Safefree(buff);
10447       return NULL;
10448     }
10449     dd->count++;
10450     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10451     buff[res.dsc$w_length] = '\0';
10452     p = buff + res.dsc$w_length;
10453     while (--p >= buff) if (!isspace(*p)) break;
10454     *p = '\0';
10455     if (!decc_efs_case_preserve) {
10456       for (p = buff; *p; p++) *p = _tolower(*p);
10457     }
10458
10459     /* Skip any directory component and just copy the name. */
10460     sts = vms_split_path
10461        (buff,
10462         &v_spec,
10463         &v_len,
10464         &r_spec,
10465         &r_len,
10466         &d_spec,
10467         &d_len,
10468         &n_spec,
10469         &n_len,
10470         &e_spec,
10471         &e_len,
10472         &vs_spec,
10473         &vs_len);
10474
10475     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10476
10477         /* In Unix report mode, remove the ".dir;1" from the name */
10478         /* if it is a real directory. */
10479         if (decc_filename_unix_report || decc_efs_charset) {
10480             if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
10481                 Stat_t statbuf;
10482                 int ret_sts;
10483
10484                 ret_sts = flex_lstat(buff, &statbuf);
10485                 if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10486                     e_len = 0;
10487                     e_spec[0] = 0;
10488                 }
10489             }
10490         }
10491
10492         /* Drop NULL extensions on UNIX file specification */
10493         if ((e_len == 1) && decc_readdir_dropdotnotype) {
10494             e_len = 0;
10495             e_spec[0] = '\0';
10496         }
10497     }
10498
10499     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
10500     dd->entry.d_name[n_len + e_len] = '\0';
10501     dd->entry.d_namlen = strlen(dd->entry.d_name);
10502
10503     /* Convert the filename to UNIX format if needed */
10504     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10505
10506         /* Translate the encoded characters. */
10507         /* Fixme: Unicode handling could result in embedded 0 characters */
10508         if (strchr(dd->entry.d_name, '^') != NULL) {
10509             char new_name[256];
10510             char * q;
10511             p = dd->entry.d_name;
10512             q = new_name;
10513             while (*p != 0) {
10514                 int inchars_read, outchars_added;
10515                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10516                 p += inchars_read;
10517                 q += outchars_added;
10518                 /* fix-me */
10519                 /* if outchars_added > 1, then this is a wide file specification */
10520                 /* Wide file specifications need to be passed in Perl */
10521                 /* counted strings apparently with a Unicode flag */
10522             }
10523             *q = 0;
10524             strcpy(dd->entry.d_name, new_name);
10525             dd->entry.d_namlen = strlen(dd->entry.d_name);
10526         }
10527     }
10528
10529     dd->entry.vms_verscount = 0;
10530     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10531     Safefree(buff);
10532     return &dd->entry;
10533
10534 }  /* end of readdir() */
10535 /*}}}*/
10536
10537 /*
10538  *  Read the next entry from the directory -- thread-safe version.
10539  */
10540 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10541 int
10542 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10543 {
10544     int retval;
10545
10546     MUTEX_LOCK( (perl_mutex *) dd->mutex );
10547
10548     entry = readdir(dd);
10549     *result = entry;
10550     retval = ( *result == NULL ? errno : 0 );
10551
10552     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10553
10554     return retval;
10555
10556 }  /* end of readdir_r() */
10557 /*}}}*/
10558
10559 /*
10560  *  Return something that can be used in a seekdir later.
10561  */
10562 /*{{{ long telldir(DIR *dd)*/
10563 long
10564 Perl_telldir(DIR *dd)
10565 {
10566     return dd->count;
10567 }
10568 /*}}}*/
10569
10570 /*
10571  *  Return to a spot where we used to be.  Brute force.
10572  */
10573 /*{{{ void seekdir(DIR *dd,long count)*/
10574 void
10575 Perl_seekdir(pTHX_ DIR *dd, long count)
10576 {
10577     int old_flags;
10578
10579     /* If we haven't done anything yet... */
10580     if (dd->count == 0)
10581         return;
10582
10583     /* Remember some state, and clear it. */
10584     old_flags = dd->flags;
10585     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10586     _ckvmssts(lib$find_file_end(&dd->context));
10587     dd->context = 0;
10588
10589     /* The increment is in readdir(). */
10590     for (dd->count = 0; dd->count < count; )
10591         readdir(dd);
10592
10593     dd->flags = old_flags;
10594
10595 }  /* end of seekdir() */
10596 /*}}}*/
10597
10598 /* VMS subprocess management
10599  *
10600  * my_vfork() - just a vfork(), after setting a flag to record that
10601  * the current script is trying a Unix-style fork/exec.
10602  *
10603  * vms_do_aexec() and vms_do_exec() are called in response to the
10604  * perl 'exec' function.  If this follows a vfork call, then they
10605  * call out the regular perl routines in doio.c which do an
10606  * execvp (for those who really want to try this under VMS).
10607  * Otherwise, they do exactly what the perl docs say exec should
10608  * do - terminate the current script and invoke a new command
10609  * (See below for notes on command syntax.)
10610  *
10611  * do_aspawn() and do_spawn() implement the VMS side of the perl
10612  * 'system' function.
10613  *
10614  * Note on command arguments to perl 'exec' and 'system': When handled
10615  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10616  * are concatenated to form a DCL command string.  If the first non-numeric
10617  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10618  * the command string is handed off to DCL directly.  Otherwise,
10619  * the first token of the command is taken as the filespec of an image
10620  * to run.  The filespec is expanded using a default type of '.EXE' and
10621  * the process defaults for device, directory, etc., and if found, the resultant
10622  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10623  * the command string as parameters.  This is perhaps a bit complicated,
10624  * but I hope it will form a happy medium between what VMS folks expect
10625  * from lib$spawn and what Unix folks expect from exec.
10626  */
10627
10628 static int vfork_called;
10629
10630 /*{{{int my_vfork()*/
10631 int
10632 my_vfork()
10633 {
10634   vfork_called++;
10635   return vfork();
10636 }
10637 /*}}}*/
10638
10639
10640 static void
10641 vms_execfree(struct dsc$descriptor_s *vmscmd)
10642 {
10643   if (vmscmd) {
10644       if (vmscmd->dsc$a_pointer) {
10645           PerlMem_free(vmscmd->dsc$a_pointer);
10646       }
10647       PerlMem_free(vmscmd);
10648   }
10649 }
10650
10651 static char *
10652 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10653 {
10654   char *junk, *tmps = NULL;
10655   register size_t cmdlen = 0;
10656   size_t rlen;
10657   register SV **idx;
10658   STRLEN n_a;
10659
10660   idx = mark;
10661   if (really) {
10662     tmps = SvPV(really,rlen);
10663     if (*tmps) {
10664       cmdlen += rlen + 1;
10665       idx++;
10666     }
10667   }
10668
10669   for (idx++; idx <= sp; idx++) {
10670     if (*idx) {
10671       junk = SvPVx(*idx,rlen);
10672       cmdlen += rlen ? rlen + 1 : 0;
10673     }
10674   }
10675   Newx(PL_Cmd, cmdlen+1, char);
10676
10677   if (tmps && *tmps) {
10678     strcpy(PL_Cmd,tmps);
10679     mark++;
10680   }
10681   else *PL_Cmd = '\0';
10682   while (++mark <= sp) {
10683     if (*mark) {
10684       char *s = SvPVx(*mark,n_a);
10685       if (!*s) continue;
10686       if (*PL_Cmd) strcat(PL_Cmd," ");
10687       strcat(PL_Cmd,s);
10688     }
10689   }
10690   return PL_Cmd;
10691
10692 }  /* end of setup_argstr() */
10693
10694
10695 static unsigned long int
10696 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10697                    struct dsc$descriptor_s **pvmscmd)
10698 {
10699   char * vmsspec;
10700   char * resspec;
10701   char image_name[NAM$C_MAXRSS+1];
10702   char image_argv[NAM$C_MAXRSS+1];
10703   $DESCRIPTOR(defdsc,".EXE");
10704   $DESCRIPTOR(defdsc2,".");
10705   struct dsc$descriptor_s resdsc;
10706   struct dsc$descriptor_s *vmscmd;
10707   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10708   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10709   register char *s, *rest, *cp, *wordbreak;
10710   char * cmd;
10711   int cmdlen;
10712   register int isdcl;
10713
10714   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10715   if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10716
10717   /* vmsspec is a DCL command buffer, not just a filename */
10718   vmsspec = PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10719   if (vmsspec == NULL)
10720       _ckvmssts_noperl(SS$_INSFMEM);
10721
10722   resspec = PerlMem_malloc(VMS_MAXRSS);
10723   if (resspec == NULL)
10724       _ckvmssts_noperl(SS$_INSFMEM);
10725
10726   /* Make a copy for modification */
10727   cmdlen = strlen(incmd);
10728   cmd = PerlMem_malloc(cmdlen+1);
10729   if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10730   strncpy(cmd, incmd, cmdlen);
10731   cmd[cmdlen] = 0;
10732   image_name[0] = 0;
10733   image_argv[0] = 0;
10734
10735   resdsc.dsc$a_pointer = resspec;
10736   resdsc.dsc$b_dtype  = DSC$K_DTYPE_T;
10737   resdsc.dsc$b_class  = DSC$K_CLASS_S;
10738   resdsc.dsc$w_length = VMS_MAXRSS - 1;
10739
10740   vmscmd->dsc$a_pointer = NULL;
10741   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
10742   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
10743   vmscmd->dsc$w_length = 0;
10744   if (pvmscmd) *pvmscmd = vmscmd;
10745
10746   if (suggest_quote) *suggest_quote = 0;
10747
10748   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10749     PerlMem_free(cmd);
10750     PerlMem_free(vmsspec);
10751     PerlMem_free(resspec);
10752     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
10753   }
10754
10755   s = cmd;
10756
10757   while (*s && isspace(*s)) s++;
10758
10759   if (*s == '@' || *s == '$') {
10760     vmsspec[0] = *s;  rest = s + 1;
10761     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10762   }
10763   else { cp = vmsspec; rest = s; }
10764   if (*rest == '.' || *rest == '/') {
10765     char *cp2;
10766     for (cp2 = resspec;
10767          *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10768          rest++, cp2++) *cp2 = *rest;
10769     *cp2 = '\0';
10770     if (int_tovmsspec(resspec, cp, 0, NULL)) {
10771       s = vmsspec;
10772
10773       /* When a UNIX spec with no file type is translated to VMS, */
10774       /* A trailing '.' is appended under ODS-5 rules.            */
10775       /* Here we do not want that trailing "." as it prevents     */
10776       /* Looking for a implied ".exe" type. */
10777       if (decc_efs_charset) {
10778           int i;
10779           i = strlen(vmsspec);
10780           if (vmsspec[i-1] == '.') {
10781               vmsspec[i-1] = '\0';
10782           }
10783       }
10784
10785       if (*rest) {
10786         for (cp2 = vmsspec + strlen(vmsspec);
10787              *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10788              rest++, cp2++) *cp2 = *rest;
10789         *cp2 = '\0';
10790       }
10791     }
10792   }
10793   /* Intuit whether verb (first word of cmd) is a DCL command:
10794    *   - if first nonspace char is '@', it's a DCL indirection
10795    * otherwise
10796    *   - if verb contains a filespec separator, it's not a DCL command
10797    *   - if it doesn't, caller tells us whether to default to a DCL
10798    *     command, or to a local image unless told it's DCL (by leading '$')
10799    */
10800   if (*s == '@') {
10801       isdcl = 1;
10802       if (suggest_quote) *suggest_quote = 1;
10803   } else {
10804     register char *filespec = strpbrk(s,":<[.;");
10805     rest = wordbreak = strpbrk(s," \"\t/");
10806     if (!wordbreak) wordbreak = s + strlen(s);
10807     if (*s == '$') check_img = 0;
10808     if (filespec && (filespec < wordbreak)) isdcl = 0;
10809     else isdcl = !check_img;
10810   }
10811
10812   if (!isdcl) {
10813     int rsts;
10814     imgdsc.dsc$a_pointer = s;
10815     imgdsc.dsc$w_length = wordbreak - s;
10816     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10817     if (!(retsts&1)) {
10818         _ckvmssts_noperl(lib$find_file_end(&cxt));
10819         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10820       if (!(retsts & 1) && *s == '$') {
10821         _ckvmssts_noperl(lib$find_file_end(&cxt));
10822         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10823         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10824         if (!(retsts&1)) {
10825           _ckvmssts_noperl(lib$find_file_end(&cxt));
10826           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10827         }
10828       }
10829     }
10830     _ckvmssts_noperl(lib$find_file_end(&cxt));
10831
10832     if (retsts & 1) {
10833       FILE *fp;
10834       s = resspec;
10835       while (*s && !isspace(*s)) s++;
10836       *s = '\0';
10837
10838       /* check that it's really not DCL with no file extension */
10839       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10840       if (fp) {
10841         char b[256] = {0,0,0,0};
10842         read(fileno(fp), b, 256);
10843         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10844         if (isdcl) {
10845           int shebang_len;
10846
10847           /* Check for script */
10848           shebang_len = 0;
10849           if ((b[0] == '#') && (b[1] == '!'))
10850              shebang_len = 2;
10851 #ifdef ALTERNATE_SHEBANG
10852           else {
10853             shebang_len = strlen(ALTERNATE_SHEBANG);
10854             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10855               char * perlstr;
10856                 perlstr = strstr("perl",b);
10857                 if (perlstr == NULL)
10858                   shebang_len = 0;
10859             }
10860             else
10861               shebang_len = 0;
10862           }
10863 #endif
10864
10865           if (shebang_len > 0) {
10866           int i;
10867           int j;
10868           char tmpspec[NAM$C_MAXRSS + 1];
10869
10870             i = shebang_len;
10871              /* Image is following after white space */
10872             /*--------------------------------------*/
10873             while (isprint(b[i]) && isspace(b[i]))
10874                 i++;
10875
10876             j = 0;
10877             while (isprint(b[i]) && !isspace(b[i])) {
10878                 tmpspec[j++] = b[i++];
10879                 if (j >= NAM$C_MAXRSS)
10880                    break;
10881             }
10882             tmpspec[j] = '\0';
10883
10884              /* There may be some default parameters to the image */
10885             /*---------------------------------------------------*/
10886             j = 0;
10887             while (isprint(b[i])) {
10888                 image_argv[j++] = b[i++];
10889                 if (j >= NAM$C_MAXRSS)
10890                    break;
10891             }
10892             while ((j > 0) && !isprint(image_argv[j-1]))
10893                 j--;
10894             image_argv[j] = 0;
10895
10896             /* It will need to be converted to VMS format and validated */
10897             if (tmpspec[0] != '\0') {
10898               char * iname;
10899
10900                /* Try to find the exact program requested to be run */
10901               /*---------------------------------------------------*/
10902               iname = int_rmsexpand
10903                  (tmpspec, image_name, ".exe",
10904                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10905               if (iname != NULL) {
10906                 if (cando_by_name_int
10907                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10908                   /* MCR prefix needed */
10909                   isdcl = 0;
10910                 }
10911                 else {
10912                    /* Try again with a null type */
10913                   /*----------------------------*/
10914                   iname = int_rmsexpand
10915                     (tmpspec, image_name, ".",
10916                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10917                   if (iname != NULL) {
10918                     if (cando_by_name_int
10919                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10920                       /* MCR prefix needed */
10921                       isdcl = 0;
10922                     }
10923                   }
10924                 }
10925
10926                  /* Did we find the image to run the script? */
10927                 /*------------------------------------------*/
10928                 if (isdcl) {
10929                   char *tchr;
10930
10931                    /* Assume DCL or foreign command exists */
10932                   /*--------------------------------------*/
10933                   tchr = strrchr(tmpspec, '/');
10934                   if (tchr != NULL) {
10935                     tchr++;
10936                   }
10937                   else {
10938                     tchr = tmpspec;
10939                   }
10940                   strcpy(image_name, tchr);
10941                 }
10942               }
10943             }
10944           }
10945         }
10946         fclose(fp);
10947       }
10948       if (check_img && isdcl) {
10949           PerlMem_free(cmd);
10950           PerlMem_free(resspec);
10951           PerlMem_free(vmsspec);
10952           return RMS$_FNF;
10953       }
10954
10955       if (cando_by_name(S_IXUSR,0,resspec)) {
10956         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10957         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10958         if (!isdcl) {
10959             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
10960             if (image_name[0] != 0) {
10961                 strcat(vmscmd->dsc$a_pointer, image_name);
10962                 strcat(vmscmd->dsc$a_pointer, " ");
10963             }
10964         } else if (image_name[0] != 0) {
10965             strcpy(vmscmd->dsc$a_pointer, image_name);
10966             strcat(vmscmd->dsc$a_pointer, " ");
10967         } else {
10968             strcpy(vmscmd->dsc$a_pointer,"@");
10969         }
10970         if (suggest_quote) *suggest_quote = 1;
10971
10972         /* If there is an image name, use original command */
10973         if (image_name[0] == 0)
10974             strcat(vmscmd->dsc$a_pointer,resspec);
10975         else {
10976             rest = cmd;
10977             while (*rest && isspace(*rest)) rest++;
10978         }
10979
10980         if (image_argv[0] != 0) {
10981           strcat(vmscmd->dsc$a_pointer,image_argv);
10982           strcat(vmscmd->dsc$a_pointer, " ");
10983         }
10984         if (rest) {
10985            int rest_len;
10986            int vmscmd_len;
10987
10988            rest_len = strlen(rest);
10989            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10990            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10991               strcat(vmscmd->dsc$a_pointer,rest);
10992            else
10993              retsts = CLI$_BUFOVF;
10994         }
10995         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10996         PerlMem_free(cmd);
10997         PerlMem_free(vmsspec);
10998         PerlMem_free(resspec);
10999         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
11000       }
11001       else
11002         retsts = RMS$_PRV;
11003     }
11004   }
11005   /* It's either a DCL command or we couldn't find a suitable image */
11006   vmscmd->dsc$w_length = strlen(cmd);
11007
11008   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
11009   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
11010   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
11011
11012   PerlMem_free(cmd);
11013   PerlMem_free(resspec);
11014   PerlMem_free(vmsspec);
11015
11016   /* check if it's a symbol (for quoting purposes) */
11017   if (suggest_quote && !*suggest_quote) {
11018     int iss;
11019     char equiv[LNM$C_NAMLENGTH];
11020     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11021     eqvdsc.dsc$a_pointer = equiv;
11022
11023     iss = lib$get_symbol(vmscmd,&eqvdsc);
11024     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
11025   }
11026   if (!(retsts & 1)) {
11027     /* just hand off status values likely to be due to user error */
11028     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
11029         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
11030        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
11031     else { _ckvmssts_noperl(retsts); }
11032   }
11033
11034   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
11035
11036 }  /* end of setup_cmddsc() */
11037
11038
11039 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
11040 bool
11041 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
11042 {
11043 bool exec_sts;
11044 char * cmd;
11045
11046   if (sp > mark) {
11047     if (vfork_called) {           /* this follows a vfork - act Unixish */
11048       vfork_called--;
11049       if (vfork_called < 0) {
11050         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
11051         vfork_called = 0;
11052       }
11053       else return do_aexec(really,mark,sp);
11054     }
11055                                            /* no vfork - act VMSish */
11056     cmd = setup_argstr(aTHX_ really,mark,sp);
11057     exec_sts = vms_do_exec(cmd);
11058     Safefree(cmd);  /* Clean up from setup_argstr() */
11059     return exec_sts;
11060   }
11061
11062   return FALSE;
11063 }  /* end of vms_do_aexec() */
11064 /*}}}*/
11065
11066 /* {{{bool vms_do_exec(char *cmd) */
11067 bool
11068 Perl_vms_do_exec(pTHX_ const char *cmd)
11069 {
11070   struct dsc$descriptor_s *vmscmd;
11071
11072   if (vfork_called) {             /* this follows a vfork - act Unixish */
11073     vfork_called--;
11074     if (vfork_called < 0) {
11075       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
11076       vfork_called = 0;
11077     }
11078     else return do_exec(cmd);
11079   }
11080
11081   {                               /* no vfork - act VMSish */
11082     unsigned long int retsts;
11083
11084     TAINT_ENV();
11085     TAINT_PROPER("exec");
11086     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
11087       retsts = lib$do_command(vmscmd);
11088
11089     switch (retsts) {
11090       case RMS$_FNF: case RMS$_DNF:
11091         set_errno(ENOENT); break;
11092       case RMS$_DIR:
11093         set_errno(ENOTDIR); break;
11094       case RMS$_DEV:
11095         set_errno(ENODEV); break;
11096       case RMS$_PRV:
11097         set_errno(EACCES); break;
11098       case RMS$_SYN:
11099         set_errno(EINVAL); break;
11100       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11101         set_errno(E2BIG); break;
11102       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11103         _ckvmssts_noperl(retsts); /* fall through */
11104       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11105         set_errno(EVMSERR);
11106     }
11107     set_vaxc_errno(retsts);
11108     if (ckWARN(WARN_EXEC)) {
11109       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
11110              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
11111     }
11112     vms_execfree(vmscmd);
11113   }
11114
11115   return FALSE;
11116
11117 }  /* end of vms_do_exec() */
11118 /*}}}*/
11119
11120 int do_spawn2(pTHX_ const char *, int);
11121
11122 int
11123 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
11124 {
11125 unsigned long int sts;
11126 char * cmd;
11127 int flags = 0;
11128
11129   if (sp > mark) {
11130
11131     /* We'll copy the (undocumented?) Win32 behavior and allow a
11132      * numeric first argument.  But the only value we'll support
11133      * through do_aspawn is a value of 1, which means spawn without
11134      * waiting for completion -- other values are ignored.
11135      */
11136     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
11137         ++mark;
11138         flags = SvIVx(*mark);
11139     }
11140
11141     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
11142         flags = CLI$M_NOWAIT;
11143     else
11144         flags = 0;
11145
11146     cmd = setup_argstr(aTHX_ really, mark, sp);
11147     sts = do_spawn2(aTHX_ cmd, flags);
11148     /* pp_sys will clean up cmd */
11149     return sts;
11150   }
11151   return SS$_ABORT;
11152 }  /* end of do_aspawn() */
11153 /*}}}*/
11154
11155
11156 /* {{{int do_spawn(char* cmd) */
11157 int
11158 Perl_do_spawn(pTHX_ char* cmd)
11159 {
11160     PERL_ARGS_ASSERT_DO_SPAWN;
11161
11162     return do_spawn2(aTHX_ cmd, 0);
11163 }
11164 /*}}}*/
11165
11166 /* {{{int do_spawn_nowait(char* cmd) */
11167 int
11168 Perl_do_spawn_nowait(pTHX_ char* cmd)
11169 {
11170     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
11171
11172     return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
11173 }
11174 /*}}}*/
11175
11176 /* {{{int do_spawn2(char *cmd) */
11177 int
11178 do_spawn2(pTHX_ const char *cmd, int flags)
11179 {
11180   unsigned long int sts, substs;
11181
11182   /* The caller of this routine expects to Safefree(PL_Cmd) */
11183   Newx(PL_Cmd,10,char);
11184
11185   TAINT_ENV();
11186   TAINT_PROPER("spawn");
11187   if (!cmd || !*cmd) {
11188     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
11189     if (!(sts & 1)) {
11190       switch (sts) {
11191         case RMS$_FNF:  case RMS$_DNF:
11192           set_errno(ENOENT); break;
11193         case RMS$_DIR:
11194           set_errno(ENOTDIR); break;
11195         case RMS$_DEV:
11196           set_errno(ENODEV); break;
11197         case RMS$_PRV:
11198           set_errno(EACCES); break;
11199         case RMS$_SYN:
11200           set_errno(EINVAL); break;
11201         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11202           set_errno(E2BIG); break;
11203         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11204           _ckvmssts_noperl(sts); /* fall through */
11205         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11206           set_errno(EVMSERR);
11207       }
11208       set_vaxc_errno(sts);
11209       if (ckWARN(WARN_EXEC)) {
11210         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
11211                     Strerror(errno));
11212       }
11213     }
11214     sts = substs;
11215   }
11216   else {
11217     char mode[3];
11218     PerlIO * fp;
11219     if (flags & CLI$M_NOWAIT)
11220         strcpy(mode, "n");
11221     else
11222         strcpy(mode, "nW");
11223
11224     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
11225     if (fp != NULL)
11226       my_pclose(fp);
11227     /* sts will be the pid in the nowait case */
11228   }
11229   return sts;
11230 }  /* end of do_spawn2() */
11231 /*}}}*/
11232
11233
11234 static unsigned int *sockflags, sockflagsize;
11235
11236 /*
11237  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
11238  * routines found in some versions of the CRTL can't deal with sockets.
11239  * We don't shim the other file open routines since a socket isn't
11240  * likely to be opened by a name.
11241  */
11242 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
11243 FILE *my_fdopen(int fd, const char *mode)
11244 {
11245   FILE *fp = fdopen(fd, mode);
11246
11247   if (fp) {
11248     unsigned int fdoff = fd / sizeof(unsigned int);
11249     Stat_t sbuf; /* native stat; we don't need flex_stat */
11250     if (!sockflagsize || fdoff > sockflagsize) {
11251       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
11252       else           Newx  (sockflags,fdoff+2,unsigned int);
11253       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11254       sockflagsize = fdoff + 2;
11255     }
11256     if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
11257       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11258   }
11259   return fp;
11260
11261 }
11262 /*}}}*/
11263
11264
11265 /*
11266  * Clear the corresponding bit when the (possibly) socket stream is closed.
11267  * There still a small hole: we miss an implicit close which might occur
11268  * via freopen().  >> Todo
11269  */
11270 /*{{{ int my_fclose(FILE *fp)*/
11271 int my_fclose(FILE *fp) {
11272   if (fp) {
11273     unsigned int fd = fileno(fp);
11274     unsigned int fdoff = fd / sizeof(unsigned int);
11275
11276     if (sockflagsize && fdoff < sockflagsize)
11277       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11278   }
11279   return fclose(fp);
11280 }
11281 /*}}}*/
11282
11283
11284 /*
11285  * A simple fwrite replacement which outputs itmsz*nitm chars without
11286  * introducing record boundaries every itmsz chars.
11287  * We are using fputs, which depends on a terminating null.  We may
11288  * well be writing binary data, so we need to accommodate not only
11289  * data with nulls sprinkled in the middle but also data with no null
11290  * byte at the end.
11291  */
11292 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
11293 int
11294 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11295 {
11296   register char *cp, *end, *cpd;
11297   char *data;
11298   register unsigned int fd = fileno(dest);
11299   register unsigned int fdoff = fd / sizeof(unsigned int);
11300   int retval;
11301   int bufsize = itmsz * nitm + 1;
11302
11303   if (fdoff < sockflagsize &&
11304       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11305     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11306     return nitm;
11307   }
11308
11309   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11310   memcpy( data, src, itmsz*nitm );
11311   data[itmsz*nitm] = '\0';
11312
11313   end = data + itmsz * nitm;
11314   retval = (int) nitm; /* on success return # items written */
11315
11316   cpd = data;
11317   while (cpd <= end) {
11318     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11319     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11320     if (cp < end)
11321       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11322     cpd = cp + 1;
11323   }
11324
11325   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11326   return retval;
11327
11328 }  /* end of my_fwrite() */
11329 /*}}}*/
11330
11331 /*{{{ int my_flush(FILE *fp)*/
11332 int
11333 Perl_my_flush(pTHX_ FILE *fp)
11334 {
11335     int res;
11336     if ((res = fflush(fp)) == 0 && fp) {
11337 #ifdef VMS_DO_SOCKETS
11338         Stat_t s;
11339         if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11340 #endif
11341             res = fsync(fileno(fp));
11342     }
11343 /*
11344  * If the flush succeeded but set end-of-file, we need to clear
11345  * the error because our caller may check ferror().  BTW, this
11346  * probably means we just flushed an empty file.
11347  */
11348     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11349
11350     return res;
11351 }
11352 /*}}}*/
11353
11354 /* fgetname() is not returning the correct file specifications when
11355  * decc_filename_unix_report mode is active.  So we have to have it
11356  * aways return filenames in VMS mode and convert it ourselves.
11357  */
11358
11359 /*{{{ char * my_fgetname(FILE *fp, buf)*/
11360 char *
11361 Perl_my_fgetname(FILE *fp, char * buf) {
11362     char * retname;
11363     char * vms_name;
11364
11365     retname = fgetname(fp, buf, 1);
11366
11367     /* If we are in VMS mode, then we are done */
11368     if (!decc_filename_unix_report || (retname == NULL)) {
11369        return retname;
11370     }
11371
11372     /* Convert this to Unix format */
11373     vms_name = PerlMem_malloc(VMS_MAXRSS + 1);
11374     strcpy(vms_name, retname);
11375     retname = int_tounixspec(vms_name, buf, NULL);
11376     PerlMem_free(vms_name);
11377
11378     return retname;
11379 }
11380 /*}}}*/
11381
11382 /*
11383  * Here are replacements for the following Unix routines in the VMS environment:
11384  *      getpwuid    Get information for a particular UIC or UID
11385  *      getpwnam    Get information for a named user
11386  *      getpwent    Get information for each user in the rights database
11387  *      setpwent    Reset search to the start of the rights database
11388  *      endpwent    Finish searching for users in the rights database
11389  *
11390  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11391  * (defined in pwd.h), which contains the following fields:-
11392  *      struct passwd {
11393  *              char        *pw_name;    Username (in lower case)
11394  *              char        *pw_passwd;  Hashed password
11395  *              unsigned int pw_uid;     UIC
11396  *              unsigned int pw_gid;     UIC group  number
11397  *              char        *pw_unixdir; Default device/directory (VMS-style)
11398  *              char        *pw_gecos;   Owner name
11399  *              char        *pw_dir;     Default device/directory (Unix-style)
11400  *              char        *pw_shell;   Default CLI name (eg. DCL)
11401  *      };
11402  * If the specified user does not exist, getpwuid and getpwnam return NULL.
11403  *
11404  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11405  * not the UIC member number (eg. what's returned by getuid()),
11406  * getpwuid() can accept either as input (if uid is specified, the caller's
11407  * UIC group is used), though it won't recognise gid=0.
11408  *
11409  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11410  * information about other users in your group or in other groups, respectively.
11411  * If the required privilege is not available, then these routines fill only
11412  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11413  * string).
11414  *
11415  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11416  */
11417
11418 /* sizes of various UAF record fields */
11419 #define UAI$S_USERNAME 12
11420 #define UAI$S_IDENT    31
11421 #define UAI$S_OWNER    31
11422 #define UAI$S_DEFDEV   31
11423 #define UAI$S_DEFDIR   63
11424 #define UAI$S_DEFCLI   31
11425 #define UAI$S_PWD       8
11426
11427 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
11428                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11429                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
11430
11431 static char __empty[]= "";
11432 static struct passwd __passwd_empty=
11433     {(char *) __empty, (char *) __empty, 0, 0,
11434      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11435 static int contxt= 0;
11436 static struct passwd __pwdcache;
11437 static char __pw_namecache[UAI$S_IDENT+1];
11438
11439 /*
11440  * This routine does most of the work extracting the user information.
11441  */
11442 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11443 {
11444     static struct {
11445         unsigned char length;
11446         char pw_gecos[UAI$S_OWNER+1];
11447     } owner;
11448     static union uicdef uic;
11449     static struct {
11450         unsigned char length;
11451         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11452     } defdev;
11453     static struct {
11454         unsigned char length;
11455         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11456     } defdir;
11457     static struct {
11458         unsigned char length;
11459         char pw_shell[UAI$S_DEFCLI+1];
11460     } defcli;
11461     static char pw_passwd[UAI$S_PWD+1];
11462
11463     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11464     struct dsc$descriptor_s name_desc;
11465     unsigned long int sts;
11466
11467     static struct itmlst_3 itmlst[]= {
11468         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
11469         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
11470         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
11471         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
11472         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
11473         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
11474         {0,                0,           NULL,    NULL}};
11475
11476     name_desc.dsc$w_length=  strlen(name);
11477     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11478     name_desc.dsc$b_class=   DSC$K_CLASS_S;
11479     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11480
11481 /*  Note that sys$getuai returns many fields as counted strings. */
11482     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11483     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11484       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11485     }
11486     else { _ckvmssts(sts); }
11487     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
11488
11489     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
11490     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11491     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11492     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11493     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11494     owner.pw_gecos[lowner]=            '\0';
11495     defdev.pw_dir[ldefdev+ldefdir]= '\0';
11496     defcli.pw_shell[ldefcli]=          '\0';
11497     if (valid_uic(uic)) {
11498         pwd->pw_uid= uic.uic$l_uic;
11499         pwd->pw_gid= uic.uic$v_group;
11500     }
11501     else
11502       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11503     pwd->pw_passwd=  pw_passwd;
11504     pwd->pw_gecos=   owner.pw_gecos;
11505     pwd->pw_dir=     defdev.pw_dir;
11506     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11507     pwd->pw_shell=   defcli.pw_shell;
11508     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11509         int ldir;
11510         ldir= strlen(pwd->pw_unixdir) - 1;
11511         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11512     }
11513     else
11514         strcpy(pwd->pw_unixdir, pwd->pw_dir);
11515     if (!decc_efs_case_preserve)
11516         __mystrtolower(pwd->pw_unixdir);
11517     return 1;
11518 }
11519
11520 /*
11521  * Get information for a named user.
11522 */
11523 /*{{{struct passwd *getpwnam(char *name)*/
11524 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
11525 {
11526     struct dsc$descriptor_s name_desc;
11527     union uicdef uic;
11528     unsigned long int status, sts;
11529
11530     __pwdcache = __passwd_empty;
11531     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11532       /* We still may be able to determine pw_uid and pw_gid */
11533       name_desc.dsc$w_length=  strlen(name);
11534       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11535       name_desc.dsc$b_class=   DSC$K_CLASS_S;
11536       name_desc.dsc$a_pointer= (char *) name;
11537       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11538         __pwdcache.pw_uid= uic.uic$l_uic;
11539         __pwdcache.pw_gid= uic.uic$v_group;
11540       }
11541       else {
11542         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11543           set_vaxc_errno(sts);
11544           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11545           return NULL;
11546         }
11547         else { _ckvmssts(sts); }
11548       }
11549     }
11550     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
11551     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
11552     __pwdcache.pw_name= __pw_namecache;
11553     return &__pwdcache;
11554 }  /* end of my_getpwnam() */
11555 /*}}}*/
11556
11557 /*
11558  * Get information for a particular UIC or UID.
11559  * Called by my_getpwent with uid=-1 to list all users.
11560 */
11561 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11562 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
11563 {
11564     const $DESCRIPTOR(name_desc,__pw_namecache);
11565     unsigned short lname;
11566     union uicdef uic;
11567     unsigned long int status;
11568
11569     if (uid == (unsigned int) -1) {
11570       do {
11571         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11572         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11573           set_vaxc_errno(status);
11574           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11575           my_endpwent();
11576           return NULL;
11577         }
11578         else { _ckvmssts(status); }
11579       } while (!valid_uic (uic));
11580     }
11581     else {
11582       uic.uic$l_uic= uid;
11583       if (!uic.uic$v_group)
11584         uic.uic$v_group= PerlProc_getgid();
11585       if (valid_uic(uic))
11586         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11587       else status = SS$_IVIDENT;
11588       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11589           status == RMS$_PRV) {
11590         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11591         return NULL;
11592       }
11593       else { _ckvmssts(status); }
11594     }
11595     __pw_namecache[lname]= '\0';
11596     __mystrtolower(__pw_namecache);
11597
11598     __pwdcache = __passwd_empty;
11599     __pwdcache.pw_name = __pw_namecache;
11600
11601 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11602     The identifier's value is usually the UIC, but it doesn't have to be,
11603     so if we can, we let fillpasswd update this. */
11604     __pwdcache.pw_uid =  uic.uic$l_uic;
11605     __pwdcache.pw_gid =  uic.uic$v_group;
11606
11607     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11608     return &__pwdcache;
11609
11610 }  /* end of my_getpwuid() */
11611 /*}}}*/
11612
11613 /*
11614  * Get information for next user.
11615 */
11616 /*{{{struct passwd *my_getpwent()*/
11617 struct passwd *Perl_my_getpwent(pTHX)
11618 {
11619     return (my_getpwuid((unsigned int) -1));
11620 }
11621 /*}}}*/
11622
11623 /*
11624  * Finish searching rights database for users.
11625 */
11626 /*{{{void my_endpwent()*/
11627 void Perl_my_endpwent(pTHX)
11628 {
11629     if (contxt) {
11630       _ckvmssts(sys$finish_rdb(&contxt));
11631       contxt= 0;
11632     }
11633 }
11634 /*}}}*/
11635
11636 #ifdef HOMEGROWN_POSIX_SIGNALS
11637   /* Signal handling routines, pulled into the core from POSIX.xs.
11638    *
11639    * We need these for threads, so they've been rolled into the core,
11640    * rather than left in POSIX.xs.
11641    *
11642    * (DRS, Oct 23, 1997)
11643    */
11644
11645   /* sigset_t is atomic under VMS, so these routines are easy */
11646 /*{{{int my_sigemptyset(sigset_t *) */
11647 int my_sigemptyset(sigset_t *set) {
11648     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11649     *set = 0; return 0;
11650 }
11651 /*}}}*/
11652
11653
11654 /*{{{int my_sigfillset(sigset_t *)*/
11655 int my_sigfillset(sigset_t *set) {
11656     int i;
11657     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11658     for (i = 0; i < NSIG; i++) *set |= (1 << i);
11659     return 0;
11660 }
11661 /*}}}*/
11662
11663
11664 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
11665 int my_sigaddset(sigset_t *set, int sig) {
11666     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11667     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11668     *set |= (1 << (sig - 1));
11669     return 0;
11670 }
11671 /*}}}*/
11672
11673
11674 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
11675 int my_sigdelset(sigset_t *set, int sig) {
11676     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11677     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11678     *set &= ~(1 << (sig - 1));
11679     return 0;
11680 }
11681 /*}}}*/
11682
11683
11684 /*{{{int my_sigismember(sigset_t *set, int sig)*/
11685 int my_sigismember(sigset_t *set, int sig) {
11686     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11687     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11688     return *set & (1 << (sig - 1));
11689 }
11690 /*}}}*/
11691
11692
11693 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
11694 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
11695     sigset_t tempmask;
11696
11697     /* If set and oset are both null, then things are badly wrong. Bail out. */
11698     if ((oset == NULL) && (set == NULL)) {
11699       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
11700       return -1;
11701     }
11702
11703     /* If set's null, then we're just handling a fetch. */
11704     if (set == NULL) {
11705         tempmask = sigblock(0);
11706     }
11707     else {
11708       switch (how) {
11709       case SIG_SETMASK:
11710         tempmask = sigsetmask(*set);
11711         break;
11712       case SIG_BLOCK:
11713         tempmask = sigblock(*set);
11714         break;
11715       case SIG_UNBLOCK:
11716         tempmask = sigblock(0);
11717         sigsetmask(*oset & ~tempmask);
11718         break;
11719       default:
11720         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11721         return -1;
11722       }
11723     }
11724
11725     /* Did they pass us an oset? If so, stick our holding mask into it */
11726     if (oset)
11727       *oset = tempmask;
11728
11729     return 0;
11730 }
11731 /*}}}*/
11732 #endif  /* HOMEGROWN_POSIX_SIGNALS */
11733
11734
11735 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11736  * my_utime(), and flex_stat(), all of which operate on UTC unless
11737  * VMSISH_TIMES is true.
11738  */
11739 /* method used to handle UTC conversions:
11740  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
11741  */
11742 static int gmtime_emulation_type;
11743 /* number of secs to add to UTC POSIX-style time to get local time */
11744 static long int utc_offset_secs;
11745
11746 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11747  * in vmsish.h.  #undef them here so we can call the CRTL routines
11748  * directly.
11749  */
11750 #undef gmtime
11751 #undef localtime
11752 #undef time
11753
11754
11755 /*
11756  * DEC C previous to 6.0 corrupts the behavior of the /prefix
11757  * qualifier with the extern prefix pragma.  This provisional
11758  * hack circumvents this prefix pragma problem in previous
11759  * precompilers.
11760  */
11761 #if defined(__VMS_VER) && __VMS_VER >= 70000000
11762 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
11763 #    pragma __extern_prefix save
11764 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
11765 #    define gmtime decc$__utctz_gmtime
11766 #    define localtime decc$__utctz_localtime
11767 #    define time decc$__utc_time
11768 #    pragma __extern_prefix restore
11769
11770      struct tm *gmtime(), *localtime();
11771
11772 #  endif
11773 #endif
11774
11775
11776 static time_t toutc_dst(time_t loc) {
11777   struct tm *rsltmp;
11778
11779   if ((rsltmp = localtime(&loc)) == NULL) return -1;
11780   loc -= utc_offset_secs;
11781   if (rsltmp->tm_isdst) loc -= 3600;
11782   return loc;
11783 }
11784 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11785        ((gmtime_emulation_type || my_time(NULL)), \
11786        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11787        ((secs) - utc_offset_secs))))
11788
11789 static time_t toloc_dst(time_t utc) {
11790   struct tm *rsltmp;
11791
11792   utc += utc_offset_secs;
11793   if ((rsltmp = localtime(&utc)) == NULL) return -1;
11794   if (rsltmp->tm_isdst) utc += 3600;
11795   return utc;
11796 }
11797 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11798        ((gmtime_emulation_type || my_time(NULL)), \
11799        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11800        ((secs) + utc_offset_secs))))
11801
11802 #ifndef RTL_USES_UTC
11803 /*
11804
11805     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
11806         DST starts on 1st sun of april      at 02:00  std time
11807             ends on last sun of october     at 02:00  dst time
11808     see the UCX management command reference, SET CONFIG TIMEZONE
11809     for formatting info.
11810
11811     No, it's not as general as it should be, but then again, NOTHING
11812     will handle UK times in a sensible way.
11813 */
11814
11815
11816 /*
11817     parse the DST start/end info:
11818     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
11819 */
11820
11821 static char *
11822 tz_parse_startend(char *s, struct tm *w, int *past)
11823 {
11824     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
11825     int ly, dozjd, d, m, n, hour, min, sec, j, k;
11826     time_t g;
11827
11828     if (!s)    return 0;
11829     if (!w) return 0;
11830     if (!past) return 0;
11831
11832     ly = 0;
11833     if (w->tm_year % 4        == 0) ly = 1;
11834     if (w->tm_year % 100      == 0) ly = 0;
11835     if (w->tm_year+1900 % 400 == 0) ly = 1;
11836     if (ly) dinm[1]++;
11837
11838     dozjd = isdigit(*s);
11839     if (*s == 'J' || *s == 'j' || dozjd) {
11840         if (!dozjd && !isdigit(*++s)) return 0;
11841         d = *s++ - '0';
11842         if (isdigit(*s)) {
11843             d = d*10 + *s++ - '0';
11844             if (isdigit(*s)) {
11845                 d = d*10 + *s++ - '0';
11846             }
11847         }
11848         if (d == 0) return 0;
11849         if (d > 366) return 0;
11850         d--;
11851         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
11852         g = d * 86400;
11853         dozjd = 1;
11854     } else if (*s == 'M' || *s == 'm') {
11855         if (!isdigit(*++s)) return 0;
11856         m = *s++ - '0';
11857         if (isdigit(*s)) m = 10*m + *s++ - '0';
11858         if (*s != '.') return 0;
11859         if (!isdigit(*++s)) return 0;
11860         n = *s++ - '0';
11861         if (n < 1 || n > 5) return 0;
11862         if (*s != '.') return 0;
11863         if (!isdigit(*++s)) return 0;
11864         d = *s++ - '0';
11865         if (d > 6) return 0;
11866     }
11867
11868     if (*s == '/') {
11869         if (!isdigit(*++s)) return 0;
11870         hour = *s++ - '0';
11871         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
11872         if (*s == ':') {
11873             if (!isdigit(*++s)) return 0;
11874             min = *s++ - '0';
11875             if (isdigit(*s)) min = 10*min + *s++ - '0';
11876             if (*s == ':') {
11877                 if (!isdigit(*++s)) return 0;
11878                 sec = *s++ - '0';
11879                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
11880             }
11881         }
11882     } else {
11883         hour = 2;
11884         min = 0;
11885         sec = 0;
11886     }
11887
11888     if (dozjd) {
11889         if (w->tm_yday < d) goto before;
11890         if (w->tm_yday > d) goto after;
11891     } else {
11892         if (w->tm_mon+1 < m) goto before;
11893         if (w->tm_mon+1 > m) goto after;
11894
11895         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
11896         k = d - j; /* mday of first d */
11897         if (k <= 0) k += 7;
11898         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
11899         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
11900         if (w->tm_mday < k) goto before;
11901         if (w->tm_mday > k) goto after;
11902     }
11903
11904     if (w->tm_hour < hour) goto before;
11905     if (w->tm_hour > hour) goto after;
11906     if (w->tm_min  < min)  goto before;
11907     if (w->tm_min  > min)  goto after;
11908     if (w->tm_sec  < sec)  goto before;
11909     goto after;
11910
11911 before:
11912     *past = 0;
11913     return s;
11914 after:
11915     *past = 1;
11916     return s;
11917 }
11918
11919
11920
11921
11922 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
11923
11924 static char *
11925 tz_parse_offset(char *s, int *offset)
11926 {
11927     int hour = 0, min = 0, sec = 0;
11928     int neg = 0;
11929     if (!s) return 0;
11930     if (!offset) return 0;
11931
11932     if (*s == '-') {neg++; s++;}
11933     if (*s == '+') s++;
11934     if (!isdigit(*s)) return 0;
11935     hour = *s++ - '0';
11936     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
11937     if (hour > 24) return 0;
11938     if (*s == ':') {
11939         if (!isdigit(*++s)) return 0;
11940         min = *s++ - '0';
11941         if (isdigit(*s)) min = min*10 + (*s++ - '0');
11942         if (min > 59) return 0;
11943         if (*s == ':') {
11944             if (!isdigit(*++s)) return 0;
11945             sec = *s++ - '0';
11946             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
11947             if (sec > 59) return 0;
11948         }
11949     }
11950
11951     *offset = (hour*60+min)*60 + sec;
11952     if (neg) *offset = -*offset;
11953     return s;
11954 }
11955
11956 /*
11957     input time is w, whatever type of time the CRTL localtime() uses.
11958     sets dst, the zone, and the gmtoff (seconds)
11959
11960     caches the value of TZ and UCX$TZ env variables; note that
11961     my_setenv looks for these and sets a flag if they're changed
11962     for efficiency.
11963
11964     We have to watch out for the "australian" case (dst starts in
11965     october, ends in april)...flagged by "reverse" and checked by
11966     scanning through the months of the previous year.
11967
11968 */
11969
11970 static int
11971 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
11972 {
11973     time_t when;
11974     struct tm *w2;
11975     char *s,*s2;
11976     char *dstzone, *tz, *s_start, *s_end;
11977     int std_off, dst_off, isdst;
11978     int y, dststart, dstend;
11979     static char envtz[1025];  /* longer than any logical, symbol, ... */
11980     static char ucxtz[1025];
11981     static char reversed = 0;
11982
11983     if (!w) return 0;
11984
11985     if (tz_updated) {
11986         tz_updated = 0;
11987         reversed = -1;  /* flag need to check  */
11988         envtz[0] = ucxtz[0] = '\0';
11989         tz = my_getenv("TZ",0);
11990         if (tz) strcpy(envtz, tz);
11991         tz = my_getenv("UCX$TZ",0);
11992         if (tz) strcpy(ucxtz, tz);
11993         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
11994     }
11995     tz = envtz;
11996     if (!*tz) tz = ucxtz;
11997
11998     s = tz;
11999     while (isalpha(*s)) s++;
12000     s = tz_parse_offset(s, &std_off);
12001     if (!s) return 0;
12002     if (!*s) {                  /* no DST, hurray we're done! */
12003         isdst = 0;
12004         goto done;
12005     }
12006
12007     dstzone = s;
12008     while (isalpha(*s)) s++;
12009     s2 = tz_parse_offset(s, &dst_off);
12010     if (s2) {
12011         s = s2;
12012     } else {
12013         dst_off = std_off - 3600;
12014     }
12015
12016     if (!*s) {      /* default dst start/end?? */
12017         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
12018             s = strchr(ucxtz,',');
12019         }
12020         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
12021     }
12022     if (*s != ',') return 0;
12023
12024     when = *w;
12025     when = _toutc(when);      /* convert to utc */
12026     when = when - std_off;    /* convert to pseudolocal time*/
12027
12028     w2 = localtime(&when);
12029     y = w2->tm_year;
12030     s_start = s+1;
12031     s = tz_parse_startend(s_start,w2,&dststart);
12032     if (!s) return 0;
12033     if (*s != ',') return 0;
12034
12035     when = *w;
12036     when = _toutc(when);      /* convert to utc */
12037     when = when - dst_off;    /* convert to pseudolocal time*/
12038     w2 = localtime(&when);
12039     if (w2->tm_year != y) {   /* spans a year, just check one time */
12040         when += dst_off - std_off;
12041         w2 = localtime(&when);
12042     }
12043     s_end = s+1;
12044     s = tz_parse_startend(s_end,w2,&dstend);
12045     if (!s) return 0;
12046
12047     if (reversed == -1) {  /* need to check if start later than end */
12048         int j, ds, de;
12049
12050         when = *w;
12051         if (when < 2*365*86400) {
12052             when += 2*365*86400;
12053         } else {
12054             when -= 365*86400;
12055         }
12056         w2 =localtime(&when);
12057         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
12058
12059         for (j = 0; j < 12; j++) {
12060             w2 =localtime(&when);
12061             tz_parse_startend(s_start,w2,&ds);
12062             tz_parse_startend(s_end,w2,&de);
12063             if (ds != de) break;
12064             when += 30*86400;
12065         }
12066         reversed = 0;
12067         if (de && !ds) reversed = 1;
12068     }
12069
12070     isdst = dststart && !dstend;
12071     if (reversed) isdst = dststart  || !dstend;
12072
12073 done:
12074     if (dst)    *dst = isdst;
12075     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
12076     if (isdst)  tz = dstzone;
12077     if (zone) {
12078         while(isalpha(*tz))  *zone++ = *tz++;
12079         *zone = '\0';
12080     }
12081     return 1;
12082 }
12083
12084 #endif /* !RTL_USES_UTC */
12085
12086 /* my_time(), my_localtime(), my_gmtime()
12087  * By default traffic in UTC time values, using CRTL gmtime() or
12088  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
12089  * Note: We need to use these functions even when the CRTL has working
12090  * UTC support, since they also handle C<use vmsish qw(times);>
12091  *
12092  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
12093  * Modified by Charles Bailey <bailey@newman.upenn.edu>
12094  */
12095
12096 /*{{{time_t my_time(time_t *timep)*/
12097 time_t Perl_my_time(pTHX_ time_t *timep)
12098 {
12099   time_t when;
12100   struct tm *tm_p;
12101
12102   if (gmtime_emulation_type == 0) {
12103     int dstnow;
12104     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
12105                               /* results of calls to gmtime() and localtime() */
12106                               /* for same &base */
12107
12108     gmtime_emulation_type++;
12109     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
12110       char off[LNM$C_NAMLENGTH+1];;
12111
12112       gmtime_emulation_type++;
12113       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
12114         gmtime_emulation_type++;
12115         utc_offset_secs = 0;
12116         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
12117       }
12118       else { utc_offset_secs = atol(off); }
12119     }
12120     else { /* We've got a working gmtime() */
12121       struct tm gmt, local;
12122
12123       gmt = *tm_p;
12124       tm_p = localtime(&base);
12125       local = *tm_p;
12126       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
12127       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
12128       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
12129       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
12130     }
12131   }
12132
12133   when = time(NULL);
12134 # ifdef VMSISH_TIME
12135 # ifdef RTL_USES_UTC
12136   if (VMSISH_TIME) when = _toloc(when);
12137 # else
12138   if (!VMSISH_TIME) when = _toutc(when);
12139 # endif
12140 # endif
12141   if (timep != NULL) *timep = when;
12142   return when;
12143
12144 }  /* end of my_time() */
12145 /*}}}*/
12146
12147
12148 /*{{{struct tm *my_gmtime(const time_t *timep)*/
12149 struct tm *
12150 Perl_my_gmtime(pTHX_ const time_t *timep)
12151 {
12152   char *p;
12153   time_t when;
12154   struct tm *rsltmp;
12155
12156   if (timep == NULL) {
12157     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12158     return NULL;
12159   }
12160   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
12161
12162   when = *timep;
12163 # ifdef VMSISH_TIME
12164   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
12165 #  endif
12166 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
12167   return gmtime(&when);
12168 # else
12169   /* CRTL localtime() wants local time as input, so does no tz correction */
12170   rsltmp = localtime(&when);
12171   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
12172   return rsltmp;
12173 #endif
12174 }  /* end of my_gmtime() */
12175 /*}}}*/
12176
12177
12178 /*{{{struct tm *my_localtime(const time_t *timep)*/
12179 struct tm *
12180 Perl_my_localtime(pTHX_ const time_t *timep)
12181 {
12182   time_t when, whenutc;
12183   struct tm *rsltmp;
12184   int dst, offset;
12185
12186   if (timep == NULL) {
12187     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12188     return NULL;
12189   }
12190   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
12191   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
12192
12193   when = *timep;
12194 # ifdef RTL_USES_UTC
12195 # ifdef VMSISH_TIME
12196   if (VMSISH_TIME) when = _toutc(when);
12197 # endif
12198   /* CRTL localtime() wants UTC as input, does tz correction itself */
12199   return localtime(&when);
12200
12201 # else /* !RTL_USES_UTC */
12202   whenutc = when;
12203 # ifdef VMSISH_TIME
12204   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
12205   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
12206 # endif
12207   dst = -1;
12208 #ifndef RTL_USES_UTC
12209   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
12210       when = whenutc - offset;                   /* pseudolocal time*/
12211   }
12212 # endif
12213   /* CRTL localtime() wants local time as input, so does no tz correction */
12214   rsltmp = localtime(&when);
12215   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
12216   return rsltmp;
12217 # endif
12218
12219 } /*  end of my_localtime() */
12220 /*}}}*/
12221
12222 /* Reset definitions for later calls */
12223 #define gmtime(t)    my_gmtime(t)
12224 #define localtime(t) my_localtime(t)
12225 #define time(t)      my_time(t)
12226
12227
12228 /* my_utime - update modification/access time of a file
12229  *
12230  * VMS 7.3 and later implementation
12231  * Only the UTC translation is home-grown. The rest is handled by the
12232  * CRTL utime(), which will take into account the relevant feature
12233  * logicals and ODS-5 volume characteristics for true access times.
12234  *
12235  * pre VMS 7.3 implementation:
12236  * The calling sequence is identical to POSIX utime(), but under
12237  * VMS with ODS-2, only the modification time is changed; ODS-2 does
12238  * not maintain access times.  Restrictions differ from the POSIX
12239  * definition in that the time can be changed as long as the
12240  * caller has permission to execute the necessary IO$_MODIFY $QIO;
12241  * no separate checks are made to insure that the caller is the
12242  * owner of the file or has special privs enabled.
12243  * Code here is based on Joe Meadows' FILE utility.
12244  *
12245  */
12246
12247 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
12248  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
12249  * in 100 ns intervals.
12250  */
12251 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
12252
12253 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
12254 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
12255 {
12256 #if __CRTL_VER >= 70300000
12257   struct utimbuf utc_utimes, *utc_utimesp;
12258
12259   if (utimes != NULL) {
12260     utc_utimes.actime = utimes->actime;
12261     utc_utimes.modtime = utimes->modtime;
12262 # ifdef VMSISH_TIME
12263     /* If input was local; convert to UTC for sys svc */
12264     if (VMSISH_TIME) {
12265       utc_utimes.actime = _toutc(utimes->actime);
12266       utc_utimes.modtime = _toutc(utimes->modtime);
12267     }
12268 # endif
12269     utc_utimesp = &utc_utimes;
12270   }
12271   else {
12272     utc_utimesp = NULL;
12273   }
12274
12275   return utime(file, utc_utimesp);
12276
12277 #else /* __CRTL_VER < 70300000 */
12278
12279   register int i;
12280   int sts;
12281   long int bintime[2], len = 2, lowbit, unixtime,
12282            secscale = 10000000; /* seconds --> 100 ns intervals */
12283   unsigned long int chan, iosb[2], retsts;
12284   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
12285   struct FAB myfab = cc$rms_fab;
12286   struct NAM mynam = cc$rms_nam;
12287 #if defined (__DECC) && defined (__VAX)
12288   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
12289    * at least through VMS V6.1, which causes a type-conversion warning.
12290    */
12291 #  pragma message save
12292 #  pragma message disable cvtdiftypes
12293 #endif
12294   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
12295   struct fibdef myfib;
12296 #if defined (__DECC) && defined (__VAX)
12297   /* This should be right after the declaration of myatr, but due
12298    * to a bug in VAX DEC C, this takes effect a statement early.
12299    */
12300 #  pragma message restore
12301 #endif
12302   /* cast ok for read only parameter */
12303   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
12304                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
12305                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
12306
12307   if (file == NULL || *file == '\0') {
12308     SETERRNO(ENOENT, LIB$_INVARG);
12309     return -1;
12310   }
12311
12312   /* Convert to VMS format ensuring that it will fit in 255 characters */
12313   if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
12314       SETERRNO(ENOENT, LIB$_INVARG);
12315       return -1;
12316   }
12317   if (utimes != NULL) {
12318     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
12319      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
12320      * Since time_t is unsigned long int, and lib$emul takes a signed long int
12321      * as input, we force the sign bit to be clear by shifting unixtime right
12322      * one bit, then multiplying by an extra factor of 2 in lib$emul().
12323      */
12324     lowbit = (utimes->modtime & 1) ? secscale : 0;
12325     unixtime = (long int) utimes->modtime;
12326 #   ifdef VMSISH_TIME
12327     /* If input was UTC; convert to local for sys svc */
12328     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
12329 #   endif
12330     unixtime >>= 1;  secscale <<= 1;
12331     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
12332     if (!(retsts & 1)) {
12333       SETERRNO(EVMSERR, retsts);
12334       return -1;
12335     }
12336     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
12337     if (!(retsts & 1)) {
12338       SETERRNO(EVMSERR, retsts);
12339       return -1;
12340     }
12341   }
12342   else {
12343     /* Just get the current time in VMS format directly */
12344     retsts = sys$gettim(bintime);
12345     if (!(retsts & 1)) {
12346       SETERRNO(EVMSERR, retsts);
12347       return -1;
12348     }
12349   }
12350
12351   myfab.fab$l_fna = vmsspec;
12352   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
12353   myfab.fab$l_nam = &mynam;
12354   mynam.nam$l_esa = esa;
12355   mynam.nam$b_ess = (unsigned char) sizeof esa;
12356   mynam.nam$l_rsa = rsa;
12357   mynam.nam$b_rss = (unsigned char) sizeof rsa;
12358   if (decc_efs_case_preserve)
12359       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
12360
12361   /* Look for the file to be affected, letting RMS parse the file
12362    * specification for us as well.  I have set errno using only
12363    * values documented in the utime() man page for VMS POSIX.
12364    */
12365   retsts = sys$parse(&myfab,0,0);
12366   if (!(retsts & 1)) {
12367     set_vaxc_errno(retsts);
12368     if      (retsts == RMS$_PRV) set_errno(EACCES);
12369     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
12370     else                         set_errno(EVMSERR);
12371     return -1;
12372   }
12373   retsts = sys$search(&myfab,0,0);
12374   if (!(retsts & 1)) {
12375     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12376     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12377     set_vaxc_errno(retsts);
12378     if      (retsts == RMS$_PRV) set_errno(EACCES);
12379     else if (retsts == RMS$_FNF) set_errno(ENOENT);
12380     else                         set_errno(EVMSERR);
12381     return -1;
12382   }
12383
12384   devdsc.dsc$w_length = mynam.nam$b_dev;
12385   /* cast ok for read only parameter */
12386   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
12387
12388   retsts = sys$assign(&devdsc,&chan,0,0);
12389   if (!(retsts & 1)) {
12390     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12391     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12392     set_vaxc_errno(retsts);
12393     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
12394     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
12395     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
12396     else                               set_errno(EVMSERR);
12397     return -1;
12398   }
12399
12400   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
12401   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
12402
12403   memset((void *) &myfib, 0, sizeof myfib);
12404 #if defined(__DECC) || defined(__DECCXX)
12405   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
12406   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
12407   /* This prevents the revision time of the file being reset to the current
12408    * time as a result of our IO$_MODIFY $QIO. */
12409   myfib.fib$l_acctl = FIB$M_NORECORD;
12410 #else
12411   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
12412   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
12413   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
12414 #endif
12415   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
12416   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12417   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12418   _ckvmssts(sys$dassgn(chan));
12419   if (retsts & 1) retsts = iosb[0];
12420   if (!(retsts & 1)) {
12421     set_vaxc_errno(retsts);
12422     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12423     else                      set_errno(EVMSERR);
12424     return -1;
12425   }
12426
12427   return 0;
12428
12429 #endif /* #if __CRTL_VER >= 70300000 */
12430
12431 }  /* end of my_utime() */
12432 /*}}}*/
12433
12434 /*
12435  * flex_stat, flex_lstat, flex_fstat
12436  * basic stat, but gets it right when asked to stat
12437  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
12438  */
12439
12440 #ifndef _USE_STD_STAT
12441 /* encode_dev packs a VMS device name string into an integer to allow
12442  * simple comparisons. This can be used, for example, to check whether two
12443  * files are located on the same device, by comparing their encoded device
12444  * names. Even a string comparison would not do, because stat() reuses the
12445  * device name buffer for each call; so without encode_dev, it would be
12446  * necessary to save the buffer and use strcmp (this would mean a number of
12447  * changes to the standard Perl code, to say nothing of what a Perl script
12448  * would have to do.
12449  *
12450  * The device lock id, if it exists, should be unique (unless perhaps compared
12451  * with lock ids transferred from other nodes). We have a lock id if the disk is
12452  * mounted cluster-wide, which is when we tend to get long (host-qualified)
12453  * device names. Thus we use the lock id in preference, and only if that isn't
12454  * available, do we try to pack the device name into an integer (flagged by
12455  * the sign bit (LOCKID_MASK) being set).
12456  *
12457  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
12458  * name and its encoded form, but it seems very unlikely that we will find
12459  * two files on different disks that share the same encoded device names,
12460  * and even more remote that they will share the same file id (if the test
12461  * is to check for the same file).
12462  *
12463  * A better method might be to use sys$device_scan on the first call, and to
12464  * search for the device, returning an index into the cached array.
12465  * The number returned would be more intelligible.
12466  * This is probably not worth it, and anyway would take quite a bit longer
12467  * on the first call.
12468  */
12469 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
12470 static mydev_t encode_dev (pTHX_ const char *dev)
12471 {
12472   int i;
12473   unsigned long int f;
12474   mydev_t enc;
12475   char c;
12476   const char *q;
12477
12478   if (!dev || !dev[0]) return 0;
12479
12480 #if LOCKID_MASK
12481   {
12482     struct dsc$descriptor_s dev_desc;
12483     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
12484
12485     /* For cluster-mounted disks, the disk lock identifier is unique, so we
12486        can try that first. */
12487     dev_desc.dsc$w_length =  strlen (dev);
12488     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
12489     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
12490     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
12491     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
12492     if (!$VMS_STATUS_SUCCESS(status)) {
12493       switch (status) {
12494         case SS$_NOSUCHDEV:
12495           SETERRNO(ENODEV, status);
12496           return 0;
12497         default:
12498           _ckvmssts(status);
12499       }
12500     }
12501     if (lockid) return (lockid & ~LOCKID_MASK);
12502   }
12503 #endif
12504
12505   /* Otherwise we try to encode the device name */
12506   enc = 0;
12507   f = 1;
12508   i = 0;
12509   for (q = dev + strlen(dev); q--; q >= dev) {
12510     if (*q == ':')
12511         break;
12512     if (isdigit (*q))
12513       c= (*q) - '0';
12514     else if (isalpha (toupper (*q)))
12515       c= toupper (*q) - 'A' + (char)10;
12516     else
12517       continue; /* Skip '$'s */
12518     i++;
12519     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
12520     if (i>1) f *= 36;
12521     enc += f * (unsigned long int) c;
12522   }
12523   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
12524
12525 }  /* end of encode_dev() */
12526 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12527         device_no = encode_dev(aTHX_ devname)
12528 #else
12529 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12530         device_no = new_dev_no
12531 #endif
12532
12533 static int
12534 is_null_device(name)
12535     const char *name;
12536 {
12537   if (decc_bug_devnull != 0) {
12538     if (strncmp("/dev/null", name, 9) == 0)
12539       return 1;
12540   }
12541     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
12542        The underscore prefix, controller letter, and unit number are
12543        independently optional; for our purposes, the colon punctuation
12544        is not.  The colon can be trailed by optional directory and/or
12545        filename, but two consecutive colons indicates a nodename rather
12546        than a device.  [pr]  */
12547   if (*name == '_') ++name;
12548   if (tolower(*name++) != 'n') return 0;
12549   if (tolower(*name++) != 'l') return 0;
12550   if (tolower(*name) == 'a') ++name;
12551   if (*name == '0') ++name;
12552   return (*name++ == ':') && (*name != ':');
12553 }
12554
12555 static int
12556 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
12557
12558 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
12559
12560 static I32
12561 Perl_cando_by_name_int
12562    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
12563 {
12564   char usrname[L_cuserid];
12565   struct dsc$descriptor_s usrdsc =
12566          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
12567   char *vmsname = NULL, *fileified = NULL;
12568   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
12569   unsigned short int retlen, trnlnm_iter_count;
12570   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12571   union prvdef curprv;
12572   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
12573          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
12574          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
12575   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
12576          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
12577          {0,0,0,0}};
12578   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
12579          {0,0,0,0}};
12580   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12581   Stat_t st;
12582   static int profile_context = -1;
12583
12584   if (!fname || !*fname) return FALSE;
12585
12586   /* Make sure we expand logical names, since sys$check_access doesn't */
12587   fileified = PerlMem_malloc(VMS_MAXRSS);
12588   if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12589   if (!strpbrk(fname,"/]>:")) {
12590       strcpy(fileified,fname);
12591       trnlnm_iter_count = 0;
12592       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
12593         trnlnm_iter_count++;
12594         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
12595       }
12596       fname = fileified;
12597   }
12598
12599   vmsname = PerlMem_malloc(VMS_MAXRSS);
12600   if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12601   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
12602     /* Don't know if already in VMS format, so make sure */
12603     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
12604       PerlMem_free(fileified);
12605       PerlMem_free(vmsname);
12606       return FALSE;
12607     }
12608   }
12609   else {
12610     strcpy(vmsname,fname);
12611   }
12612
12613   /* sys$check_access needs a file spec, not a directory spec.
12614    * flex_stat now will handle a null thread context during startup.
12615    */
12616
12617   retlen = namdsc.dsc$w_length = strlen(vmsname);
12618   if (vmsname[retlen-1] == ']'
12619       || vmsname[retlen-1] == '>'
12620       || vmsname[retlen-1] == ':'
12621       || (!flex_stat_int(vmsname, &st, 1) &&
12622           S_ISDIR(st.st_mode))) {
12623
12624       if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
12625         PerlMem_free(fileified);
12626         PerlMem_free(vmsname);
12627         return FALSE;
12628       }
12629       fname = fileified;
12630   }
12631   else {
12632       fname = vmsname;
12633   }
12634
12635   retlen = namdsc.dsc$w_length = strlen(fname);
12636   namdsc.dsc$a_pointer = (char *)fname;
12637
12638   switch (bit) {
12639     case S_IXUSR: case S_IXGRP: case S_IXOTH:
12640       access = ARM$M_EXECUTE;
12641       flags = CHP$M_READ;
12642       break;
12643     case S_IRUSR: case S_IRGRP: case S_IROTH:
12644       access = ARM$M_READ;
12645       flags = CHP$M_READ | CHP$M_USEREADALL;
12646       break;
12647     case S_IWUSR: case S_IWGRP: case S_IWOTH:
12648       access = ARM$M_WRITE;
12649       flags = CHP$M_READ | CHP$M_WRITE;
12650       break;
12651     case S_IDUSR: case S_IDGRP: case S_IDOTH:
12652       access = ARM$M_DELETE;
12653       flags = CHP$M_READ | CHP$M_WRITE;
12654       break;
12655     default:
12656       if (fileified != NULL)
12657         PerlMem_free(fileified);
12658       if (vmsname != NULL)
12659         PerlMem_free(vmsname);
12660       return FALSE;
12661   }
12662
12663   /* Before we call $check_access, create a user profile with the current
12664    * process privs since otherwise it just uses the default privs from the
12665    * UAF and might give false positives or negatives.  This only works on
12666    * VMS versions v6.0 and later since that's when sys$create_user_profile
12667    * became available.
12668    */
12669
12670   /* get current process privs and username */
12671   _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
12672   _ckvmssts_noperl(iosb[0]);
12673
12674 #if defined(__VMS_VER) && __VMS_VER >= 60000000
12675
12676   /* find out the space required for the profile */
12677   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
12678                                     &usrprodsc.dsc$w_length,&profile_context));
12679
12680   /* allocate space for the profile and get it filled in */
12681   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
12682   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12683   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
12684                                     &usrprodsc.dsc$w_length,&profile_context));
12685
12686   /* use the profile to check access to the file; free profile & analyze results */
12687   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
12688   PerlMem_free(usrprodsc.dsc$a_pointer);
12689   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
12690
12691 #else
12692
12693   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
12694
12695 #endif
12696
12697   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
12698       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
12699       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
12700     set_vaxc_errno(retsts);
12701     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12702     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12703     else set_errno(ENOENT);
12704     if (fileified != NULL)
12705       PerlMem_free(fileified);
12706     if (vmsname != NULL)
12707       PerlMem_free(vmsname);
12708     return FALSE;
12709   }
12710   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12711     if (fileified != NULL)
12712       PerlMem_free(fileified);
12713     if (vmsname != NULL)
12714       PerlMem_free(vmsname);
12715     return TRUE;
12716   }
12717   _ckvmssts_noperl(retsts);
12718
12719   if (fileified != NULL)
12720     PerlMem_free(fileified);
12721   if (vmsname != NULL)
12722     PerlMem_free(vmsname);
12723   return FALSE;  /* Should never get here */
12724
12725 }
12726
12727 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
12728 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12729  * subset of the applicable information.
12730  */
12731 bool
12732 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12733 {
12734   return cando_by_name_int
12735         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12736 }  /* end of cando() */
12737 /*}}}*/
12738
12739
12740 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12741 I32
12742 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12743 {
12744    return cando_by_name_int(bit, effective, fname, 0);
12745
12746 }  /* end of cando_by_name() */
12747 /*}}}*/
12748
12749
12750 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12751 int
12752 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12753 {
12754   if (!fstat(fd, &statbufp->crtl_stat)) {
12755     char *cptr;
12756     char *vms_filename;
12757     vms_filename = PerlMem_malloc(VMS_MAXRSS);
12758     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12759
12760     /* Save name for cando by name in VMS format */
12761     cptr = getname(fd, vms_filename, 1);
12762
12763     /* This should not happen, but just in case */
12764     if (cptr == NULL) {
12765         statbufp->st_devnam[0] = 0;
12766     }
12767     else {
12768         /* Make sure that the saved name fits in 255 characters */
12769         cptr = int_rmsexpand_vms
12770                        (vms_filename,
12771                         statbufp->st_devnam,
12772                         0);
12773         if (cptr == NULL)
12774             statbufp->st_devnam[0] = 0;
12775     }
12776     PerlMem_free(vms_filename);
12777
12778     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12779     VMS_DEVICE_ENCODE
12780         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12781
12782 #   ifdef RTL_USES_UTC
12783 #   ifdef VMSISH_TIME
12784     if (VMSISH_TIME) {
12785       statbufp->st_mtime = _toloc(statbufp->st_mtime);
12786       statbufp->st_atime = _toloc(statbufp->st_atime);
12787       statbufp->st_ctime = _toloc(statbufp->st_ctime);
12788     }
12789 #   endif
12790 #   else
12791 #   ifdef VMSISH_TIME
12792     if (!VMSISH_TIME) { /* Return UTC instead of local time */
12793 #   else
12794     if (1) {
12795 #   endif
12796       statbufp->st_mtime = _toutc(statbufp->st_mtime);
12797       statbufp->st_atime = _toutc(statbufp->st_atime);
12798       statbufp->st_ctime = _toutc(statbufp->st_ctime);
12799     }
12800 #endif
12801     return 0;
12802   }
12803   return -1;
12804
12805 }  /* end of flex_fstat() */
12806 /*}}}*/
12807
12808 static int
12809 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12810 {
12811     char *fileified;
12812     char *temp_fspec;
12813     const char *save_spec;
12814     char *ret_spec;
12815     int retval = -1;
12816     int efs_hack = 0;
12817     dSAVEDERRNO;
12818
12819     if (!fspec) {
12820         errno = EINVAL;
12821         return retval;
12822     }
12823
12824     if (decc_bug_devnull != 0) {
12825       if (is_null_device(fspec)) { /* Fake a stat() for the null device */
12826         memset(statbufp,0,sizeof *statbufp);
12827         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12828         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12829         statbufp->st_uid = 0x00010001;
12830         statbufp->st_gid = 0x0001;
12831         time((time_t *)&statbufp->st_mtime);
12832         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12833         return 0;
12834       }
12835     }
12836
12837     /* Try for a directory name first.  If fspec contains a filename without
12838      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12839      * and sea:[wine.dark]water. exist, we prefer the directory here.
12840      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12841      * not sea:[wine.dark]., if the latter exists.  If the intended target is
12842      * the file with null type, specify this by calling flex_stat() with
12843      * a '.' at the end of fspec.
12844      *
12845      * If we are in Posix filespec mode, accept the filename as is.
12846      */
12847
12848
12849     fileified = PerlMem_malloc(VMS_MAXRSS);
12850     if (fileified == NULL)
12851         _ckvmssts_noperl(SS$_INSFMEM);
12852
12853     temp_fspec = PerlMem_malloc(VMS_MAXRSS);
12854     if (temp_fspec == NULL)
12855         _ckvmssts_noperl(SS$_INSFMEM);
12856
12857     strcpy(temp_fspec, fspec);
12858
12859     SAVE_ERRNO;
12860
12861 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12862   if (decc_posix_compliant_pathnames == 0) {
12863 #endif
12864
12865     /* We may be able to optimize this, but in order for fileify_dirspec to
12866      * always return a usuable answer, we have to call vmspath first to
12867      * make sure that it is in VMS directory format, as stat/lstat on 8.3
12868      * can not handle directories in unix format that it does not have read
12869      * access to.  Vmspath handles the case where a bare name which could be
12870      * a logical name gets passed.
12871      */
12872     ret_spec = int_tovmspath(fspec, temp_fspec, NULL);
12873     if (ret_spec != NULL) {
12874         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
12875         if (ret_spec != NULL) {
12876             if (lstat_flag == 0)
12877                 retval = stat(fileified, &statbufp->crtl_stat);
12878             else
12879                 retval = lstat(fileified, &statbufp->crtl_stat);
12880             save_spec = fileified;
12881         }
12882     }
12883
12884     if (retval && vms_bug_stat_filename) {
12885
12886         /* We should try again as a vmsified file specification */
12887         /* However Perl traditionally has not done this, which  */
12888         /* causes problems with existing tests */
12889
12890         ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12891         if (ret_spec != NULL) {
12892             if (lstat_flag == 0)
12893                 retval = stat(temp_fspec, &statbufp->crtl_stat);
12894             else
12895                 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12896             save_spec = temp_fspec;
12897         }
12898     }
12899
12900     if (retval) {
12901         /* Last chance - allow multiple dots with out EFS CHARSET */
12902         /* The CRTL stat() falls down hard on multi-dot filenames in unix
12903          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12904          * enable it if it isn't already.
12905          */
12906 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12907         if (!decc_efs_charset && (decc_efs_charset_index > 0))
12908             decc$feature_set_value(decc_efs_charset_index, 1, 1);
12909 #endif
12910         if (lstat_flag == 0)
12911             retval = stat(fspec, &statbufp->crtl_stat);
12912         else
12913             retval = lstat(fspec, &statbufp->crtl_stat);
12914         save_spec = fspec;
12915 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12916         if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
12917             decc$feature_set_value(decc_efs_charset_index, 1, 0);
12918             efs_hack = 1;
12919         }
12920 #endif
12921     }
12922
12923 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12924   } else {
12925     if (lstat_flag == 0)
12926       retval = stat(temp_fspec, &statbufp->crtl_stat);
12927     else
12928       retval = lstat(temp_fspec, &statbufp->crtl_stat);
12929       save_spec = temp_fspec;
12930   }
12931 #endif
12932
12933 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12934   /* As you were... */
12935   if (!decc_efs_charset)
12936     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12937 #endif
12938
12939     if (!retval) {
12940     char * cptr;
12941     int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12942
12943       /* If this is an lstat, do not follow the link */
12944       if (lstat_flag)
12945         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12946
12947 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12948       /* If we used the efs_hack above, we must also use it here for */
12949       /* perl_cando to work */
12950       if (efs_hack && (decc_efs_charset_index > 0)) {
12951           decc$feature_set_value(decc_efs_charset_index, 1, 1);
12952       }
12953 #endif
12954       cptr = int_rmsexpand_tovms(save_spec, statbufp->st_devnam, rmsex_flags);
12955 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12956       if (efs_hack && (decc_efs_charset_index > 0)) {
12957           decc$feature_set_value(decc_efs_charset, 1, 0);
12958       }
12959 #endif
12960
12961       /* Fix me: If this is NULL then stat found a file, and we could */
12962       /* not convert the specification to VMS - Should never happen */
12963       if (cptr == NULL)
12964         statbufp->st_devnam[0] = 0;
12965
12966       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12967       VMS_DEVICE_ENCODE
12968         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12969 #     ifdef RTL_USES_UTC
12970 #     ifdef VMSISH_TIME
12971       if (VMSISH_TIME) {
12972         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12973         statbufp->st_atime = _toloc(statbufp->st_atime);
12974         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12975       }
12976 #     endif
12977 #     else
12978 #     ifdef VMSISH_TIME
12979       if (!VMSISH_TIME) { /* Return UTC instead of local time */
12980 #     else
12981       if (1) {
12982 #     endif
12983         statbufp->st_mtime = _toutc(statbufp->st_mtime);
12984         statbufp->st_atime = _toutc(statbufp->st_atime);
12985         statbufp->st_ctime = _toutc(statbufp->st_ctime);
12986       }
12987 #     endif
12988     }
12989     /* If we were successful, leave errno where we found it */
12990     if (retval == 0) RESTORE_ERRNO;
12991     return retval;
12992
12993 }  /* end of flex_stat_int() */
12994
12995
12996 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12997 int
12998 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12999 {
13000    return flex_stat_int(fspec, statbufp, 0);
13001 }
13002 /*}}}*/
13003
13004 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
13005 int
13006 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
13007 {
13008    return flex_stat_int(fspec, statbufp, 1);
13009 }
13010 /*}}}*/
13011
13012
13013 /*{{{char *my_getlogin()*/
13014 /* VMS cuserid == Unix getlogin, except calling sequence */
13015 char *
13016 my_getlogin(void)
13017 {
13018     static char user[L_cuserid];
13019     return cuserid(user);
13020 }
13021 /*}}}*/
13022
13023
13024 /*  rmscopy - copy a file using VMS RMS routines
13025  *
13026  *  Copies contents and attributes of spec_in to spec_out, except owner
13027  *  and protection information.  Name and type of spec_in are used as
13028  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
13029  *  should try to propagate timestamps from the input file to the output file.
13030  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
13031  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
13032  *  propagated to the output file at creation iff the output file specification
13033  *  did not contain an explicit name or type, and the revision date is always
13034  *  updated at the end of the copy operation.  If it is greater than 0, then
13035  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
13036  *  other than the revision date should be propagated, and bit 1 indicates
13037  *  that the revision date should be propagated.
13038  *
13039  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
13040  *
13041  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
13042  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
13043  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
13044  * as part of the Perl standard distribution under the terms of the
13045  * GNU General Public License or the Perl Artistic License.  Copies
13046  * of each may be found in the Perl standard distribution.
13047  */ /* FIXME */
13048 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
13049 int
13050 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
13051 {
13052     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
13053          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
13054     unsigned long int i, sts, sts2;
13055     int dna_len;
13056     struct FAB fab_in, fab_out;
13057     struct RAB rab_in, rab_out;
13058     rms_setup_nam(nam);
13059     rms_setup_nam(nam_out);
13060     struct XABDAT xabdat;
13061     struct XABFHC xabfhc;
13062     struct XABRDT xabrdt;
13063     struct XABSUM xabsum;
13064
13065     vmsin = PerlMem_malloc(VMS_MAXRSS);
13066     if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13067     vmsout = PerlMem_malloc(VMS_MAXRSS);
13068     if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13069     if (!spec_in  || !*spec_in  || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
13070         !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
13071       PerlMem_free(vmsin);
13072       PerlMem_free(vmsout);
13073       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13074       return 0;
13075     }
13076
13077     esa = PerlMem_malloc(VMS_MAXRSS);
13078     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13079     esal = NULL;
13080 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
13081     esal = PerlMem_malloc(VMS_MAXRSS);
13082     if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13083 #endif
13084     fab_in = cc$rms_fab;
13085     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
13086     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
13087     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
13088     fab_in.fab$l_fop = FAB$M_SQO;
13089     rms_bind_fab_nam(fab_in, nam);
13090     fab_in.fab$l_xab = (void *) &xabdat;
13091
13092     rsa = PerlMem_malloc(VMS_MAXRSS);
13093     if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13094     rsal = NULL;
13095 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
13096     rsal = PerlMem_malloc(VMS_MAXRSS);
13097     if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13098 #endif
13099     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
13100     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
13101     rms_nam_esl(nam) = 0;
13102     rms_nam_rsl(nam) = 0;
13103     rms_nam_esll(nam) = 0;
13104     rms_nam_rsll(nam) = 0;
13105 #ifdef NAM$M_NO_SHORT_UPCASE
13106     if (decc_efs_case_preserve)
13107         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
13108 #endif
13109
13110     xabdat = cc$rms_xabdat;        /* To get creation date */
13111     xabdat.xab$l_nxt = (void *) &xabfhc;
13112
13113     xabfhc = cc$rms_xabfhc;        /* To get record length */
13114     xabfhc.xab$l_nxt = (void *) &xabsum;
13115
13116     xabsum = cc$rms_xabsum;        /* To get key and area information */
13117
13118     if (!((sts = sys$open(&fab_in)) & 1)) {
13119       PerlMem_free(vmsin);
13120       PerlMem_free(vmsout);
13121       PerlMem_free(esa);
13122       if (esal != NULL)
13123         PerlMem_free(esal);
13124       PerlMem_free(rsa);
13125       if (rsal != NULL)
13126         PerlMem_free(rsal);
13127       set_vaxc_errno(sts);
13128       switch (sts) {
13129         case RMS$_FNF: case RMS$_DNF:
13130           set_errno(ENOENT); break;
13131         case RMS$_DIR:
13132           set_errno(ENOTDIR); break;
13133         case RMS$_DEV:
13134           set_errno(ENODEV); break;
13135         case RMS$_SYN:
13136           set_errno(EINVAL); break;
13137         case RMS$_PRV:
13138           set_errno(EACCES); break;
13139         default:
13140           set_errno(EVMSERR);
13141       }
13142       return 0;
13143     }
13144
13145     nam_out = nam;
13146     fab_out = fab_in;
13147     fab_out.fab$w_ifi = 0;
13148     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
13149     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
13150     fab_out.fab$l_fop = FAB$M_SQO;
13151     rms_bind_fab_nam(fab_out, nam_out);
13152     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
13153     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
13154     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
13155     esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
13156     if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13157     rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
13158     if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13159     esal_out = NULL;
13160     rsal_out = NULL;
13161 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
13162     esal_out = PerlMem_malloc(VMS_MAXRSS);
13163     if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13164     rsal_out = PerlMem_malloc(VMS_MAXRSS);
13165     if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13166 #endif
13167     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
13168     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
13169
13170     if (preserve_dates == 0) {  /* Act like DCL COPY */
13171       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
13172       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
13173       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
13174         PerlMem_free(vmsin);
13175         PerlMem_free(vmsout);
13176         PerlMem_free(esa);
13177         if (esal != NULL)
13178             PerlMem_free(esal);
13179         PerlMem_free(rsa);
13180         if (rsal != NULL)
13181             PerlMem_free(rsal);
13182         PerlMem_free(esa_out);
13183         if (esal_out != NULL)
13184             PerlMem_free(esal_out);
13185         PerlMem_free(rsa_out);
13186         if (rsal_out != NULL)
13187             PerlMem_free(rsal_out);
13188         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
13189         set_vaxc_errno(sts);
13190         return 0;
13191       }
13192       fab_out.fab$l_xab = (void *) &xabdat;
13193       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
13194         preserve_dates = 1;
13195     }
13196     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
13197       preserve_dates =0;      /* bitmask from this point forward   */
13198
13199     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
13200     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
13201       PerlMem_free(vmsin);
13202       PerlMem_free(vmsout);
13203       PerlMem_free(esa);
13204       if (esal != NULL)
13205           PerlMem_free(esal);
13206       PerlMem_free(rsa);
13207       if (rsal != NULL)
13208           PerlMem_free(rsal);
13209       PerlMem_free(esa_out);
13210       if (esal_out != NULL)
13211           PerlMem_free(esal_out);
13212       PerlMem_free(rsa_out);
13213       if (rsal_out != NULL)
13214           PerlMem_free(rsal_out);
13215       set_vaxc_errno(sts);
13216       switch (sts) {
13217         case RMS$_DNF:
13218           set_errno(ENOENT); break;
13219         case RMS$_DIR:
13220           set_errno(ENOTDIR); break;
13221         case RMS$_DEV:
13222           set_errno(ENODEV); break;
13223         case RMS$_SYN:
13224           set_errno(EINVAL); break;
13225         case RMS$_PRV:
13226           set_errno(EACCES); break;
13227         default:
13228           set_errno(EVMSERR);
13229       }
13230       return 0;
13231     }
13232     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
13233     if (preserve_dates & 2) {
13234       /* sys$close() will process xabrdt, not xabdat */
13235       xabrdt = cc$rms_xabrdt;
13236 #ifndef __GNUC__
13237       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
13238 #else
13239       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
13240        * is unsigned long[2], while DECC & VAXC use a struct */
13241       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
13242 #endif
13243       fab_out.fab$l_xab = (void *) &xabrdt;
13244     }
13245
13246     ubf = PerlMem_malloc(32256);
13247     if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13248     rab_in = cc$rms_rab;
13249     rab_in.rab$l_fab = &fab_in;
13250     rab_in.rab$l_rop = RAB$M_BIO;
13251     rab_in.rab$l_ubf = ubf;
13252     rab_in.rab$w_usz = 32256;
13253     if (!((sts = sys$connect(&rab_in)) & 1)) {
13254       sys$close(&fab_in); sys$close(&fab_out);
13255       PerlMem_free(vmsin);
13256       PerlMem_free(vmsout);
13257       PerlMem_free(ubf);
13258       PerlMem_free(esa);
13259       if (esal != NULL)
13260           PerlMem_free(esal);
13261       PerlMem_free(rsa);
13262       if (rsal != NULL)
13263           PerlMem_free(rsal);
13264       PerlMem_free(esa_out);
13265       if (esal_out != NULL)
13266           PerlMem_free(esal_out);
13267       PerlMem_free(rsa_out);
13268       if (rsal_out != NULL)
13269           PerlMem_free(rsal_out);
13270       set_errno(EVMSERR); set_vaxc_errno(sts);
13271       return 0;
13272     }
13273
13274     rab_out = cc$rms_rab;
13275     rab_out.rab$l_fab = &fab_out;
13276     rab_out.rab$l_rbf = ubf;
13277     if (!((sts = sys$connect(&rab_out)) & 1)) {
13278       sys$close(&fab_in); sys$close(&fab_out);
13279       PerlMem_free(vmsin);
13280       PerlMem_free(vmsout);
13281       PerlMem_free(ubf);
13282       PerlMem_free(esa);
13283       if (esal != NULL)
13284           PerlMem_free(esal);
13285       PerlMem_free(rsa);
13286       if (rsal != NULL)
13287           PerlMem_free(rsal);
13288       PerlMem_free(esa_out);
13289       if (esal_out != NULL)
13290           PerlMem_free(esal_out);
13291       PerlMem_free(rsa_out);
13292       if (rsal_out != NULL)
13293           PerlMem_free(rsal_out);
13294       set_errno(EVMSERR); set_vaxc_errno(sts);
13295       return 0;
13296     }
13297
13298     while ((sts = sys$read(&rab_in))) {  /* always true  */
13299       if (sts == RMS$_EOF) break;
13300       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
13301       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
13302         sys$close(&fab_in); sys$close(&fab_out);
13303         PerlMem_free(vmsin);
13304         PerlMem_free(vmsout);
13305         PerlMem_free(ubf);
13306         PerlMem_free(esa);
13307         if (esal != NULL)
13308             PerlMem_free(esal);
13309         PerlMem_free(rsa);
13310         if (rsal != NULL)
13311             PerlMem_free(rsal);
13312         PerlMem_free(esa_out);
13313         if (esal_out != NULL)
13314             PerlMem_free(esal_out);
13315         PerlMem_free(rsa_out);
13316         if (rsal_out != NULL)
13317             PerlMem_free(rsal_out);
13318         set_errno(EVMSERR); set_vaxc_errno(sts);
13319         return 0;
13320       }
13321     }
13322
13323
13324     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
13325     sys$close(&fab_in);  sys$close(&fab_out);
13326     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
13327
13328     PerlMem_free(vmsin);
13329     PerlMem_free(vmsout);
13330     PerlMem_free(ubf);
13331     PerlMem_free(esa);
13332     if (esal != NULL)
13333         PerlMem_free(esal);
13334     PerlMem_free(rsa);
13335     if (rsal != NULL)
13336         PerlMem_free(rsal);
13337     PerlMem_free(esa_out);
13338     if (esal_out != NULL)
13339         PerlMem_free(esal_out);
13340     PerlMem_free(rsa_out);
13341     if (rsal_out != NULL)
13342         PerlMem_free(rsal_out);
13343
13344     if (!(sts & 1)) {
13345       set_errno(EVMSERR); set_vaxc_errno(sts);
13346       return 0;
13347     }
13348
13349     return 1;
13350
13351 }  /* end of rmscopy() */
13352 /*}}}*/
13353
13354
13355 /***  The following glue provides 'hooks' to make some of the routines
13356  * from this file available from Perl.  These routines are sufficiently
13357  * basic, and are required sufficiently early in the build process,
13358  * that's it's nice to have them available to miniperl as well as the
13359  * full Perl, so they're set up here instead of in an extension.  The
13360  * Perl code which handles importation of these names into a given
13361  * package lives in [.VMS]Filespec.pm in @INC.
13362  */
13363
13364 void
13365 rmsexpand_fromperl(pTHX_ CV *cv)
13366 {
13367   dXSARGS;
13368   char *fspec, *defspec = NULL, *rslt;
13369   STRLEN n_a;
13370   int fs_utf8, dfs_utf8;
13371
13372   fs_utf8 = 0;
13373   dfs_utf8 = 0;
13374   if (!items || items > 2)
13375     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
13376   fspec = SvPV(ST(0),n_a);
13377   fs_utf8 = SvUTF8(ST(0));
13378   if (!fspec || !*fspec) XSRETURN_UNDEF;
13379   if (items == 2) {
13380     defspec = SvPV(ST(1),n_a);
13381     dfs_utf8 = SvUTF8(ST(1));
13382   }
13383   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
13384   ST(0) = sv_newmortal();
13385   if (rslt != NULL) {
13386     sv_usepvn(ST(0),rslt,strlen(rslt));
13387     if (fs_utf8) {
13388         SvUTF8_on(ST(0));
13389     }
13390   }
13391   XSRETURN(1);
13392 }
13393
13394 void
13395 vmsify_fromperl(pTHX_ CV *cv)
13396 {
13397   dXSARGS;
13398   char *vmsified;
13399   STRLEN n_a;
13400   int utf8_fl;
13401
13402   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
13403   utf8_fl = SvUTF8(ST(0));
13404   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13405   ST(0) = sv_newmortal();
13406   if (vmsified != NULL) {
13407     sv_usepvn(ST(0),vmsified,strlen(vmsified));
13408     if (utf8_fl) {
13409         SvUTF8_on(ST(0));
13410     }
13411   }
13412   XSRETURN(1);
13413 }
13414
13415 void
13416 unixify_fromperl(pTHX_ CV *cv)
13417 {
13418   dXSARGS;
13419   char *unixified;
13420   STRLEN n_a;
13421   int utf8_fl;
13422
13423   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
13424   utf8_fl = SvUTF8(ST(0));
13425   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13426   ST(0) = sv_newmortal();
13427   if (unixified != NULL) {
13428     sv_usepvn(ST(0),unixified,strlen(unixified));
13429     if (utf8_fl) {
13430         SvUTF8_on(ST(0));
13431     }
13432   }
13433   XSRETURN(1);
13434 }
13435
13436 void
13437 fileify_fromperl(pTHX_ CV *cv)
13438 {
13439   dXSARGS;
13440   char *fileified;
13441   STRLEN n_a;
13442   int utf8_fl;
13443
13444   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
13445   utf8_fl = SvUTF8(ST(0));
13446   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13447   ST(0) = sv_newmortal();
13448   if (fileified != NULL) {
13449     sv_usepvn(ST(0),fileified,strlen(fileified));
13450     if (utf8_fl) {
13451         SvUTF8_on(ST(0));
13452     }
13453   }
13454   XSRETURN(1);
13455 }
13456
13457 void
13458 pathify_fromperl(pTHX_ CV *cv)
13459 {
13460   dXSARGS;
13461   char *pathified;
13462   STRLEN n_a;
13463   int utf8_fl;
13464
13465   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
13466   utf8_fl = SvUTF8(ST(0));
13467   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13468   ST(0) = sv_newmortal();
13469   if (pathified != NULL) {
13470     sv_usepvn(ST(0),pathified,strlen(pathified));
13471     if (utf8_fl) {
13472         SvUTF8_on(ST(0));
13473     }
13474   }
13475   XSRETURN(1);
13476 }
13477
13478 void
13479 vmspath_fromperl(pTHX_ CV *cv)
13480 {
13481   dXSARGS;
13482   char *vmspath;
13483   STRLEN n_a;
13484   int utf8_fl;
13485
13486   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
13487   utf8_fl = SvUTF8(ST(0));
13488   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13489   ST(0) = sv_newmortal();
13490   if (vmspath != NULL) {
13491     sv_usepvn(ST(0),vmspath,strlen(vmspath));
13492     if (utf8_fl) {
13493         SvUTF8_on(ST(0));
13494     }
13495   }
13496   XSRETURN(1);
13497 }
13498
13499 void
13500 unixpath_fromperl(pTHX_ CV *cv)
13501 {
13502   dXSARGS;
13503   char *unixpath;
13504   STRLEN n_a;
13505   int utf8_fl;
13506
13507   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
13508   utf8_fl = SvUTF8(ST(0));
13509   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13510   ST(0) = sv_newmortal();
13511   if (unixpath != NULL) {
13512     sv_usepvn(ST(0),unixpath,strlen(unixpath));
13513     if (utf8_fl) {
13514         SvUTF8_on(ST(0));
13515     }
13516   }
13517   XSRETURN(1);
13518 }
13519
13520 void
13521 candelete_fromperl(pTHX_ CV *cv)
13522 {
13523   dXSARGS;
13524   char *fspec, *fsp;
13525   SV *mysv;
13526   IO *io;
13527   STRLEN n_a;
13528
13529   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
13530
13531   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13532   Newx(fspec, VMS_MAXRSS, char);
13533   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
13534   if (SvTYPE(mysv) == SVt_PVGV) {
13535     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
13536       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13537       ST(0) = &PL_sv_no;
13538       Safefree(fspec);
13539       XSRETURN(1);
13540     }
13541     fsp = fspec;
13542   }
13543   else {
13544     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
13545       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13546       ST(0) = &PL_sv_no;
13547       Safefree(fspec);
13548       XSRETURN(1);
13549     }
13550   }
13551
13552   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
13553   Safefree(fspec);
13554   XSRETURN(1);
13555 }
13556
13557 void
13558 rmscopy_fromperl(pTHX_ CV *cv)
13559 {
13560   dXSARGS;
13561   char *inspec, *outspec, *inp, *outp;
13562   int date_flag;
13563   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
13564                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13565   unsigned long int sts;
13566   SV *mysv;
13567   IO *io;
13568   STRLEN n_a;
13569
13570   if (items < 2 || items > 3)
13571     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
13572
13573   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13574   Newx(inspec, VMS_MAXRSS, char);
13575   if (SvTYPE(mysv) == SVt_PVGV) {
13576     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
13577       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13578       ST(0) = sv_2mortal(newSViv(0));
13579       Safefree(inspec);
13580       XSRETURN(1);
13581     }
13582     inp = inspec;
13583   }
13584   else {
13585     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
13586       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13587       ST(0) = sv_2mortal(newSViv(0));
13588       Safefree(inspec);
13589       XSRETURN(1);
13590     }
13591   }
13592   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
13593   Newx(outspec, VMS_MAXRSS, char);
13594   if (SvTYPE(mysv) == SVt_PVGV) {
13595     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
13596       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13597       ST(0) = sv_2mortal(newSViv(0));
13598       Safefree(inspec);
13599       Safefree(outspec);
13600       XSRETURN(1);
13601     }
13602     outp = outspec;
13603   }
13604   else {
13605     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
13606       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13607       ST(0) = sv_2mortal(newSViv(0));
13608       Safefree(inspec);
13609       Safefree(outspec);
13610       XSRETURN(1);
13611     }
13612   }
13613   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
13614
13615   ST(0) = sv_2mortal(newSViv(rmscopy(inp,outp,date_flag)));
13616   Safefree(inspec);
13617   Safefree(outspec);
13618   XSRETURN(1);
13619 }
13620
13621 /* The mod2fname is limited to shorter filenames by design, so it should
13622  * not be modified to support longer EFS pathnames
13623  */
13624 void
13625 mod2fname(pTHX_ CV *cv)
13626 {
13627   dXSARGS;
13628   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
13629        workbuff[NAM$C_MAXRSS*1 + 1];
13630   int total_namelen = 3, counter, num_entries;
13631   /* ODS-5 ups this, but we want to be consistent, so... */
13632   int max_name_len = 39;
13633   AV *in_array = (AV *)SvRV(ST(0));
13634
13635   num_entries = av_len(in_array);
13636
13637   /* All the names start with PL_. */
13638   strcpy(ultimate_name, "PL_");
13639
13640   /* Clean up our working buffer */
13641   Zero(work_name, sizeof(work_name), char);
13642
13643   /* Run through the entries and build up a working name */
13644   for(counter = 0; counter <= num_entries; counter++) {
13645     /* If it's not the first name then tack on a __ */
13646     if (counter) {
13647       strcat(work_name, "__");
13648     }
13649     strcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)));
13650   }
13651
13652   /* Check to see if we actually have to bother...*/
13653   if (strlen(work_name) + 3 <= max_name_len) {
13654     strcat(ultimate_name, work_name);
13655   } else {
13656     /* It's too darned big, so we need to go strip. We use the same */
13657     /* algorithm as xsubpp does. First, strip out doubled __ */
13658     char *source, *dest, last;
13659     dest = workbuff;
13660     last = 0;
13661     for (source = work_name; *source; source++) {
13662       if (last == *source && last == '_') {
13663         continue;
13664       }
13665       *dest++ = *source;
13666       last = *source;
13667     }
13668     /* Go put it back */
13669     strcpy(work_name, workbuff);
13670     /* Is it still too big? */
13671     if (strlen(work_name) + 3 > max_name_len) {
13672       /* Strip duplicate letters */
13673       last = 0;
13674       dest = workbuff;
13675       for (source = work_name; *source; source++) {
13676         if (last == toupper(*source)) {
13677         continue;
13678         }
13679         *dest++ = *source;
13680         last = toupper(*source);
13681       }
13682       strcpy(work_name, workbuff);
13683     }
13684
13685     /* Is it *still* too big? */
13686     if (strlen(work_name) + 3 > max_name_len) {
13687       /* Too bad, we truncate */
13688       work_name[max_name_len - 2] = 0;
13689     }
13690     strcat(ultimate_name, work_name);
13691   }
13692
13693   /* Okay, return it */
13694   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
13695   XSRETURN(1);
13696 }
13697
13698 void
13699 hushexit_fromperl(pTHX_ CV *cv)
13700 {
13701     dXSARGS;
13702
13703     if (items > 0) {
13704         VMSISH_HUSHED = SvTRUE(ST(0));
13705     }
13706     ST(0) = boolSV(VMSISH_HUSHED);
13707     XSRETURN(1);
13708 }
13709
13710
13711 PerlIO *
13712 Perl_vms_start_glob
13713    (pTHX_ SV *tmpglob,
13714     IO *io)
13715 {
13716     PerlIO *fp;
13717     struct vs_str_st *rslt;
13718     char *vmsspec;
13719     char *rstr;
13720     char *begin, *cp;
13721     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13722     PerlIO *tmpfp;
13723     STRLEN i;
13724     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13725     struct dsc$descriptor_vs rsdsc;
13726     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13727     unsigned long hasver = 0, isunix = 0;
13728     unsigned long int lff_flags = 0;
13729     int rms_sts;
13730     int vms_old_glob = 1;
13731
13732     if (!SvOK(tmpglob)) {
13733         SETERRNO(ENOENT,RMS$_FNF);
13734         return NULL;
13735     }
13736
13737     vms_old_glob = !decc_filename_unix_report;
13738
13739 #ifdef VMS_LONGNAME_SUPPORT
13740     lff_flags = LIB$M_FIL_LONG_NAMES;
13741 #endif
13742     /* The Newx macro will not allow me to assign a smaller array
13743      * to the rslt pointer, so we will assign it to the begin char pointer
13744      * and then copy the value into the rslt pointer.
13745      */
13746     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13747     rslt = (struct vs_str_st *)begin;
13748     rslt->length = 0;
13749     rstr = &rslt->str[0];
13750     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13751     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13752     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13753     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13754
13755     Newx(vmsspec, VMS_MAXRSS, char);
13756
13757         /* We could find out if there's an explicit dev/dir or version
13758            by peeking into lib$find_file's internal context at
13759            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13760            but that's unsupported, so I don't want to do it now and
13761            have it bite someone in the future. */
13762         /* Fix-me: vms_split_path() is the only way to do this, the
13763            existing method will fail with many legal EFS or UNIX specifications
13764          */
13765
13766     cp = SvPV(tmpglob,i);
13767
13768     for (; i; i--) {
13769         if (cp[i] == ';') hasver = 1;
13770         if (cp[i] == '.') {
13771             if (sts) hasver = 1;
13772             else sts = 1;
13773         }
13774         if (cp[i] == '/') {
13775             hasdir = isunix = 1;
13776             break;
13777         }
13778         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13779             hasdir = 1;
13780             break;
13781         }
13782     }
13783
13784     /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13785     if ((hasdir == 0) && decc_filename_unix_report) {
13786         isunix = 1;
13787     }
13788
13789     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13790         char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13791         int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13792         int wildstar = 0;
13793         int wildquery = 0;
13794         int found = 0;
13795         Stat_t st;
13796         int stat_sts;
13797         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13798         if (!stat_sts && S_ISDIR(st.st_mode)) {
13799             char * vms_dir;
13800             const char * fname;
13801             STRLEN fname_len;
13802
13803             /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13804             /* path delimiter of ':>]', if so, then the old behavior has */
13805             /* obviously been specificially requested */
13806
13807             fname = SvPVX_const(tmpglob);
13808             fname_len = strlen(fname);
13809             vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13810             if (vms_old_glob || (vms_dir != NULL)) {
13811                 wilddsc.dsc$a_pointer = tovmspath_utf8(
13812                                             SvPVX(tmpglob),vmsspec,NULL);
13813                 ok = (wilddsc.dsc$a_pointer != NULL);
13814                 /* maybe passed 'foo' rather than '[.foo]', thus not
13815                    detected above */
13816                 hasdir = 1;
13817             } else {
13818                 /* Operate just on the directory, the special stat/fstat for */
13819                 /* leaves the fileified  specification in the st_devnam */
13820                 /* member. */
13821                 wilddsc.dsc$a_pointer = st.st_devnam;
13822                 ok = 1;
13823             }
13824         }
13825         else {
13826             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13827             ok = (wilddsc.dsc$a_pointer != NULL);
13828         }
13829         if (ok)
13830             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13831
13832         /* If not extended character set, replace ? with % */
13833         /* With extended character set, ? is a wildcard single character */
13834         for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13835             if (*cp == '?') {
13836                 wildquery = 1;
13837                 if (!decc_efs_case_preserve)
13838                     *cp = '%';
13839             } else if (*cp == '%') {
13840                 wildquery = 1;
13841             } else if (*cp == '*') {
13842                 wildstar = 1;
13843             }
13844         }
13845
13846         if (ok) {
13847             wv_sts = vms_split_path(
13848                 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13849                 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13850                 &wvs_spec, &wvs_len);
13851         } else {
13852             wn_spec = NULL;
13853             wn_len = 0;
13854             we_spec = NULL;
13855             we_len = 0;
13856         }
13857
13858         sts = SS$_NORMAL;
13859         while (ok && $VMS_STATUS_SUCCESS(sts)) {
13860          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13861          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13862          int valid_find;
13863
13864             valid_find = 0;
13865             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13866                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
13867             if (!$VMS_STATUS_SUCCESS(sts))
13868                 break;
13869
13870             /* with varying string, 1st word of buffer contains result length */
13871             rstr[rslt->length] = '\0';
13872
13873              /* Find where all the components are */
13874              v_sts = vms_split_path
13875                        (rstr,
13876                         &v_spec,
13877                         &v_len,
13878                         &r_spec,
13879                         &r_len,
13880                         &d_spec,
13881                         &d_len,
13882                         &n_spec,
13883                         &n_len,
13884                         &e_spec,
13885                         &e_len,
13886                         &vs_spec,
13887                         &vs_len);
13888
13889             /* If no version on input, truncate the version on output */
13890             if (!hasver && (vs_len > 0)) {
13891                 *vs_spec = '\0';
13892                 vs_len = 0;
13893             }
13894
13895             if (isunix) {
13896
13897                 /* In Unix report mode, remove the ".dir;1" from the name */
13898                 /* if it is a real directory */
13899                 if (decc_filename_unix_report || decc_efs_charset) {
13900                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13901                         Stat_t statbuf;
13902                         int ret_sts;
13903
13904                         ret_sts = flex_lstat(rstr, &statbuf);
13905                         if ((ret_sts == 0) &&
13906                             S_ISDIR(statbuf.st_mode)) {
13907                             e_len = 0;
13908                             e_spec[0] = 0;
13909                         }
13910                     }
13911                 }
13912
13913                 /* No version & a null extension on UNIX handling */
13914                 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13915                     e_len = 0;
13916                     *e_spec = '\0';
13917                 }
13918             }
13919
13920             if (!decc_efs_case_preserve) {
13921                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13922             }
13923
13924             /* Find File treats a Null extension as return all extensions */
13925             /* This is contrary to Perl expectations */
13926
13927             if (wildstar || wildquery || vms_old_glob) {
13928                 /* really need to see if the returned file name matched */
13929                 /* but for now will assume that it matches */
13930                 valid_find = 1;
13931             } else {
13932                 /* Exact Match requested */
13933                 /* How are directories handled? - like a file */
13934                 if ((e_len == we_len) && (n_len == wn_len)) {
13935                     int t1;
13936                     t1 = e_len;
13937                     if (t1 > 0)
13938                         t1 = strncmp(e_spec, we_spec, e_len);
13939                     if (t1 == 0) {
13940                        t1 = n_len;
13941                        if (t1 > 0)
13942                            t1 = strncmp(n_spec, we_spec, n_len);
13943                        if (t1 == 0)
13944                            valid_find = 1;
13945                     }
13946                 }
13947             }
13948
13949             if (valid_find) {
13950                 found++;
13951
13952                 if (hasdir) {
13953                     if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13954                     begin = rstr;
13955                 }
13956                 else {
13957                     /* Start with the name */
13958                     begin = n_spec;
13959                 }
13960                 strcat(begin,"\n");
13961                 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13962             }
13963         }
13964         if (cxt) (void)lib$find_file_end(&cxt);
13965
13966         if (!found) {
13967             /* Be POSIXish: return the input pattern when no matches */
13968             strcpy(rstr,SvPVX(tmpglob));
13969             strcat(rstr,"\n");
13970             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13971         }
13972
13973         if (ok && sts != RMS$_NMF &&
13974             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13975         if (!ok) {
13976             if (!(sts & 1)) {
13977                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13978             }
13979             PerlIO_close(tmpfp);
13980             fp = NULL;
13981         }
13982         else {
13983             PerlIO_rewind(tmpfp);
13984             IoTYPE(io) = IoTYPE_RDONLY;
13985             IoIFP(io) = fp = tmpfp;
13986             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
13987         }
13988     }
13989     Safefree(vmsspec);
13990     Safefree(rslt);
13991     return fp;
13992 }
13993
13994
13995 static char *
13996 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13997                    int *utf8_fl);
13998
13999 void
14000 unixrealpath_fromperl(pTHX_ CV *cv)
14001 {
14002     dXSARGS;
14003     char *fspec, *rslt_spec, *rslt;
14004     STRLEN n_a;
14005
14006     if (!items || items != 1)
14007         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
14008
14009     fspec = SvPV(ST(0),n_a);
14010     if (!fspec || !*fspec) XSRETURN_UNDEF;
14011
14012     Newx(rslt_spec, VMS_MAXRSS + 1, char);
14013     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
14014
14015     ST(0) = sv_newmortal();
14016     if (rslt != NULL)
14017         sv_usepvn(ST(0),rslt,strlen(rslt));
14018     else
14019         Safefree(rslt_spec);
14020         XSRETURN(1);
14021 }
14022
14023 static char *
14024 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
14025                    int *utf8_fl);
14026
14027 void
14028 vmsrealpath_fromperl(pTHX_ CV *cv)
14029 {
14030     dXSARGS;
14031     char *fspec, *rslt_spec, *rslt;
14032     STRLEN n_a;
14033
14034     if (!items || items != 1)
14035         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
14036
14037     fspec = SvPV(ST(0),n_a);
14038     if (!fspec || !*fspec) XSRETURN_UNDEF;
14039
14040     Newx(rslt_spec, VMS_MAXRSS + 1, char);
14041     rslt = do_vms_realname(fspec, rslt_spec, NULL);
14042
14043     ST(0) = sv_newmortal();
14044     if (rslt != NULL)
14045         sv_usepvn(ST(0),rslt,strlen(rslt));
14046     else
14047         Safefree(rslt_spec);
14048         XSRETURN(1);
14049 }
14050
14051 #ifdef HAS_SYMLINK
14052 /*
14053  * A thin wrapper around decc$symlink to make sure we follow the
14054  * standard and do not create a symlink with a zero-length name.
14055  *
14056  * Also in ODS-2 mode, existing tests assume that the link target
14057  * will be converted to UNIX format.
14058  */
14059 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
14060 int Perl_my_symlink(pTHX_ const char *contents, const char *link_name) {
14061   if (!link_name || !*link_name) {
14062     SETERRNO(ENOENT, SS$_NOSUCHFILE);
14063     return -1;
14064   }
14065
14066   if (decc_efs_charset) {
14067       return symlink(contents, link_name);
14068   } else {
14069       int sts;
14070       char * utarget;
14071
14072       /* Unless we are in ODS-5 mode, convert the symlink target to UNIX */
14073       /* because in order to work, the symlink target must be in UNIX format */
14074
14075       /* As symbolic links can hold things other than files, we will only do */
14076       /* the conversion in in ODS-2 mode */
14077
14078       utarget = PerlMem_malloc(VMS_MAXRSS + 1);
14079       if (int_tounixspec(contents, utarget, NULL) == NULL) {
14080
14081           /* This should not fail, as an untranslatable filename */
14082           /* should be passed through */
14083           utarget = (char *)contents;
14084       }
14085       sts = symlink(utarget, link_name);
14086       PerlMem_free(utarget);
14087       return sts;
14088   }
14089
14090 }
14091 /*}}}*/
14092
14093 #endif /* HAS_SYMLINK */
14094
14095 int do_vms_case_tolerant(void);
14096
14097 void
14098 case_tolerant_process_fromperl(pTHX_ CV *cv)
14099 {
14100   dXSARGS;
14101   ST(0) = boolSV(do_vms_case_tolerant());
14102   XSRETURN(1);
14103 }
14104
14105 #ifdef USE_ITHREADS
14106
14107 void
14108 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
14109                           struct interp_intern *dst)
14110 {
14111     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
14112
14113     memcpy(dst,src,sizeof(struct interp_intern));
14114 }
14115
14116 #endif
14117
14118 void
14119 Perl_sys_intern_clear(pTHX)
14120 {
14121 }
14122
14123 void
14124 Perl_sys_intern_init(pTHX)
14125 {
14126     unsigned int ix = RAND_MAX;
14127     double x;
14128
14129     VMSISH_HUSHED = 0;
14130
14131     MY_POSIX_EXIT = vms_posix_exit;
14132
14133     x = (float)ix;
14134     MY_INV_RAND_MAX = 1./x;
14135 }
14136
14137 void
14138 init_os_extras(void)
14139 {
14140   dTHX;
14141   char* file = __FILE__;
14142   if (decc_disable_to_vms_logname_translation) {
14143     no_translate_barewords = TRUE;
14144   } else {
14145     no_translate_barewords = FALSE;
14146   }
14147
14148   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
14149   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
14150   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
14151   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
14152   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
14153   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
14154   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
14155   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
14156   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
14157   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
14158   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
14159   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
14160   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
14161   newXSproto("VMS::Filespec::case_tolerant_process",
14162       case_tolerant_process_fromperl,file,"");
14163
14164   store_pipelocs(aTHX);         /* will redo any earlier attempts */
14165
14166   return;
14167 }
14168
14169 #if __CRTL_VER == 80200000
14170 /* This missed getting in to the DECC SDK for 8.2 */
14171 char *realpath(const char *file_name, char * resolved_name, ...);
14172 #endif
14173
14174 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
14175 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
14176  * The perl fallback routine to provide realpath() is not as efficient
14177  * on OpenVMS.
14178  */
14179
14180 /* Hack, use old stat() as fastest way of getting ino_t and device */
14181 int decc$stat(const char *name, void * statbuf);
14182 #if !defined(__VAX) && __CRTL_VER >= 80200000
14183 int decc$lstat(const char *name, void * statbuf);
14184 #else
14185 #define decc$lstat decc$stat
14186 #endif
14187
14188
14189 /* Realpath is fragile.  In 8.3 it does not work if the feature
14190  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
14191  * links are implemented in RMS, not the CRTL. It also can fail if the
14192  * user does not have read/execute access to some of the directories.
14193  * So in order for Do What I Mean mode to work, if realpath() fails,
14194  * fall back to looking up the filename by the device name and FID.
14195  */
14196
14197 int vms_fid_to_name(char * outname, int outlen,
14198                     const char * name, int lstat_flag, mode_t * mode)
14199 {
14200 #pragma message save
14201 #pragma message disable MISALGNDSTRCT
14202 #pragma message disable MISALGNDMEM
14203 #pragma member_alignment save
14204 #pragma nomember_alignment
14205 struct statbuf_t {
14206     char           * st_dev;
14207     unsigned short st_ino[3];
14208     unsigned short old_st_mode;
14209     unsigned long  padl[30];  /* plenty of room */
14210 } statbuf;
14211 #pragma message restore
14212 #pragma member_alignment restore
14213
14214     int sts;
14215     struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
14216     struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
14217     char *fileified;
14218     char *temp_fspec;
14219     char *ret_spec;
14220
14221     /* Need to follow the mostly the same rules as flex_stat_int, or we may get
14222      * unexpected answers
14223      */
14224
14225     fileified = PerlMem_malloc(VMS_MAXRSS);
14226     if (fileified == NULL)
14227         _ckvmssts_noperl(SS$_INSFMEM);
14228
14229     temp_fspec = PerlMem_malloc(VMS_MAXRSS);
14230     if (temp_fspec == NULL)
14231         _ckvmssts_noperl(SS$_INSFMEM);
14232
14233     sts = -1;
14234     /* First need to try as a directory */
14235     ret_spec = int_tovmspath(name, temp_fspec, NULL);
14236     if (ret_spec != NULL) {
14237         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
14238         if (ret_spec != NULL) {
14239             if (lstat_flag == 0)
14240                 sts = decc$stat(fileified, &statbuf);
14241             else
14242                 sts = decc$lstat(fileified, &statbuf);
14243         }
14244     }
14245
14246     /* Then as a VMS file spec */
14247     if (sts != 0) {
14248         ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
14249         if (ret_spec != NULL) {
14250             if (lstat_flag == 0) {
14251                 sts = decc$stat(temp_fspec, &statbuf);
14252             } else {
14253                 sts = decc$lstat(temp_fspec, &statbuf);
14254             }
14255         }
14256     }
14257
14258     if (sts) {
14259         /* Next try - allow multiple dots with out EFS CHARSET */
14260         /* The CRTL stat() falls down hard on multi-dot filenames in unix
14261          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
14262          * enable it if it isn't already.
14263          */
14264 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14265         if (!decc_efs_charset && (decc_efs_charset_index > 0))
14266             decc$feature_set_value(decc_efs_charset_index, 1, 1);
14267 #endif
14268         ret_spec = int_tovmspath(name, temp_fspec, NULL);
14269         if (lstat_flag == 0) {
14270             sts = decc$stat(name, &statbuf);
14271         } else {
14272             sts = decc$lstat(name, &statbuf);
14273         }
14274 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14275         if (!decc_efs_charset && (decc_efs_charset_index > 0))
14276             decc$feature_set_value(decc_efs_charset_index, 1, 0);
14277 #endif
14278     }
14279
14280
14281     /* and then because the Perl Unix to VMS conversion is not perfect */
14282     /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
14283     /* characters from filenames so we need to try it as-is */
14284     if (sts) {
14285         if (lstat_flag == 0) {
14286             sts = decc$stat(name, &statbuf);
14287         } else {
14288             sts = decc$lstat(name, &statbuf);
14289         }
14290     }
14291
14292     if (sts == 0) {
14293         int vms_sts;
14294
14295         dvidsc.dsc$a_pointer=statbuf.st_dev;
14296         dvidsc.dsc$w_length=strlen(statbuf.st_dev);
14297
14298         specdsc.dsc$a_pointer = outname;
14299         specdsc.dsc$w_length = outlen-1;
14300
14301         vms_sts = lib$fid_to_name
14302             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
14303         if ($VMS_STATUS_SUCCESS(vms_sts)) {
14304             outname[specdsc.dsc$w_length] = 0;
14305
14306             /* Return the mode */
14307             if (mode) {
14308                 *mode = statbuf.old_st_mode;
14309             }
14310             return 0;
14311         }
14312     }
14313     return sts;
14314 }
14315
14316
14317
14318 static char *
14319 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
14320                    int *utf8_fl)
14321 {
14322     char * rslt = NULL;
14323
14324 #ifdef HAS_SYMLINK
14325     if (decc_posix_compliant_pathnames > 0 ) {
14326         /* realpath currently only works if posix compliant pathnames are
14327          * enabled.  It may start working when they are not, but in that
14328          * case we still want the fallback behavior for backwards compatibility
14329          */
14330         rslt = realpath(filespec, outbuf);
14331     }
14332 #endif
14333
14334     if (rslt == NULL) {
14335         char * vms_spec;
14336         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
14337         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
14338         int file_len;
14339         mode_t my_mode;
14340
14341         /* Fall back to fid_to_name */
14342
14343         Newx(vms_spec, VMS_MAXRSS + 1, char);
14344
14345         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
14346         if (sts == 0) {
14347
14348
14349             /* Now need to trim the version off */
14350             sts = vms_split_path
14351                   (vms_spec,
14352                    &v_spec,
14353                    &v_len,
14354                    &r_spec,
14355                    &r_len,
14356                    &d_spec,
14357                    &d_len,
14358                    &n_spec,
14359                    &n_len,
14360                    &e_spec,
14361                    &e_len,
14362                    &vs_spec,
14363                    &vs_len);
14364
14365
14366                 if (sts == 0) {
14367                     int haslower = 0;
14368                     const char *cp;
14369
14370                     /* Trim off the version */
14371                     int file_len = v_len + r_len + d_len + n_len + e_len;
14372                     vms_spec[file_len] = 0;
14373
14374                     /* Trim off the .DIR if this is a directory */
14375                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
14376                         if (S_ISDIR(my_mode)) {
14377                             e_len = 0;
14378                             e_spec[0] = 0;
14379                         }
14380                     }
14381
14382                     /* Drop NULL extensions on UNIX file specification */
14383                     if ((e_len == 1) && decc_readdir_dropdotnotype) {
14384                         e_len = 0;
14385                         e_spec[0] = '\0';
14386                     }
14387
14388                     /* The result is expected to be in UNIX format */
14389                     rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
14390
14391                     /* Downcase if input had any lower case letters and
14392                      * case preservation is not in effect.
14393                      */
14394                     if (!decc_efs_case_preserve) {
14395                         for (cp = filespec; *cp; cp++)
14396                             if (islower(*cp)) { haslower = 1; break; }
14397
14398                         if (haslower) __mystrtolower(rslt);
14399                     }
14400                 }
14401         } else {
14402
14403             /* Now for some hacks to deal with backwards and forward */
14404             /* compatibilty */
14405             if (!decc_efs_charset) {
14406
14407                 /* 1. ODS-2 mode wants to do a syntax only translation */
14408                 rslt = int_rmsexpand(filespec, outbuf,
14409                                     NULL, 0, NULL, utf8_fl);
14410
14411             } else {
14412                 if (decc_filename_unix_report) {
14413                     char * dir_name;
14414                     char * vms_dir_name;
14415                     char * file_name;
14416
14417                     /* 2. ODS-5 / UNIX report mode should return a failure */
14418                     /*    if the parent directory also does not exist */
14419                     /*    Otherwise, get the real path for the parent */
14420                     /*    and add the child to it.
14421
14422                     /* basename / dirname only available for VMS 7.0+ */
14423                     /* So we may need to implement them as common routines */
14424
14425                     Newx(dir_name, VMS_MAXRSS + 1, char);
14426                     Newx(vms_dir_name, VMS_MAXRSS + 1, char);
14427                     dir_name[0] = '\0';
14428                     file_name = NULL;
14429
14430                     /* First try a VMS parse */
14431                     sts = vms_split_path
14432                           (filespec,
14433                            &v_spec,
14434                            &v_len,
14435                            &r_spec,
14436                            &r_len,
14437                            &d_spec,
14438                            &d_len,
14439                            &n_spec,
14440                            &n_len,
14441                            &e_spec,
14442                            &e_len,
14443                            &vs_spec,
14444                            &vs_len);
14445
14446                     if (sts == 0) {
14447                         /* This is VMS */
14448
14449                         int dir_len = v_len + r_len + d_len + n_len;
14450                         if (dir_len > 0) {
14451                            strncpy(dir_name, filespec, dir_len);
14452                            dir_name[dir_len] = '\0';
14453                            file_name = (char *)&filespec[dir_len + 1];
14454                         }
14455                     } else {
14456                         /* This must be UNIX */
14457                         char * tchar;
14458
14459                         tchar = strrchr(filespec, '/');
14460
14461                         if (tchar != NULL) {
14462                             int dir_len = tchar - filespec;
14463                             strncpy(dir_name, filespec, dir_len);
14464                             dir_name[dir_len] = '\0';
14465                             file_name = (char *) &filespec[dir_len + 1];
14466                         }
14467                     }
14468
14469                     /* Dir name is defaulted */
14470                     if (dir_name[0] == 0) {
14471                         dir_name[0] = '.';
14472                         dir_name[1] = '\0';
14473                     }
14474
14475                     /* Need realpath for the directory */
14476                     sts = vms_fid_to_name(vms_dir_name,
14477                                           VMS_MAXRSS + 1,
14478                                           dir_name, 0, NULL);
14479
14480                     if (sts == 0) {
14481                         /* Now need to pathify it.
14482                         char *tdir = int_pathify_dirspec(vms_dir_name,
14483                                                          outbuf);
14484
14485                         /* And now add the original filespec to it */
14486                         if (file_name != NULL) {
14487                             strcat(outbuf, file_name);
14488                         }
14489                         return outbuf;
14490                     }
14491                     Safefree(vms_dir_name);
14492                     Safefree(dir_name);
14493                 }
14494             }
14495         }
14496         Safefree(vms_spec);
14497     }
14498     return rslt;
14499 }
14500
14501 static char *
14502 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
14503                    int *utf8_fl)
14504 {
14505     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
14506     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
14507     int file_len;
14508
14509     /* Fall back to fid_to_name */
14510
14511     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
14512     if (sts != 0) {
14513         return NULL;
14514     }
14515     else {
14516
14517
14518         /* Now need to trim the version off */
14519         sts = vms_split_path
14520                   (outbuf,
14521                    &v_spec,
14522                    &v_len,
14523                    &r_spec,
14524                    &r_len,
14525                    &d_spec,
14526                    &d_len,
14527                    &n_spec,
14528                    &n_len,
14529                    &e_spec,
14530                    &e_len,
14531                    &vs_spec,
14532                    &vs_len);
14533
14534
14535         if (sts == 0) {
14536             int haslower = 0;
14537             const char *cp;
14538
14539             /* Trim off the version */
14540             int file_len = v_len + r_len + d_len + n_len + e_len;
14541             outbuf[file_len] = 0;
14542
14543             /* Downcase if input had any lower case letters and
14544              * case preservation is not in effect.
14545              */
14546             if (!decc_efs_case_preserve) {
14547                 for (cp = filespec; *cp; cp++)
14548                     if (islower(*cp)) { haslower = 1; break; }
14549
14550                 if (haslower) __mystrtolower(outbuf);
14551             }
14552         }
14553     }
14554     return outbuf;
14555 }
14556
14557
14558 /*}}}*/
14559 /* External entry points */
14560 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
14561 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
14562
14563 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
14564 { return do_vms_realname(filespec, outbuf, utf8_fl); }
14565
14566 /* case_tolerant */
14567
14568 /*{{{int do_vms_case_tolerant(void)*/
14569 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
14570  * controlled by a process setting.
14571  */
14572 int do_vms_case_tolerant(void)
14573 {
14574     return vms_process_case_tolerant;
14575 }
14576 /*}}}*/
14577 /* External entry points */
14578 #if __CRTL_VER >= 70301000 && !defined(__VAX)
14579 int Perl_vms_case_tolerant(void)
14580 { return do_vms_case_tolerant(); }
14581 #else
14582 int Perl_vms_case_tolerant(void)
14583 { return vms_process_case_tolerant; }
14584 #endif
14585
14586
14587  /* Start of DECC RTL Feature handling */
14588
14589 static int sys_trnlnm
14590    (const char * logname,
14591     char * value,
14592     int value_len)
14593 {
14594     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
14595     const unsigned long attr = LNM$M_CASE_BLIND;
14596     struct dsc$descriptor_s name_dsc;
14597     int status;
14598     unsigned short result;
14599     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
14600                                 {0, 0, 0, 0}};
14601
14602     name_dsc.dsc$w_length = strlen(logname);
14603     name_dsc.dsc$a_pointer = (char *)logname;
14604     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14605     name_dsc.dsc$b_class = DSC$K_CLASS_S;
14606
14607     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
14608
14609     if ($VMS_STATUS_SUCCESS(status)) {
14610
14611          /* Null terminate and return the string */
14612         /*--------------------------------------*/
14613         value[result] = 0;
14614     }
14615
14616     return status;
14617 }
14618
14619 static int sys_crelnm
14620    (const char * logname,
14621     const char * value)
14622 {
14623     int ret_val;
14624     const char * proc_table = "LNM$PROCESS_TABLE";
14625     struct dsc$descriptor_s proc_table_dsc;
14626     struct dsc$descriptor_s logname_dsc;
14627     struct itmlst_3 item_list[2];
14628
14629     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
14630     proc_table_dsc.dsc$w_length = strlen(proc_table);
14631     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14632     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
14633
14634     logname_dsc.dsc$a_pointer = (char *) logname;
14635     logname_dsc.dsc$w_length = strlen(logname);
14636     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14637     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
14638
14639     item_list[0].buflen = strlen(value);
14640     item_list[0].itmcode = LNM$_STRING;
14641     item_list[0].bufadr = (char *)value;
14642     item_list[0].retlen = NULL;
14643
14644     item_list[1].buflen = 0;
14645     item_list[1].itmcode = 0;
14646
14647     ret_val = sys$crelnm
14648                        (NULL,
14649                         (const struct dsc$descriptor_s *)&proc_table_dsc,
14650                         (const struct dsc$descriptor_s *)&logname_dsc,
14651                         NULL,
14652                         (const struct item_list_3 *) item_list);
14653
14654     return ret_val;
14655 }
14656
14657 /* C RTL Feature settings */
14658
14659 static int set_features
14660    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
14661     int (* cli_routine)(void),  /* Not documented */
14662     void *image_info)           /* Not documented */
14663 {
14664     int status;
14665     int s;
14666     char* str;
14667     char val_str[10];
14668 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
14669     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
14670     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
14671     unsigned long case_perm;
14672     unsigned long case_image;
14673 #endif
14674
14675     /* Allow an exception to bring Perl into the VMS debugger */
14676     vms_debug_on_exception = 0;
14677     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
14678     if ($VMS_STATUS_SUCCESS(status)) {
14679        val_str[0] = _toupper(val_str[0]);
14680        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14681          vms_debug_on_exception = 1;
14682        else
14683          vms_debug_on_exception = 0;
14684     }
14685
14686     /* Debug unix/vms file translation routines */
14687     vms_debug_fileify = 0;
14688     status = sys_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
14689     if ($VMS_STATUS_SUCCESS(status)) {
14690         val_str[0] = _toupper(val_str[0]);
14691         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14692             vms_debug_fileify = 1;
14693         else
14694             vms_debug_fileify = 0;
14695     }
14696
14697
14698     /* Historically PERL has been doing vmsify / stat differently than */
14699     /* the CRTL.  In particular, under some conditions the CRTL will   */
14700     /* remove some illegal characters like spaces from filenames       */
14701     /* resulting in some differences.  The stat()/lstat() wrapper has  */
14702     /* been reporting such file names as invalid and fails to stat them */
14703     /* fixing this bug so that stat()/lstat() accept these like the     */
14704     /* CRTL does will result in several tests failing.                  */
14705     /* This should really be fixed, but for now, set up a feature to    */
14706     /* enable it so that the impact can be studied.                     */
14707     vms_bug_stat_filename = 0;
14708     status = sys_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
14709     if ($VMS_STATUS_SUCCESS(status)) {
14710         val_str[0] = _toupper(val_str[0]);
14711         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14712             vms_bug_stat_filename = 1;
14713         else
14714             vms_bug_stat_filename = 0;
14715     }
14716
14717
14718     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
14719     vms_vtf7_filenames = 0;
14720     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
14721     if ($VMS_STATUS_SUCCESS(status)) {
14722        val_str[0] = _toupper(val_str[0]);
14723        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14724          vms_vtf7_filenames = 1;
14725        else
14726          vms_vtf7_filenames = 0;
14727     }
14728
14729     /* unlink all versions on unlink() or rename() */
14730     vms_unlink_all_versions = 0;
14731     status = sys_trnlnm
14732         ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
14733     if ($VMS_STATUS_SUCCESS(status)) {
14734        val_str[0] = _toupper(val_str[0]);
14735        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14736          vms_unlink_all_versions = 1;
14737        else
14738          vms_unlink_all_versions = 0;
14739     }
14740
14741     /* Dectect running under GNV Bash or other UNIX like shell */
14742 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14743     gnv_unix_shell = 0;
14744     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
14745     if ($VMS_STATUS_SUCCESS(status)) {
14746          gnv_unix_shell = 1;
14747          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
14748          set_feature_default("DECC$EFS_CHARSET", 1);
14749          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
14750          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
14751          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
14752          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
14753          vms_unlink_all_versions = 1;
14754          vms_posix_exit = 1;
14755     }
14756 #endif
14757
14758     /* hacks to see if known bugs are still present for testing */
14759
14760     /* PCP mode requires creating /dev/null special device file */
14761     decc_bug_devnull = 0;
14762     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14763     if ($VMS_STATUS_SUCCESS(status)) {
14764        val_str[0] = _toupper(val_str[0]);
14765        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14766           decc_bug_devnull = 1;
14767        else
14768           decc_bug_devnull = 0;
14769     }
14770
14771     /* UNIX directory names with no paths are broken in a lot of places */
14772     decc_dir_barename = 1;
14773     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
14774     if ($VMS_STATUS_SUCCESS(status)) {
14775       val_str[0] = _toupper(val_str[0]);
14776       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14777         decc_dir_barename = 1;
14778       else
14779         decc_dir_barename = 0;
14780     }
14781
14782 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14783     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14784     if (s >= 0) {
14785         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14786         if (decc_disable_to_vms_logname_translation < 0)
14787             decc_disable_to_vms_logname_translation = 0;
14788     }
14789
14790     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14791     if (s >= 0) {
14792         decc_efs_case_preserve = decc$feature_get_value(s, 1);
14793         if (decc_efs_case_preserve < 0)
14794             decc_efs_case_preserve = 0;
14795     }
14796
14797     s = decc$feature_get_index("DECC$EFS_CHARSET");
14798     decc_efs_charset_index = s;
14799     if (s >= 0) {
14800         decc_efs_charset = decc$feature_get_value(s, 1);
14801         if (decc_efs_charset < 0)
14802             decc_efs_charset = 0;
14803     }
14804
14805     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14806     if (s >= 0) {
14807         decc_filename_unix_report = decc$feature_get_value(s, 1);
14808         if (decc_filename_unix_report > 0) {
14809             decc_filename_unix_report = 1;
14810             vms_posix_exit = 1;
14811         }
14812         else
14813             decc_filename_unix_report = 0;
14814     }
14815
14816     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14817     if (s >= 0) {
14818         decc_filename_unix_only = decc$feature_get_value(s, 1);
14819         if (decc_filename_unix_only > 0) {
14820             decc_filename_unix_only = 1;
14821         }
14822         else {
14823             decc_filename_unix_only = 0;
14824         }
14825     }
14826
14827     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14828     if (s >= 0) {
14829         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14830         if (decc_filename_unix_no_version < 0)
14831             decc_filename_unix_no_version = 0;
14832     }
14833
14834     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14835     if (s >= 0) {
14836         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14837         if (decc_readdir_dropdotnotype < 0)
14838             decc_readdir_dropdotnotype = 0;
14839     }
14840
14841 #if __CRTL_VER >= 80200000
14842     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14843     if (s >= 0) {
14844         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14845         if (decc_posix_compliant_pathnames < 0)
14846             decc_posix_compliant_pathnames = 0;
14847         if (decc_posix_compliant_pathnames > 4)
14848             decc_posix_compliant_pathnames = 0;
14849     }
14850
14851 #endif
14852 #else
14853     status = sys_trnlnm
14854         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
14855     if ($VMS_STATUS_SUCCESS(status)) {
14856         val_str[0] = _toupper(val_str[0]);
14857         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14858            decc_disable_to_vms_logname_translation = 1;
14859         }
14860     }
14861
14862 #ifndef __VAX
14863     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
14864     if ($VMS_STATUS_SUCCESS(status)) {
14865         val_str[0] = _toupper(val_str[0]);
14866         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14867            decc_efs_case_preserve = 1;
14868         }
14869     }
14870 #endif
14871
14872     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14873     if ($VMS_STATUS_SUCCESS(status)) {
14874         val_str[0] = _toupper(val_str[0]);
14875         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14876            decc_filename_unix_report = 1;
14877         }
14878     }
14879     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14880     if ($VMS_STATUS_SUCCESS(status)) {
14881         val_str[0] = _toupper(val_str[0]);
14882         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14883            decc_filename_unix_only = 1;
14884            decc_filename_unix_report = 1;
14885         }
14886     }
14887     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14888     if ($VMS_STATUS_SUCCESS(status)) {
14889         val_str[0] = _toupper(val_str[0]);
14890         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14891            decc_filename_unix_no_version = 1;
14892         }
14893     }
14894     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
14895     if ($VMS_STATUS_SUCCESS(status)) {
14896         val_str[0] = _toupper(val_str[0]);
14897         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14898            decc_readdir_dropdotnotype = 1;
14899         }
14900     }
14901 #endif
14902
14903 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
14904
14905      /* Report true case tolerance */
14906     /*----------------------------*/
14907     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14908     if (!$VMS_STATUS_SUCCESS(status))
14909         case_perm = PPROP$K_CASE_BLIND;
14910     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14911     if (!$VMS_STATUS_SUCCESS(status))
14912         case_image = PPROP$K_CASE_BLIND;
14913     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14914         (case_image == PPROP$K_CASE_SENSITIVE))
14915         vms_process_case_tolerant = 0;
14916
14917 #endif
14918
14919     /* USE POSIX/DCL Exit codes - Recommended, but needs to default to  */
14920     /* for strict backward compatibilty */
14921     status = sys_trnlnm
14922         ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14923     if ($VMS_STATUS_SUCCESS(status)) {
14924        val_str[0] = _toupper(val_str[0]);
14925        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14926          vms_posix_exit = 1;
14927        else
14928          vms_posix_exit = 0;
14929     }
14930
14931
14932     /* CRTL can be initialized past this point, but not before. */
14933 /*    DECC$CRTL_INIT(); */
14934
14935     return SS$_NORMAL;
14936 }
14937
14938 #ifdef __DECC
14939 #pragma nostandard
14940 #pragma extern_model save
14941 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
14942         const __align (LONGWORD) int spare[8] = {0};
14943
14944 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
14945 #if __DECC_VER >= 60560002
14946 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
14947 #else
14948 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
14949 #endif
14950 #endif /* __DECC */
14951
14952 const long vms_cc_features = (const long)set_features;
14953
14954 /*
14955 ** Force a reference to LIB$INITIALIZE to ensure it
14956 ** exists in the image.
14957 */
14958 int lib$initialize(void);
14959 #ifdef __DECC
14960 #pragma extern_model strict_refdef
14961 #endif
14962     int lib_init_ref = (int) lib$initialize;
14963
14964 #ifdef __DECC
14965 #pragma extern_model restore
14966 #pragma standard
14967 #endif
14968
14969 /*  End of vms.c */