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 #define PERL_BUFSIZ        512
2889
2890
2891 static void
2892 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2893 {
2894   unsigned long int mbxbufsiz;
2895   static unsigned long int syssize = 0;
2896   unsigned long int dviitm = DVI$_DEVNAM;
2897   char csize[LNM$C_NAMLENGTH+1];
2898   int sts;
2899
2900   if (!syssize) {
2901     unsigned long syiitm = SYI$_MAXBUF;
2902     /*
2903      * Get the SYSGEN parameter MAXBUF
2904      *
2905      * If the logical 'PERL_MBX_SIZE' is defined
2906      * use the value of the logical instead of PERL_BUFSIZ, but
2907      * keep the size between 128 and MAXBUF.
2908      *
2909      */
2910     _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2911   }
2912
2913   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2914       mbxbufsiz = atoi(csize);
2915   } else {
2916       mbxbufsiz = PERL_BUFSIZ;
2917   }
2918   if (mbxbufsiz < 128) mbxbufsiz = 128;
2919   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2920
2921   _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2922
2923   sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2924   _ckvmssts_noperl(sts);
2925   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2926
2927 }  /* end of create_mbx() */
2928
2929
2930 /*{{{  my_popen and my_pclose*/
2931
2932 typedef struct _iosb           IOSB;
2933 typedef struct _iosb*         pIOSB;
2934 typedef struct _pipe           Pipe;
2935 typedef struct _pipe*         pPipe;
2936 typedef struct pipe_details    Info;
2937 typedef struct pipe_details*  pInfo;
2938 typedef struct _srqp            RQE;
2939 typedef struct _srqp*          pRQE;
2940 typedef struct _tochildbuf      CBuf;
2941 typedef struct _tochildbuf*    pCBuf;
2942
2943 struct _iosb {
2944     unsigned short status;
2945     unsigned short count;
2946     unsigned long  dvispec;
2947 };
2948
2949 #pragma member_alignment save
2950 #pragma nomember_alignment quadword
2951 struct _srqp {          /* VMS self-relative queue entry */
2952     unsigned long qptr[2];
2953 };
2954 #pragma member_alignment restore
2955 static RQE  RQE_ZERO = {0,0};
2956
2957 struct _tochildbuf {
2958     RQE             q;
2959     int             eof;
2960     unsigned short  size;
2961     char            *buf;
2962 };
2963
2964 struct _pipe {
2965     RQE            free;
2966     RQE            wait;
2967     int            fd_out;
2968     unsigned short chan_in;
2969     unsigned short chan_out;
2970     char          *buf;
2971     unsigned int   bufsize;
2972     IOSB           iosb;
2973     IOSB           iosb2;
2974     int           *pipe_done;
2975     int            retry;
2976     int            type;
2977     int            shut_on_empty;
2978     int            need_wake;
2979     pPipe         *home;
2980     pInfo          info;
2981     pCBuf          curr;
2982     pCBuf          curr2;
2983 #if defined(PERL_IMPLICIT_CONTEXT)
2984     void            *thx;           /* Either a thread or an interpreter */
2985                                     /* pointer, depending on how we're built */
2986 #endif
2987 };
2988
2989
2990 struct pipe_details
2991 {
2992     pInfo           next;
2993     PerlIO *fp;  /* file pointer to pipe mailbox */
2994     int useFILE; /* using stdio, not perlio */
2995     int pid;   /* PID of subprocess */
2996     int mode;  /* == 'r' if pipe open for reading */
2997     int done;  /* subprocess has completed */
2998     int waiting; /* waiting for completion/closure */
2999     int             closing;        /* my_pclose is closing this pipe */
3000     unsigned long   completion;     /* termination status of subprocess */
3001     pPipe           in;             /* pipe in to sub */
3002     pPipe           out;            /* pipe out of sub */
3003     pPipe           err;            /* pipe of sub's sys$error */
3004     int             in_done;        /* true when in pipe finished */
3005     int             out_done;
3006     int             err_done;
3007     unsigned short  xchan;          /* channel to debug xterm */
3008     unsigned short  xchan_valid;    /* channel is assigned */
3009 };
3010
3011 struct exit_control_block
3012 {
3013     struct exit_control_block *flink;
3014     unsigned long int   (*exit_routine)();
3015     unsigned long int arg_count;
3016     unsigned long int *status_address;
3017     unsigned long int exit_status;
3018 };
3019
3020 typedef struct _closed_pipes    Xpipe;
3021 typedef struct _closed_pipes*  pXpipe;
3022
3023 struct _closed_pipes {
3024     int             pid;            /* PID of subprocess */
3025     unsigned long   completion;     /* termination status of subprocess */
3026 };
3027 #define NKEEPCLOSED 50
3028 static Xpipe closed_list[NKEEPCLOSED];
3029 static int   closed_index = 0;
3030 static int   closed_num = 0;
3031
3032 #define RETRY_DELAY     "0 ::0.20"
3033 #define MAX_RETRY              50
3034
3035 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
3036 static unsigned long mypid;
3037 static unsigned long delaytime[2];
3038
3039 static pInfo open_pipes = NULL;
3040 static $DESCRIPTOR(nl_desc, "NL:");
3041
3042 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
3043
3044
3045
3046 static unsigned long int
3047 pipe_exit_routine()
3048 {
3049     pInfo info;
3050     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
3051     int sts, did_stuff, need_eof, j;
3052
3053    /*
3054     * Flush any pending i/o, but since we are in process run-down, be
3055     * careful about referencing PerlIO structures that may already have
3056     * been deallocated.  We may not even have an interpreter anymore.
3057     */
3058     info = open_pipes;
3059     while (info) {
3060         if (info->fp) {
3061 #if defined(PERL_IMPLICIT_CONTEXT)
3062            /* We need to use the Perl context of the thread that created */
3063            /* the pipe. */
3064            pTHX;
3065            if (info->err)
3066                aTHX = info->err->thx;
3067            else if (info->out)
3068                aTHX = info->out->thx;
3069            else if (info->in)
3070                aTHX = info->in->thx;
3071 #endif
3072            if (!info->useFILE
3073 #if defined(USE_ITHREADS)
3074              && my_perl
3075 #endif
3076              && PL_perlio_fd_refcnt)
3077                PerlIO_flush(info->fp);
3078            else
3079                fflush((FILE *)info->fp);
3080         }
3081         info = info->next;
3082     }
3083
3084     /*
3085      next we try sending an EOF...ignore if doesn't work, make sure we
3086      don't hang
3087     */
3088     did_stuff = 0;
3089     info = open_pipes;
3090
3091     while (info) {
3092       int need_eof;
3093       _ckvmssts_noperl(sys$setast(0));
3094       if (info->in && !info->in->shut_on_empty) {
3095         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3096                                  0, 0, 0, 0, 0, 0));
3097         info->waiting = 1;
3098         did_stuff = 1;
3099       }
3100       _ckvmssts_noperl(sys$setast(1));
3101       info = info->next;
3102     }
3103
3104     /* wait for EOF to have effect, up to ~ 30 sec [default] */
3105
3106     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3107         int nwait = 0;
3108
3109         info = open_pipes;
3110         while (info) {
3111           _ckvmssts_noperl(sys$setast(0));
3112           if (info->waiting && info->done)
3113                 info->waiting = 0;
3114           nwait += info->waiting;
3115           _ckvmssts_noperl(sys$setast(1));
3116           info = info->next;
3117         }
3118         if (!nwait) break;
3119         sleep(1);
3120     }
3121
3122     did_stuff = 0;
3123     info = open_pipes;
3124     while (info) {
3125       _ckvmssts_noperl(sys$setast(0));
3126       if (!info->done) { /* Tap them gently on the shoulder . . .*/
3127         sts = sys$forcex(&info->pid,0,&abort);
3128         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3129         did_stuff = 1;
3130       }
3131       _ckvmssts_noperl(sys$setast(1));
3132       info = info->next;
3133     }
3134
3135     /* again, wait for effect */
3136
3137     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3138         int nwait = 0;
3139
3140         info = open_pipes;
3141         while (info) {
3142           _ckvmssts_noperl(sys$setast(0));
3143           if (info->waiting && info->done)
3144                 info->waiting = 0;
3145           nwait += info->waiting;
3146           _ckvmssts_noperl(sys$setast(1));
3147           info = info->next;
3148         }
3149         if (!nwait) break;
3150         sleep(1);
3151     }
3152
3153     info = open_pipes;
3154     while (info) {
3155       _ckvmssts_noperl(sys$setast(0));
3156       if (!info->done) {  /* We tried to be nice . . . */
3157         sts = sys$delprc(&info->pid,0);
3158         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3159         info->done = 1;  /* sys$delprc is as done as we're going to get. */
3160       }
3161       _ckvmssts_noperl(sys$setast(1));
3162       info = info->next;
3163     }
3164
3165     while(open_pipes) {
3166
3167 #if defined(PERL_IMPLICIT_CONTEXT)
3168       /* We need to use the Perl context of the thread that created */
3169       /* the pipe. */
3170       pTHX;
3171       if (open_pipes->err)
3172           aTHX = open_pipes->err->thx;
3173       else if (open_pipes->out)
3174           aTHX = open_pipes->out->thx;
3175       else if (open_pipes->in)
3176           aTHX = open_pipes->in->thx;
3177 #endif
3178       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3179       else if (!(sts & 1)) retsts = sts;
3180     }
3181     return retsts;
3182 }
3183
3184 static struct exit_control_block pipe_exitblock =
3185        {(struct exit_control_block *) 0,
3186         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3187
3188 static void pipe_mbxtofd_ast(pPipe p);
3189 static void pipe_tochild1_ast(pPipe p);
3190 static void pipe_tochild2_ast(pPipe p);
3191
3192 static void
3193 popen_completion_ast(pInfo info)
3194 {
3195   pInfo i = open_pipes;
3196   int iss;
3197   int sts;
3198   pXpipe x;
3199
3200   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3201   closed_list[closed_index].pid = info->pid;
3202   closed_list[closed_index].completion = info->completion;
3203   closed_index++;
3204   if (closed_index == NKEEPCLOSED)
3205     closed_index = 0;
3206   closed_num++;
3207
3208   while (i) {
3209     if (i == info) break;
3210     i = i->next;
3211   }
3212   if (!i) return;       /* unlinked, probably freed too */
3213
3214   info->done = TRUE;
3215
3216 /*
3217     Writing to subprocess ...
3218             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3219
3220             chan_out may be waiting for "done" flag, or hung waiting
3221             for i/o completion to child...cancel the i/o.  This will
3222             put it into "snarf mode" (done but no EOF yet) that discards
3223             input.
3224
3225     Output from subprocess (stdout, stderr) needs to be flushed and
3226     shut down.   We try sending an EOF, but if the mbx is full the pipe
3227     routine should still catch the "shut_on_empty" flag, telling it to
3228     use immediate-style reads so that "mbx empty" -> EOF.
3229
3230
3231 */
3232   if (info->in && !info->in_done) {               /* only for mode=w */
3233         if (info->in->shut_on_empty && info->in->need_wake) {
3234             info->in->need_wake = FALSE;
3235             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3236         } else {
3237             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3238         }
3239   }
3240
3241   if (info->out && !info->out_done) {             /* were we also piping output? */
3242       info->out->shut_on_empty = TRUE;
3243       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3244       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3245       _ckvmssts_noperl(iss);
3246   }
3247
3248   if (info->err && !info->err_done) {        /* we were piping stderr */
3249         info->err->shut_on_empty = TRUE;
3250         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3251         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3252         _ckvmssts_noperl(iss);
3253   }
3254   _ckvmssts_noperl(sys$setef(pipe_ef));
3255
3256 }
3257
3258 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3259 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3260
3261 /*
3262     we actually differ from vmstrnenv since we use this to
3263     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3264     are pointing to the same thing
3265 */
3266
3267 static unsigned short
3268 popen_translate(pTHX_ char *logical, char *result)
3269 {
3270     int iss;
3271     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3272     $DESCRIPTOR(d_log,"");
3273     struct _il3 {
3274         unsigned short length;
3275         unsigned short code;
3276         char *         buffer_addr;
3277         unsigned short *retlenaddr;
3278     } itmlst[2];
3279     unsigned short l, ifi;
3280
3281     d_log.dsc$a_pointer = logical;
3282     d_log.dsc$w_length  = strlen(logical);
3283
3284     itmlst[0].code = LNM$_STRING;
3285     itmlst[0].length = 255;
3286     itmlst[0].buffer_addr = result;
3287     itmlst[0].retlenaddr = &l;
3288
3289     itmlst[1].code = 0;
3290     itmlst[1].length = 0;
3291     itmlst[1].buffer_addr = 0;
3292     itmlst[1].retlenaddr = 0;
3293
3294     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3295     if (iss == SS$_NOLOGNAM) {
3296         iss = SS$_NORMAL;
3297         l = 0;
3298     }
3299     if (!(iss&1)) lib$signal(iss);
3300     result[l] = '\0';
3301 /*
3302     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
3303     strip it off and return the ifi, if any
3304 */
3305     ifi  = 0;
3306     if (result[0] == 0x1b && result[1] == 0x00) {
3307         memmove(&ifi,result+2,2);
3308         strcpy(result,result+4);
3309     }
3310     return ifi;     /* this is the RMS internal file id */
3311 }
3312
3313 static void pipe_infromchild_ast(pPipe p);
3314
3315 /*
3316     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3317     inside an AST routine without worrying about reentrancy and which Perl
3318     memory allocator is being used.
3319
3320     We read data and queue up the buffers, then spit them out one at a
3321     time to the output mailbox when the output mailbox is ready for one.
3322
3323 */
3324 #define INITIAL_TOCHILDQUEUE  2
3325
3326 static pPipe
3327 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3328 {
3329     pPipe p;
3330     pCBuf b;
3331     char mbx1[64], mbx2[64];
3332     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3333                                       DSC$K_CLASS_S, mbx1},
3334                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3335                                       DSC$K_CLASS_S, mbx2};
3336     unsigned int dviitm = DVI$_DEVBUFSIZ;
3337     int j, n;
3338
3339     n = sizeof(Pipe);
3340     _ckvmssts_noperl(lib$get_vm(&n, &p));
3341
3342     create_mbx(&p->chan_in , &d_mbx1);
3343     create_mbx(&p->chan_out, &d_mbx2);
3344     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3345
3346     p->buf           = 0;
3347     p->shut_on_empty = FALSE;
3348     p->need_wake     = FALSE;
3349     p->type          = 0;
3350     p->retry         = 0;
3351     p->iosb.status   = SS$_NORMAL;
3352     p->iosb2.status  = SS$_NORMAL;
3353     p->free          = RQE_ZERO;
3354     p->wait          = RQE_ZERO;
3355     p->curr          = 0;
3356     p->curr2         = 0;
3357     p->info          = 0;
3358 #ifdef PERL_IMPLICIT_CONTEXT
3359     p->thx           = aTHX;
3360 #endif
3361
3362     n = sizeof(CBuf) + p->bufsize;
3363
3364     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3365         _ckvmssts_noperl(lib$get_vm(&n, &b));
3366         b->buf = (char *) b + sizeof(CBuf);
3367         _ckvmssts_noperl(lib$insqhi(b, &p->free));
3368     }
3369
3370     pipe_tochild2_ast(p);
3371     pipe_tochild1_ast(p);
3372     strcpy(wmbx, mbx1);
3373     strcpy(rmbx, mbx2);
3374     return p;
3375 }
3376
3377 /*  reads the MBX Perl is writing, and queues */
3378
3379 static void
3380 pipe_tochild1_ast(pPipe p)
3381 {
3382     pCBuf b = p->curr;
3383     int iss = p->iosb.status;
3384     int eof = (iss == SS$_ENDOFFILE);
3385     int sts;
3386 #ifdef PERL_IMPLICIT_CONTEXT
3387     pTHX = p->thx;
3388 #endif
3389
3390     if (p->retry) {
3391         if (eof) {
3392             p->shut_on_empty = TRUE;
3393             b->eof     = TRUE;
3394             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3395         } else  {
3396             _ckvmssts_noperl(iss);
3397         }
3398
3399         b->eof  = eof;
3400         b->size = p->iosb.count;
3401         _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3402         if (p->need_wake) {
3403             p->need_wake = FALSE;
3404             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3405         }
3406     } else {
3407         p->retry = 1;   /* initial call */
3408     }
3409
3410     if (eof) {                  /* flush the free queue, return when done */
3411         int n = sizeof(CBuf) + p->bufsize;
3412         while (1) {
3413             iss = lib$remqti(&p->free, &b);
3414             if (iss == LIB$_QUEWASEMP) return;
3415             _ckvmssts_noperl(iss);
3416             _ckvmssts_noperl(lib$free_vm(&n, &b));
3417         }
3418     }
3419
3420     iss = lib$remqti(&p->free, &b);
3421     if (iss == LIB$_QUEWASEMP) {
3422         int n = sizeof(CBuf) + p->bufsize;
3423         _ckvmssts_noperl(lib$get_vm(&n, &b));
3424         b->buf = (char *) b + sizeof(CBuf);
3425     } else {
3426        _ckvmssts_noperl(iss);
3427     }
3428
3429     p->curr = b;
3430     iss = sys$qio(0,p->chan_in,
3431              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3432              &p->iosb,
3433              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3434     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3435     _ckvmssts_noperl(iss);
3436 }
3437
3438
3439 /* writes queued buffers to output, waits for each to complete before
3440    doing the next */
3441
3442 static void
3443 pipe_tochild2_ast(pPipe p)
3444 {
3445     pCBuf b = p->curr2;
3446     int iss = p->iosb2.status;
3447     int n = sizeof(CBuf) + p->bufsize;
3448     int done = (p->info && p->info->done) ||
3449               iss == SS$_CANCEL || iss == SS$_ABORT;
3450 #if defined(PERL_IMPLICIT_CONTEXT)
3451     pTHX = p->thx;
3452 #endif
3453
3454     do {
3455         if (p->type) {         /* type=1 has old buffer, dispose */
3456             if (p->shut_on_empty) {
3457                 _ckvmssts_noperl(lib$free_vm(&n, &b));
3458             } else {
3459                 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3460             }
3461             p->type = 0;
3462         }
3463
3464         iss = lib$remqti(&p->wait, &b);
3465         if (iss == LIB$_QUEWASEMP) {
3466             if (p->shut_on_empty) {
3467                 if (done) {
3468                     _ckvmssts_noperl(sys$dassgn(p->chan_out));
3469                     *p->pipe_done = TRUE;
3470                     _ckvmssts_noperl(sys$setef(pipe_ef));
3471                 } else {
3472                     _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3473                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3474                 }
3475                 return;
3476             }
3477             p->need_wake = TRUE;
3478             return;
3479         }
3480         _ckvmssts_noperl(iss);
3481         p->type = 1;
3482     } while (done);
3483
3484
3485     p->curr2 = b;
3486     if (b->eof) {
3487         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3488             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3489     } else {
3490         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3491             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3492     }
3493
3494     return;
3495
3496 }
3497
3498
3499 static pPipe
3500 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3501 {
3502     pPipe p;
3503     char mbx1[64], mbx2[64];
3504     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3505                                       DSC$K_CLASS_S, mbx1},
3506                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3507                                       DSC$K_CLASS_S, mbx2};
3508     unsigned int dviitm = DVI$_DEVBUFSIZ;
3509
3510     int n = sizeof(Pipe);
3511     _ckvmssts_noperl(lib$get_vm(&n, &p));
3512     create_mbx(&p->chan_in , &d_mbx1);
3513     create_mbx(&p->chan_out, &d_mbx2);
3514
3515     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3516     n = p->bufsize * sizeof(char);
3517     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3518     p->shut_on_empty = FALSE;
3519     p->info   = 0;
3520     p->type   = 0;
3521     p->iosb.status = SS$_NORMAL;
3522 #if defined(PERL_IMPLICIT_CONTEXT)
3523     p->thx = aTHX;
3524 #endif
3525     pipe_infromchild_ast(p);
3526
3527     strcpy(wmbx, mbx1);
3528     strcpy(rmbx, mbx2);
3529     return p;
3530 }
3531
3532 static void
3533 pipe_infromchild_ast(pPipe p)
3534 {
3535     int iss = p->iosb.status;
3536     int eof = (iss == SS$_ENDOFFILE);
3537     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3538     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3539 #if defined(PERL_IMPLICIT_CONTEXT)
3540     pTHX = p->thx;
3541 #endif
3542
3543     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3544         _ckvmssts_noperl(sys$dassgn(p->chan_out));
3545         p->chan_out = 0;
3546     }
3547
3548     /* read completed:
3549             input shutdown if EOF from self (done or shut_on_empty)
3550             output shutdown if closing flag set (my_pclose)
3551             send data/eof from child or eof from self
3552             otherwise, re-read (snarf of data from child)
3553     */
3554
3555     if (p->type == 1) {
3556         p->type = 0;
3557         if (myeof && p->chan_in) {                  /* input shutdown */
3558             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3559             p->chan_in = 0;
3560         }
3561
3562         if (p->chan_out) {
3563             if (myeof || kideof) {      /* pass EOF to parent */
3564                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3565                                          pipe_infromchild_ast, p,
3566                                          0, 0, 0, 0, 0, 0));
3567                 return;
3568             } else if (eof) {       /* eat EOF --- fall through to read*/
3569
3570             } else {                /* transmit data */
3571                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3572                                          pipe_infromchild_ast,p,
3573                                          p->buf, p->iosb.count, 0, 0, 0, 0));
3574                 return;
3575             }
3576         }
3577     }
3578
3579     /*  everything shut? flag as done */
3580
3581     if (!p->chan_in && !p->chan_out) {
3582         *p->pipe_done = TRUE;
3583         _ckvmssts_noperl(sys$setef(pipe_ef));
3584         return;
3585     }
3586
3587     /* write completed (or read, if snarfing from child)
3588             if still have input active,
3589                queue read...immediate mode if shut_on_empty so we get EOF if empty
3590             otherwise,
3591                check if Perl reading, generate EOFs as needed
3592     */
3593
3594     if (p->type == 0) {
3595         p->type = 1;
3596         if (p->chan_in) {
3597             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3598                           pipe_infromchild_ast,p,
3599                           p->buf, p->bufsize, 0, 0, 0, 0);
3600             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3601             _ckvmssts_noperl(iss);
3602         } else {           /* send EOFs for extra reads */
3603             p->iosb.status = SS$_ENDOFFILE;
3604             p->iosb.dvispec = 0;
3605             _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3606                                      0, 0, 0,
3607                                      pipe_infromchild_ast, p, 0, 0, 0, 0));
3608         }
3609     }
3610 }
3611
3612 static pPipe
3613 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3614 {
3615     pPipe p;
3616     char mbx[64];
3617     unsigned long dviitm = DVI$_DEVBUFSIZ;
3618     struct stat s;
3619     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3620                                       DSC$K_CLASS_S, mbx};
3621     int n = sizeof(Pipe);
3622
3623     /* things like terminals and mbx's don't need this filter */
3624     if (fd && fstat(fd,&s) == 0) {
3625         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3626         char device[65];
3627         unsigned short dev_len;
3628         struct dsc$descriptor_s d_dev;
3629         char * cptr;
3630         struct item_list_3 items[3];
3631         int status;
3632         unsigned short dvi_iosb[4];
3633
3634         cptr = getname(fd, out, 1);
3635         if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3636         d_dev.dsc$a_pointer = out;
3637         d_dev.dsc$w_length = strlen(out);
3638         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3639         d_dev.dsc$b_class = DSC$K_CLASS_S;
3640
3641         items[0].len = 4;
3642         items[0].code = DVI$_DEVCHAR;
3643         items[0].bufadr = &devchar;
3644         items[0].retadr = NULL;
3645         items[1].len = 64;
3646         items[1].code = DVI$_FULLDEVNAM;
3647         items[1].bufadr = device;
3648         items[1].retadr = &dev_len;
3649         items[2].len = 0;
3650         items[2].code = 0;
3651
3652         status = sys$getdviw
3653                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3654         _ckvmssts_noperl(status);
3655         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3656             device[dev_len] = 0;
3657
3658             if (!(devchar & DEV$M_DIR)) {
3659                 strcpy(out, device);
3660                 return 0;
3661             }
3662         }
3663     }
3664
3665     _ckvmssts_noperl(lib$get_vm(&n, &p));
3666     p->fd_out = dup(fd);
3667     create_mbx(&p->chan_in, &d_mbx);
3668     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3669     n = (p->bufsize+1) * sizeof(char);
3670     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3671     p->shut_on_empty = FALSE;
3672     p->retry = 0;
3673     p->info  = 0;
3674     strcpy(out, mbx);
3675
3676     _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3677                              pipe_mbxtofd_ast, p,
3678                              p->buf, p->bufsize, 0, 0, 0, 0));
3679
3680     return p;
3681 }
3682
3683 static void
3684 pipe_mbxtofd_ast(pPipe p)
3685 {
3686     int iss = p->iosb.status;
3687     int done = p->info->done;
3688     int iss2;
3689     int eof = (iss == SS$_ENDOFFILE);
3690     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3691     int err = !(iss&1) && !eof;
3692 #if defined(PERL_IMPLICIT_CONTEXT)
3693     pTHX = p->thx;
3694 #endif
3695
3696     if (done && myeof) {               /* end piping */
3697         close(p->fd_out);
3698         sys$dassgn(p->chan_in);
3699         *p->pipe_done = TRUE;
3700         _ckvmssts_noperl(sys$setef(pipe_ef));
3701         return;
3702     }
3703
3704     if (!err && !eof) {             /* good data to send to file */
3705         p->buf[p->iosb.count] = '\n';
3706         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3707         if (iss2 < 0) {
3708             p->retry++;
3709             if (p->retry < MAX_RETRY) {
3710                 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3711                 return;
3712             }
3713         }
3714         p->retry = 0;
3715     } else if (err) {
3716         _ckvmssts_noperl(iss);
3717     }
3718
3719
3720     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3721           pipe_mbxtofd_ast, p,
3722           p->buf, p->bufsize, 0, 0, 0, 0);
3723     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3724     _ckvmssts_noperl(iss);
3725 }
3726
3727
3728 typedef struct _pipeloc     PLOC;
3729 typedef struct _pipeloc*   pPLOC;
3730
3731 struct _pipeloc {
3732     pPLOC   next;
3733     char    dir[NAM$C_MAXRSS+1];
3734 };
3735 static pPLOC  head_PLOC = 0;
3736
3737 void
3738 free_pipelocs(pTHX_ void *head)
3739 {
3740     pPLOC p, pnext;
3741     pPLOC *pHead = (pPLOC *)head;
3742
3743     p = *pHead;
3744     while (p) {
3745         pnext = p->next;
3746         PerlMem_free(p);
3747         p = pnext;
3748     }
3749     *pHead = 0;
3750 }
3751
3752 static void
3753 store_pipelocs(pTHX)
3754 {
3755     int    i;
3756     pPLOC  p;
3757     AV    *av = 0;
3758     SV    *dirsv;
3759     GV    *gv;
3760     char  *dir, *x;
3761     char  *unixdir;
3762     char  temp[NAM$C_MAXRSS+1];
3763     STRLEN n_a;
3764
3765     if (head_PLOC)
3766         free_pipelocs(aTHX_ &head_PLOC);
3767
3768 /*  the . directory from @INC comes last */
3769
3770     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3771     if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3772     p->next = head_PLOC;
3773     head_PLOC = p;
3774     strcpy(p->dir,"./");
3775
3776 /*  get the directory from $^X */
3777
3778     unixdir = PerlMem_malloc(VMS_MAXRSS);
3779     if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3780
3781 #ifdef PERL_IMPLICIT_CONTEXT
3782     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3783 #else
3784     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3785 #endif
3786         strcpy(temp, PL_origargv[0]);
3787         x = strrchr(temp,']');
3788         if (x == NULL) {
3789         x = strrchr(temp,'>');
3790           if (x == NULL) {
3791             /* It could be a UNIX path */
3792             x = strrchr(temp,'/');
3793           }
3794         }
3795         if (x)
3796           x[1] = '\0';
3797         else {
3798           /* Got a bare name, so use default directory */
3799           temp[0] = '.';
3800           temp[1] = '\0';
3801         }
3802
3803         if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3804             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3805             if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3806             p->next = head_PLOC;
3807             head_PLOC = p;
3808             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3809             p->dir[NAM$C_MAXRSS] = '\0';
3810         }
3811     }
3812
3813 /*  reverse order of @INC entries, skip "." since entered above */
3814
3815 #ifdef PERL_IMPLICIT_CONTEXT
3816     if (aTHX)
3817 #endif
3818     if (PL_incgv) av = GvAVn(PL_incgv);
3819
3820     for (i = 0; av && i <= AvFILL(av); i++) {
3821         dirsv = *av_fetch(av,i,TRUE);
3822
3823         if (SvROK(dirsv)) continue;
3824         dir = SvPVx(dirsv,n_a);
3825         if (strcmp(dir,".") == 0) continue;
3826         if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3827             continue;
3828
3829         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3830         p->next = head_PLOC;
3831         head_PLOC = p;
3832         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3833         p->dir[NAM$C_MAXRSS] = '\0';
3834     }
3835
3836 /* most likely spot (ARCHLIB) put first in the list */
3837
3838 #ifdef ARCHLIB_EXP
3839     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3840         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3841         if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3842         p->next = head_PLOC;
3843         head_PLOC = p;
3844         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3845         p->dir[NAM$C_MAXRSS] = '\0';
3846     }
3847 #endif
3848     PerlMem_free(unixdir);
3849 }
3850
3851 static I32
3852 Perl_cando_by_name_int
3853    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3854 #if !defined(PERL_IMPLICIT_CONTEXT)
3855 #define cando_by_name_int               Perl_cando_by_name_int
3856 #else
3857 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3858 #endif
3859
3860 static char *
3861 find_vmspipe(pTHX)
3862 {
3863     static int   vmspipe_file_status = 0;
3864     static char  vmspipe_file[NAM$C_MAXRSS+1];
3865
3866     /* already found? Check and use ... need read+execute permission */
3867
3868     if (vmspipe_file_status == 1) {
3869         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3870          && cando_by_name_int
3871            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3872             return vmspipe_file;
3873         }
3874         vmspipe_file_status = 0;
3875     }
3876
3877     /* scan through stored @INC, $^X */
3878
3879     if (vmspipe_file_status == 0) {
3880         char file[NAM$C_MAXRSS+1];
3881         pPLOC  p = head_PLOC;
3882
3883         while (p) {
3884             char * exp_res;
3885             int dirlen;
3886             strcpy(file, p->dir);
3887             dirlen = strlen(file);
3888             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3889             file[NAM$C_MAXRSS] = '\0';
3890             p = p->next;
3891
3892             exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3893             if (!exp_res) continue;
3894
3895             if (cando_by_name_int
3896                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3897              && cando_by_name_int
3898                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3899                 vmspipe_file_status = 1;
3900                 return vmspipe_file;
3901             }
3902         }
3903         vmspipe_file_status = -1;   /* failed, use tempfiles */
3904     }
3905
3906     return 0;
3907 }
3908
3909 static FILE *
3910 vmspipe_tempfile(pTHX)
3911 {
3912     char file[NAM$C_MAXRSS+1];
3913     FILE *fp;
3914     static int index = 0;
3915     Stat_t s0, s1;
3916     int cmp_result;
3917
3918     /* create a tempfile */
3919
3920     /* we can't go from   W, shr=get to  R, shr=get without
3921        an intermediate vulnerable state, so don't bother trying...
3922
3923        and lib$spawn doesn't shr=put, so have to close the write
3924
3925        So... match up the creation date/time and the FID to
3926        make sure we're dealing with the same file
3927
3928     */
3929
3930     index++;
3931     if (!decc_filename_unix_only) {
3932       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3933       fp = fopen(file,"w");
3934       if (!fp) {
3935         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3936         fp = fopen(file,"w");
3937         if (!fp) {
3938             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3939             fp = fopen(file,"w");
3940         }
3941       }
3942      }
3943      else {
3944       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3945       fp = fopen(file,"w");
3946       if (!fp) {
3947         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3948         fp = fopen(file,"w");
3949         if (!fp) {
3950           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3951           fp = fopen(file,"w");
3952         }
3953       }
3954     }
3955     if (!fp) return 0;  /* we're hosed */
3956
3957     fprintf(fp,"$! 'f$verify(0)'\n");
3958     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3959     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3960     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3961     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3962     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3963     fprintf(fp,"$ perl_del    = \"delete\"\n");
3964     fprintf(fp,"$ pif         = \"if\"\n");
3965     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3966     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3967     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3968     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3969     fprintf(fp,"$!  --- build command line to get max possible length\n");
3970     fprintf(fp,"$c=perl_popen_cmd0\n");
3971     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3972     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3973     fprintf(fp,"$x=perl_popen_cmd3\n");
3974     fprintf(fp,"$c=c+x\n");
3975     fprintf(fp,"$ perl_on\n");
3976     fprintf(fp,"$ 'c'\n");
3977     fprintf(fp,"$ perl_status = $STATUS\n");
3978     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3979     fprintf(fp,"$ perl_exit 'perl_status'\n");
3980     fsync(fileno(fp));
3981
3982     fgetname(fp, file, 1);
3983     fstat(fileno(fp), &s0.crtl_stat);
3984     fclose(fp);
3985
3986     if (decc_filename_unix_only)
3987         int_tounixspec(file, file, NULL);
3988     fp = fopen(file,"r","shr=get");
3989     if (!fp) return 0;
3990     fstat(fileno(fp), &s1.crtl_stat);
3991
3992     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3993     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3994         fclose(fp);
3995         return 0;
3996     }
3997
3998     return fp;
3999 }
4000
4001
4002 static int vms_is_syscommand_xterm(void)
4003 {
4004     const static struct dsc$descriptor_s syscommand_dsc =
4005       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
4006
4007     const static struct dsc$descriptor_s decwdisplay_dsc =
4008       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
4009
4010     struct item_list_3 items[2];
4011     unsigned short dvi_iosb[4];
4012     unsigned long devchar;
4013     unsigned long devclass;
4014     int status;
4015
4016     /* Very simple check to guess if sys$command is a decterm? */
4017     /* First see if the DECW$DISPLAY: device exists */
4018     items[0].len = 4;
4019     items[0].code = DVI$_DEVCHAR;
4020     items[0].bufadr = &devchar;
4021     items[0].retadr = NULL;
4022     items[1].len = 0;
4023     items[1].code = 0;
4024
4025     status = sys$getdviw
4026         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
4027
4028     if ($VMS_STATUS_SUCCESS(status)) {
4029         status = dvi_iosb[0];
4030     }
4031
4032     if (!$VMS_STATUS_SUCCESS(status)) {
4033         SETERRNO(EVMSERR, status);
4034         return -1;
4035     }
4036
4037     /* If it does, then for now assume that we are on a workstation */
4038     /* Now verify that SYS$COMMAND is a terminal */
4039     /* for creating the debugger DECTerm */
4040
4041     items[0].len = 4;
4042     items[0].code = DVI$_DEVCLASS;
4043     items[0].bufadr = &devclass;
4044     items[0].retadr = NULL;
4045     items[1].len = 0;
4046     items[1].code = 0;
4047
4048     status = sys$getdviw
4049         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
4050
4051     if ($VMS_STATUS_SUCCESS(status)) {
4052         status = dvi_iosb[0];
4053     }
4054
4055     if (!$VMS_STATUS_SUCCESS(status)) {
4056         SETERRNO(EVMSERR, status);
4057         return -1;
4058     }
4059     else {
4060         if (devclass == DC$_TERM) {
4061             return 0;
4062         }
4063     }
4064     return -1;
4065 }
4066
4067 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
4068 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
4069 {
4070     int status;
4071     int ret_stat;
4072     char * ret_char;
4073     char device_name[65];
4074     unsigned short device_name_len;
4075     struct dsc$descriptor_s customization_dsc;
4076     struct dsc$descriptor_s device_name_dsc;
4077     const char * cptr;
4078     char * tptr;
4079     char customization[200];
4080     char title[40];
4081     pInfo info = NULL;
4082     char mbx1[64];
4083     unsigned short p_chan;
4084     int n;
4085     unsigned short iosb[4];
4086     struct item_list_3 items[2];
4087     const char * cust_str =
4088         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
4089     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
4090                                           DSC$K_CLASS_S, mbx1};
4091
4092      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
4093     /*---------------------------------------*/
4094     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
4095
4096
4097     /* Make sure that this is from the Perl debugger */
4098     ret_char = strstr(cmd," xterm ");
4099     if (ret_char == NULL)
4100         return NULL;
4101     cptr = ret_char + 7;
4102     ret_char = strstr(cmd,"tty");
4103     if (ret_char == NULL)
4104         return NULL;
4105     ret_char = strstr(cmd,"sleep");
4106     if (ret_char == NULL)
4107         return NULL;
4108
4109     if (decw_term_port == 0) {
4110         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
4111         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
4112         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
4113
4114        status = lib$find_image_symbol
4115                                (&filename1_dsc,
4116                                 &decw_term_port_dsc,
4117                                 (void *)&decw_term_port,
4118                                 NULL,
4119                                 0);
4120
4121         /* Try again with the other image name */
4122         if (!$VMS_STATUS_SUCCESS(status)) {
4123
4124            status = lib$find_image_symbol
4125                                (&filename2_dsc,
4126                                 &decw_term_port_dsc,
4127                                 (void *)&decw_term_port,
4128                                 NULL,
4129                                 0);
4130
4131         }
4132
4133     }
4134
4135
4136     /* No decw$term_port, give it up */
4137     if (!$VMS_STATUS_SUCCESS(status))
4138         return NULL;
4139
4140     /* Are we on a workstation? */
4141     /* to do: capture the rows / columns and pass their properties */
4142     ret_stat = vms_is_syscommand_xterm();
4143     if (ret_stat < 0)
4144         return NULL;
4145
4146     /* Make the title: */
4147     ret_char = strstr(cptr,"-title");
4148     if (ret_char != NULL) {
4149         while ((*cptr != 0) && (*cptr != '\"')) {
4150             cptr++;
4151         }
4152         if (*cptr == '\"')
4153             cptr++;
4154         n = 0;
4155         while ((*cptr != 0) && (*cptr != '\"')) {
4156             title[n] = *cptr;
4157             n++;
4158             if (n == 39) {
4159                 title[39] == 0;
4160                 break;
4161             }
4162             cptr++;
4163         }
4164         title[n] = 0;
4165     }
4166     else {
4167             /* Default title */
4168             strcpy(title,"Perl Debug DECTerm");
4169     }
4170     sprintf(customization, cust_str, title);
4171
4172     customization_dsc.dsc$a_pointer = customization;
4173     customization_dsc.dsc$w_length = strlen(customization);
4174     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4175     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
4176
4177     device_name_dsc.dsc$a_pointer = device_name;
4178     device_name_dsc.dsc$w_length = sizeof device_name -1;
4179     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4180     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
4181
4182     device_name_len = 0;
4183
4184     /* Try to create the window */
4185      status = (*decw_term_port)
4186        (NULL,
4187         NULL,
4188         &customization_dsc,
4189         &device_name_dsc,
4190         &device_name_len,
4191         NULL,
4192         NULL,
4193         NULL);
4194     if (!$VMS_STATUS_SUCCESS(status)) {
4195         SETERRNO(EVMSERR, status);
4196         return NULL;
4197     }
4198
4199     device_name[device_name_len] = '\0';
4200
4201     /* Need to set this up to look like a pipe for cleanup */
4202     n = sizeof(Info);
4203     status = lib$get_vm(&n, &info);
4204     if (!$VMS_STATUS_SUCCESS(status)) {
4205         SETERRNO(ENOMEM, status);
4206         return NULL;
4207     }
4208
4209     info->mode = *mode;
4210     info->done = FALSE;
4211     info->completion = 0;
4212     info->closing    = FALSE;
4213     info->in         = 0;
4214     info->out        = 0;
4215     info->err        = 0;
4216     info->fp         = NULL;
4217     info->useFILE    = 0;
4218     info->waiting    = 0;
4219     info->in_done    = TRUE;
4220     info->out_done   = TRUE;
4221     info->err_done   = TRUE;
4222
4223     /* Assign a channel on this so that it will persist, and not login */
4224     /* We stash this channel in the info structure for reference. */
4225     /* The created xterm self destructs when the last channel is removed */
4226     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4227     /* So leave this assigned. */
4228     device_name_dsc.dsc$w_length = device_name_len;
4229     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4230     if (!$VMS_STATUS_SUCCESS(status)) {
4231         SETERRNO(EVMSERR, status);
4232         return NULL;
4233     }
4234     info->xchan_valid = 1;
4235
4236     /* Now create a mailbox to be read by the application */
4237
4238     create_mbx(&p_chan, &d_mbx1);
4239
4240     /* write the name of the created terminal to the mailbox */
4241     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4242             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4243
4244     if (!$VMS_STATUS_SUCCESS(status)) {
4245         SETERRNO(EVMSERR, status);
4246         return NULL;
4247     }
4248
4249     info->fp  = PerlIO_open(mbx1, mode);
4250
4251     /* Done with this channel */
4252     sys$dassgn(p_chan);
4253
4254     /* If any errors, then clean up */
4255     if (!info->fp) {
4256         n = sizeof(Info);
4257         _ckvmssts_noperl(lib$free_vm(&n, &info));
4258         return NULL;
4259         }
4260
4261     /* All done */
4262     return info->fp;
4263 }
4264
4265 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4266
4267 static PerlIO *
4268 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4269 {
4270     static int handler_set_up = FALSE;
4271     PerlIO * ret_fp;
4272     unsigned long int sts, flags = CLI$M_NOWAIT;
4273     /* The use of a GLOBAL table (as was done previously) rendered
4274      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4275      * environment.  Hence we've switched to LOCAL symbol table.
4276      */
4277     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4278     int j, wait = 0, n;
4279     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4280     char *in, *out, *err, mbx[512];
4281     FILE *tpipe = 0;
4282     char tfilebuf[NAM$C_MAXRSS+1];
4283     pInfo info = NULL;
4284     char cmd_sym_name[20];
4285     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4286                                       DSC$K_CLASS_S, symbol};
4287     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4288                                       DSC$K_CLASS_S, 0};
4289     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4290                                       DSC$K_CLASS_S, cmd_sym_name};
4291     struct dsc$descriptor_s *vmscmd;
4292     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4293     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4294     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4295
4296     /* Check here for Xterm create request.  This means looking for
4297      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4298      *  is possible to create an xterm.
4299      */
4300     if (*in_mode == 'r') {
4301         PerlIO * xterm_fd;
4302
4303 #if defined(PERL_IMPLICIT_CONTEXT)
4304         /* Can not fork an xterm with a NULL context */
4305         /* This probably could never happen */
4306         xterm_fd = NULL;
4307         if (aTHX != NULL)
4308 #endif
4309         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4310         if (xterm_fd != NULL)
4311             return xterm_fd;
4312     }
4313
4314     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4315
4316     /* once-per-program initialization...
4317        note that the SETAST calls and the dual test of pipe_ef
4318        makes sure that only the FIRST thread through here does
4319        the initialization...all other threads wait until it's
4320        done.
4321
4322        Yeah, uglier than a pthread call, it's got all the stuff inline
4323        rather than in a separate routine.
4324     */
4325
4326     if (!pipe_ef) {
4327         _ckvmssts_noperl(sys$setast(0));
4328         if (!pipe_ef) {
4329             unsigned long int pidcode = JPI$_PID;
4330             $DESCRIPTOR(d_delay, RETRY_DELAY);
4331             _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4332             _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4333             _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4334         }
4335         if (!handler_set_up) {
4336           _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4337           handler_set_up = TRUE;
4338         }
4339         _ckvmssts_noperl(sys$setast(1));
4340     }
4341
4342     /* see if we can find a VMSPIPE.COM */
4343
4344     tfilebuf[0] = '@';
4345     vmspipe = find_vmspipe(aTHX);
4346     if (vmspipe) {
4347         strcpy(tfilebuf+1,vmspipe);
4348     } else {        /* uh, oh...we're in tempfile hell */
4349         tpipe = vmspipe_tempfile(aTHX);
4350         if (!tpipe) {       /* a fish popular in Boston */
4351             if (ckWARN(WARN_PIPE)) {
4352                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4353             }
4354         return NULL;
4355         }
4356         fgetname(tpipe,tfilebuf+1,1);
4357     }
4358     vmspipedsc.dsc$a_pointer = tfilebuf;
4359     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4360
4361     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4362     if (!(sts & 1)) {
4363       switch (sts) {
4364         case RMS$_FNF:  case RMS$_DNF:
4365           set_errno(ENOENT); break;
4366         case RMS$_DIR:
4367           set_errno(ENOTDIR); break;
4368         case RMS$_DEV:
4369           set_errno(ENODEV); break;
4370         case RMS$_PRV:
4371           set_errno(EACCES); break;
4372         case RMS$_SYN:
4373           set_errno(EINVAL); break;
4374         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4375           set_errno(E2BIG); break;
4376         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4377           _ckvmssts_noperl(sts); /* fall through */
4378         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4379           set_errno(EVMSERR);
4380       }
4381       set_vaxc_errno(sts);
4382       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4383         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4384       }
4385       *psts = sts;
4386       return NULL;
4387     }
4388     n = sizeof(Info);
4389     _ckvmssts_noperl(lib$get_vm(&n, &info));
4390
4391     strcpy(mode,in_mode);
4392     info->mode = *mode;
4393     info->done = FALSE;
4394     info->completion = 0;
4395     info->closing    = FALSE;
4396     info->in         = 0;
4397     info->out        = 0;
4398     info->err        = 0;
4399     info->fp         = NULL;
4400     info->useFILE    = 0;
4401     info->waiting    = 0;
4402     info->in_done    = TRUE;
4403     info->out_done   = TRUE;
4404     info->err_done   = TRUE;
4405     info->xchan      = 0;
4406     info->xchan_valid = 0;
4407
4408     in = PerlMem_malloc(VMS_MAXRSS);
4409     if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4410     out = PerlMem_malloc(VMS_MAXRSS);
4411     if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4412     err = PerlMem_malloc(VMS_MAXRSS);
4413     if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4414
4415     in[0] = out[0] = err[0] = '\0';
4416
4417     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4418         info->useFILE = 1;
4419         strcpy(p,p+1);
4420     }
4421     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4422         wait = 1;
4423         strcpy(p,p+1);
4424     }
4425
4426     if (*mode == 'r') {             /* piping from subroutine */
4427
4428         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4429         if (info->out) {
4430             info->out->pipe_done = &info->out_done;
4431             info->out_done = FALSE;
4432             info->out->info = info;
4433         }
4434         if (!info->useFILE) {
4435             info->fp  = PerlIO_open(mbx, mode);
4436         } else {
4437             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4438             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4439         }
4440
4441         if (!info->fp && info->out) {
4442             sys$cancel(info->out->chan_out);
4443
4444             while (!info->out_done) {
4445                 int done;
4446                 _ckvmssts_noperl(sys$setast(0));
4447                 done = info->out_done;
4448                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4449                 _ckvmssts_noperl(sys$setast(1));
4450                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4451             }
4452
4453             if (info->out->buf) {
4454                 n = info->out->bufsize * sizeof(char);
4455                 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4456             }
4457             n = sizeof(Pipe);
4458             _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4459             n = sizeof(Info);
4460             _ckvmssts_noperl(lib$free_vm(&n, &info));
4461             *psts = RMS$_FNF;
4462             return NULL;
4463         }
4464
4465         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4466         if (info->err) {
4467             info->err->pipe_done = &info->err_done;
4468             info->err_done = FALSE;
4469             info->err->info = info;
4470         }
4471
4472     } else if (*mode == 'w') {      /* piping to subroutine */
4473
4474         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4475         if (info->out) {
4476             info->out->pipe_done = &info->out_done;
4477             info->out_done = FALSE;
4478             info->out->info = info;
4479         }
4480
4481         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4482         if (info->err) {
4483             info->err->pipe_done = &info->err_done;
4484             info->err_done = FALSE;
4485             info->err->info = info;
4486         }
4487
4488         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4489         if (!info->useFILE) {
4490             info->fp  = PerlIO_open(mbx, mode);
4491         } else {
4492             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4493             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4494         }
4495
4496         if (info->in) {
4497             info->in->pipe_done = &info->in_done;
4498             info->in_done = FALSE;
4499             info->in->info = info;
4500         }
4501
4502         /* error cleanup */
4503         if (!info->fp && info->in) {
4504             info->done = TRUE;
4505             _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4506                                       0, 0, 0, 0, 0, 0, 0, 0));
4507
4508             while (!info->in_done) {
4509                 int done;
4510                 _ckvmssts_noperl(sys$setast(0));
4511                 done = info->in_done;
4512                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4513                 _ckvmssts_noperl(sys$setast(1));
4514                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4515             }
4516
4517             if (info->in->buf) {
4518                 n = info->in->bufsize * sizeof(char);
4519                 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4520             }
4521             n = sizeof(Pipe);
4522             _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4523             n = sizeof(Info);
4524             _ckvmssts_noperl(lib$free_vm(&n, &info));
4525             *psts = RMS$_FNF;
4526             return NULL;
4527         }
4528
4529
4530     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4531         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4532         if (info->out) {
4533             info->out->pipe_done = &info->out_done;
4534             info->out_done = FALSE;
4535             info->out->info = info;
4536         }
4537
4538         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4539         if (info->err) {
4540             info->err->pipe_done = &info->err_done;
4541             info->err_done = FALSE;
4542             info->err->info = info;
4543         }
4544     }
4545
4546     symbol[MAX_DCL_SYMBOL] = '\0';
4547
4548     strncpy(symbol, in, MAX_DCL_SYMBOL);
4549     d_symbol.dsc$w_length = strlen(symbol);
4550     _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4551
4552     strncpy(symbol, err, MAX_DCL_SYMBOL);
4553     d_symbol.dsc$w_length = strlen(symbol);
4554     _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4555
4556     strncpy(symbol, out, MAX_DCL_SYMBOL);
4557     d_symbol.dsc$w_length = strlen(symbol);
4558     _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4559
4560     /* Done with the names for the pipes */
4561     PerlMem_free(err);
4562     PerlMem_free(out);
4563     PerlMem_free(in);
4564
4565     p = vmscmd->dsc$a_pointer;
4566     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4567     if (*p == '$') p++;                         /* remove leading $ */
4568     while (*p == ' ' || *p == '\t') p++;
4569
4570     for (j = 0; j < 4; j++) {
4571         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4572         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4573
4574     strncpy(symbol, p, MAX_DCL_SYMBOL);
4575     d_symbol.dsc$w_length = strlen(symbol);
4576     _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4577
4578         if (strlen(p) > MAX_DCL_SYMBOL) {
4579             p += MAX_DCL_SYMBOL;
4580         } else {
4581             p += strlen(p);
4582         }
4583     }
4584     _ckvmssts_noperl(sys$setast(0));
4585     info->next=open_pipes;  /* prepend to list */
4586     open_pipes=info;
4587     _ckvmssts_noperl(sys$setast(1));
4588     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4589      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4590      * have SYS$COMMAND if we need it.
4591      */
4592     _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4593                       0, &info->pid, &info->completion,
4594                       0, popen_completion_ast,info,0,0,0));
4595
4596     /* if we were using a tempfile, close it now */
4597
4598     if (tpipe) fclose(tpipe);
4599
4600     /* once the subprocess is spawned, it has copied the symbols and
4601        we can get rid of ours */
4602
4603     for (j = 0; j < 4; j++) {
4604         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4605         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4606     _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4607     }
4608     _ckvmssts_noperl(lib$delete_symbol(&d_sym_in,  &table));
4609     _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4610     _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4611     vms_execfree(vmscmd);
4612
4613 #ifdef PERL_IMPLICIT_CONTEXT
4614     if (aTHX)
4615 #endif
4616     PL_forkprocess = info->pid;
4617
4618     ret_fp = info->fp;
4619     if (wait) {
4620          dSAVEDERRNO;
4621          int done = 0;
4622          while (!done) {
4623              _ckvmssts_noperl(sys$setast(0));
4624              done = info->done;
4625              if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4626              _ckvmssts_noperl(sys$setast(1));
4627              if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4628          }
4629         *psts = info->completion;
4630 /* Caller thinks it is open and tries to close it. */
4631 /* This causes some problems, as it changes the error status */
4632 /*        my_pclose(info->fp); */
4633
4634          /* If we did not have a file pointer open, then we have to */
4635          /* clean up here or eventually we will run out of something */
4636          SAVE_ERRNO;
4637          if (info->fp == NULL) {
4638              my_pclose_pinfo(aTHX_ info);
4639          }
4640          RESTORE_ERRNO;
4641
4642     } else {
4643         *psts = info->pid;
4644     }
4645     return ret_fp;
4646 }  /* end of safe_popen */
4647
4648
4649 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4650 PerlIO *
4651 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4652 {
4653     int sts;
4654     TAINT_ENV();
4655     TAINT_PROPER("popen");
4656     PERL_FLUSHALL_FOR_CHILD;
4657     return safe_popen(aTHX_ cmd,mode,&sts);
4658 }
4659
4660 /*}}}*/
4661
4662
4663 /* Routine to close and cleanup a pipe info structure */
4664
4665 static I32 my_pclose_pinfo(pTHX_ pInfo info) {
4666
4667     unsigned long int retsts;
4668     int done, iss, n;
4669     int status;
4670     pInfo next, last;
4671
4672     /* If we were writing to a subprocess, insure that someone reading from
4673      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4674      * produce an EOF record in the mailbox.
4675      *
4676      *  well, at least sometimes it *does*, so we have to watch out for
4677      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4678      */
4679      if (info->fp) {
4680         if (!info->useFILE
4681 #if defined(USE_ITHREADS)
4682           && my_perl
4683 #endif
4684           && PL_perlio_fd_refcnt)
4685             PerlIO_flush(info->fp);
4686         else
4687             fflush((FILE *)info->fp);
4688     }
4689
4690     _ckvmssts(sys$setast(0));
4691      info->closing = TRUE;
4692      done = info->done && info->in_done && info->out_done && info->err_done;
4693      /* hanging on write to Perl's input? cancel it */
4694      if (info->mode == 'r' && info->out && !info->out_done) {
4695         if (info->out->chan_out) {
4696             _ckvmssts(sys$cancel(info->out->chan_out));
4697             if (!info->out->chan_in) {   /* EOF generation, need AST */
4698                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4699             }
4700         }
4701      }
4702      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4703          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4704                            0, 0, 0, 0, 0, 0));
4705     _ckvmssts(sys$setast(1));
4706     if (info->fp) {
4707      if (!info->useFILE
4708 #if defined(USE_ITHREADS)
4709          && my_perl
4710 #endif
4711          && PL_perlio_fd_refcnt)
4712         PerlIO_close(info->fp);
4713      else
4714         fclose((FILE *)info->fp);
4715     }
4716      /*
4717         we have to wait until subprocess completes, but ALSO wait until all
4718         the i/o completes...otherwise we'll be freeing the "info" structure
4719         that the i/o ASTs could still be using...
4720      */
4721
4722      while (!done) {
4723          _ckvmssts(sys$setast(0));
4724          done = info->done && info->in_done && info->out_done && info->err_done;
4725          if (!done) _ckvmssts(sys$clref(pipe_ef));
4726          _ckvmssts(sys$setast(1));
4727          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4728      }
4729      retsts = info->completion;
4730
4731     /* remove from list of open pipes */
4732     _ckvmssts(sys$setast(0));
4733     last = NULL;
4734     for (next = open_pipes; next != NULL; last = next, next = next->next) {
4735         if (next == info)
4736             break;
4737     }
4738
4739     if (last)
4740         last->next = info->next;
4741     else
4742         open_pipes = info->next;
4743     _ckvmssts(sys$setast(1));
4744
4745     /* free buffers and structures */
4746
4747     if (info->in) {
4748         if (info->in->buf) {
4749             n = info->in->bufsize * sizeof(char);
4750             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4751         }
4752         n = sizeof(Pipe);
4753         _ckvmssts(lib$free_vm(&n, &info->in));
4754     }
4755     if (info->out) {
4756         if (info->out->buf) {
4757             n = info->out->bufsize * sizeof(char);
4758             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4759         }
4760         n = sizeof(Pipe);
4761         _ckvmssts(lib$free_vm(&n, &info->out));
4762     }
4763     if (info->err) {
4764         if (info->err->buf) {
4765             n = info->err->bufsize * sizeof(char);
4766             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4767         }
4768         n = sizeof(Pipe);
4769         _ckvmssts(lib$free_vm(&n, &info->err));
4770     }
4771     n = sizeof(Info);
4772     _ckvmssts(lib$free_vm(&n, &info));
4773
4774     return retsts;
4775 }
4776
4777
4778 /*{{{  I32 my_pclose(PerlIO *fp)*/
4779 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4780 {
4781     pInfo info, last = NULL;
4782     I32 ret_status;
4783
4784     /* Fixme - need ast and mutex protection here */
4785     for (info = open_pipes; info != NULL; last = info, info = info->next)
4786         if (info->fp == fp) break;
4787
4788     if (info == NULL) {  /* no such pipe open */
4789       set_errno(ECHILD); /* quoth POSIX */
4790       set_vaxc_errno(SS$_NONEXPR);
4791       return -1;
4792     }
4793
4794     ret_status = my_pclose_pinfo(aTHX_ info);
4795
4796     return ret_status;
4797
4798 }  /* end of my_pclose() */
4799
4800 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4801   /* Roll our own prototype because we want this regardless of whether
4802    * _VMS_WAIT is defined.
4803    */
4804   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4805 #endif
4806 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4807    created with popen(); otherwise partially emulate waitpid() unless
4808    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4809    Also check processes not considered by the CRTL waitpid().
4810  */
4811 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4812 Pid_t
4813 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4814 {
4815     pInfo info;
4816     int done;
4817     int sts;
4818     int j;
4819
4820     if (statusp) *statusp = 0;
4821
4822     for (info = open_pipes; info != NULL; info = info->next)
4823         if (info->pid == pid) break;
4824
4825     if (info != NULL) {  /* we know about this child */
4826       while (!info->done) {
4827           _ckvmssts(sys$setast(0));
4828           done = info->done;
4829           if (!done) _ckvmssts(sys$clref(pipe_ef));
4830           _ckvmssts(sys$setast(1));
4831           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4832       }
4833
4834       if (statusp) *statusp = info->completion;
4835       return pid;
4836     }
4837
4838     /* child that already terminated? */
4839
4840     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4841         if (closed_list[j].pid == pid) {
4842             if (statusp) *statusp = closed_list[j].completion;
4843             return pid;
4844         }
4845     }
4846
4847     /* fall through if this child is not one of our own pipe children */
4848
4849 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4850
4851       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4852        * in 7.2 did we get a version that fills in the VMS completion
4853        * status as Perl has always tried to do.
4854        */
4855
4856       sts = __vms_waitpid( pid, statusp, flags );
4857
4858       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4859          return sts;
4860
4861       /* If the real waitpid tells us the child does not exist, we
4862        * fall through here to implement waiting for a child that
4863        * was created by some means other than exec() (say, spawned
4864        * from DCL) or to wait for a process that is not a subprocess
4865        * of the current process.
4866        */
4867
4868 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4869
4870     {
4871       $DESCRIPTOR(intdsc,"0 00:00:01");
4872       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4873       unsigned long int pidcode = JPI$_PID, mypid;
4874       unsigned long int interval[2];
4875       unsigned int jpi_iosb[2];
4876       struct itmlst_3 jpilist[2] = {
4877           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4878           {                      0,         0,                 0, 0}
4879       };
4880
4881       if (pid <= 0) {
4882         /* Sorry folks, we don't presently implement rooting around for
4883            the first child we can find, and we definitely don't want to
4884            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4885          */
4886         set_errno(ENOTSUP);
4887         return -1;
4888       }
4889
4890       /* Get the owner of the child so I can warn if it's not mine. If the
4891        * process doesn't exist or I don't have the privs to look at it,
4892        * I can go home early.
4893        */
4894       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4895       if (sts & 1) sts = jpi_iosb[0];
4896       if (!(sts & 1)) {
4897         switch (sts) {
4898             case SS$_NONEXPR:
4899                 set_errno(ECHILD);
4900                 break;
4901             case SS$_NOPRIV:
4902                 set_errno(EACCES);
4903                 break;
4904             default:
4905                 _ckvmssts(sts);
4906         }
4907         set_vaxc_errno(sts);
4908         return -1;
4909       }
4910
4911       if (ckWARN(WARN_EXEC)) {
4912         /* remind folks they are asking for non-standard waitpid behavior */
4913         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4914         if (ownerpid != mypid)
4915           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4916                       "waitpid: process %x is not a child of process %x",
4917                       pid,mypid);
4918       }
4919
4920       /* simply check on it once a second until it's not there anymore. */
4921
4922       _ckvmssts(sys$bintim(&intdsc,interval));
4923       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4924             _ckvmssts(sys$schdwk(0,0,interval,0));
4925             _ckvmssts(sys$hiber());
4926       }
4927       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4928
4929       _ckvmssts(sts);
4930       return pid;
4931     }
4932 }  /* end of waitpid() */
4933 /*}}}*/
4934 /*}}}*/
4935 /*}}}*/
4936
4937 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4938 char *
4939 my_gconvert(double val, int ndig, int trail, char *buf)
4940 {
4941   static char __gcvtbuf[DBL_DIG+1];
4942   char *loc;
4943
4944   loc = buf ? buf : __gcvtbuf;
4945
4946 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4947   if (val < 1) {
4948     sprintf(loc,"%.*g",ndig,val);
4949     return loc;
4950   }
4951 #endif
4952
4953   if (val) {
4954     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4955     return gcvt(val,ndig,loc);
4956   }
4957   else {
4958     loc[0] = '0'; loc[1] = '\0';
4959     return loc;
4960   }
4961
4962 }
4963 /*}}}*/
4964
4965 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4966 static int rms_free_search_context(struct FAB * fab)
4967 {
4968 struct NAM * nam;
4969
4970     nam = fab->fab$l_nam;
4971     nam->nam$b_nop |= NAM$M_SYNCHK;
4972     nam->nam$l_rlf = NULL;
4973     fab->fab$b_dns = 0;
4974     return sys$parse(fab, NULL, NULL);
4975 }
4976
4977 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4978 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4979 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4980 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4981 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4982 #define rms_nam_esll(nam) nam.nam$b_esl
4983 #define rms_nam_esl(nam) nam.nam$b_esl
4984 #define rms_nam_name(nam) nam.nam$l_name
4985 #define rms_nam_namel(nam) nam.nam$l_name
4986 #define rms_nam_type(nam) nam.nam$l_type
4987 #define rms_nam_typel(nam) nam.nam$l_type
4988 #define rms_nam_ver(nam) nam.nam$l_ver
4989 #define rms_nam_verl(nam) nam.nam$l_ver
4990 #define rms_nam_rsll(nam) nam.nam$b_rsl
4991 #define rms_nam_rsl(nam) nam.nam$b_rsl
4992 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4993 #define rms_set_fna(fab, nam, name, size) \
4994         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4995 #define rms_get_fna(fab, nam) fab.fab$l_fna
4996 #define rms_set_dna(fab, nam, name, size) \
4997         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4998 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4999 #define rms_set_esa(nam, name, size) \
5000         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
5001 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
5002         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
5003 #define rms_set_rsa(nam, name, size) \
5004         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
5005 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
5006         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
5007 #define rms_nam_name_type_l_size(nam) \
5008         (nam.nam$b_name + nam.nam$b_type)
5009 #else
5010 static int rms_free_search_context(struct FAB * fab)
5011 {
5012 struct NAML * nam;
5013
5014     nam = fab->fab$l_naml;
5015     nam->naml$b_nop |= NAM$M_SYNCHK;
5016     nam->naml$l_rlf = NULL;
5017     nam->naml$l_long_defname_size = 0;
5018
5019     fab->fab$b_dns = 0;
5020     return sys$parse(fab, NULL, NULL);
5021 }
5022
5023 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
5024 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
5025 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
5026 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
5027 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
5028 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
5029 #define rms_nam_esl(nam) nam.naml$b_esl
5030 #define rms_nam_name(nam) nam.naml$l_name
5031 #define rms_nam_namel(nam) nam.naml$l_long_name
5032 #define rms_nam_type(nam) nam.naml$l_type
5033 #define rms_nam_typel(nam) nam.naml$l_long_type
5034 #define rms_nam_ver(nam) nam.naml$l_ver
5035 #define rms_nam_verl(nam) nam.naml$l_long_ver
5036 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
5037 #define rms_nam_rsl(nam) nam.naml$b_rsl
5038 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
5039 #define rms_set_fna(fab, nam, name, size) \
5040         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
5041         nam.naml$l_long_filename_size = size; \
5042         nam.naml$l_long_filename = name;}
5043 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
5044 #define rms_set_dna(fab, nam, name, size) \
5045         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
5046         nam.naml$l_long_defname_size = size; \
5047         nam.naml$l_long_defname = name; }
5048 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
5049 #define rms_set_esa(nam, name, size) \
5050         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
5051         nam.naml$l_long_expand_alloc = size; \
5052         nam.naml$l_long_expand = name; }
5053 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
5054         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
5055         nam.naml$l_long_expand = l_name; \
5056         nam.naml$l_long_expand_alloc = l_size; }
5057 #define rms_set_rsa(nam, name, size) \
5058         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
5059         nam.naml$l_long_result = name; \
5060         nam.naml$l_long_result_alloc = size; }
5061 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
5062         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
5063         nam.naml$l_long_result = l_name; \
5064         nam.naml$l_long_result_alloc = l_size; }
5065 #define rms_nam_name_type_l_size(nam) \
5066         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
5067 #endif
5068
5069
5070 /* rms_erase
5071  * The CRTL for 8.3 and later can create symbolic links in any mode,
5072  * however in 8.3 the unlink/remove/delete routines will only properly handle
5073  * them if one of the PCP modes is active.
5074  */
5075 static int rms_erase(const char * vmsname)
5076 {
5077   int status;
5078   struct FAB myfab = cc$rms_fab;
5079   rms_setup_nam(mynam);
5080
5081   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
5082   rms_bind_fab_nam(myfab, mynam);
5083
5084 #ifdef NAML$M_OPEN_SPECIAL
5085   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5086 #endif
5087
5088   status = sys$erase(&myfab, 0, 0);
5089
5090   return status;
5091 }
5092
5093
5094 static int
5095 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
5096                     const struct dsc$descriptor_s * vms_dst_dsc,
5097                     unsigned long flags)
5098 {
5099     /*  VMS and UNIX handle file permissions differently and the
5100      * the same ACL trick may be needed for renaming files,
5101      * especially if they are directories.
5102      */
5103
5104    /* todo: get kill_file and rename to share common code */
5105    /* I can not find online documentation for $change_acl
5106     * it appears to be replaced by $set_security some time ago */
5107
5108 const unsigned int access_mode = 0;
5109 $DESCRIPTOR(obj_file_dsc,"FILE");
5110 char *vmsname;
5111 char *rslt;
5112 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
5113 int aclsts, fndsts, rnsts = -1;
5114 unsigned int ctx = 0;
5115 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5116 struct dsc$descriptor_s * clean_dsc;
5117
5118 struct myacedef {
5119     unsigned char myace$b_length;
5120     unsigned char myace$b_type;
5121     unsigned short int myace$w_flags;
5122     unsigned long int myace$l_access;
5123     unsigned long int myace$l_ident;
5124 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
5125              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
5126              0},
5127              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
5128
5129 struct item_list_3
5130         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
5131                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
5132                       {0,0,0,0}},
5133         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
5134         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
5135                      {0,0,0,0}};
5136
5137
5138     /* Expand the input spec using RMS, since we do not want to put
5139      * ACLs on the target of a symbolic link */
5140     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
5141     if (vmsname == NULL)
5142         return SS$_INSFMEM;
5143
5144     rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
5145                         vmsname,
5146                         PERL_RMSEXPAND_M_SYMLINK);
5147     if (rslt == NULL) {
5148         PerlMem_free(vmsname);
5149         return SS$_INSFMEM;
5150     }
5151
5152     /* So we get our own UIC to use as a rights identifier,
5153      * and the insert an ACE at the head of the ACL which allows us
5154      * to delete the file.
5155      */
5156     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
5157
5158     fildsc.dsc$w_length = strlen(vmsname);
5159     fildsc.dsc$a_pointer = vmsname;
5160     ctx = 0;
5161     newace.myace$l_ident = oldace.myace$l_ident;
5162     rnsts = SS$_ABORT;
5163
5164     /* Grab any existing ACEs with this identifier in case we fail */
5165     clean_dsc = &fildsc;
5166     aclsts = fndsts = sys$get_security(&obj_file_dsc,
5167                                &fildsc,
5168                                NULL,
5169                                OSS$M_WLOCK,
5170                                findlst,
5171                                &ctx,
5172                                &access_mode);
5173
5174     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
5175         /* Add the new ACE . . . */
5176
5177         /* if the sys$get_security succeeded, then ctx is valid, and the
5178          * object/file descriptors will be ignored.  But otherwise they
5179          * are needed
5180          */
5181         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
5182                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
5183         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5184             set_errno(EVMSERR);
5185             set_vaxc_errno(aclsts);
5186             PerlMem_free(vmsname);
5187             return aclsts;
5188         }
5189
5190         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5191                                 NULL, NULL,
5192                                 &flags,
5193                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5194
5195         if ($VMS_STATUS_SUCCESS(rnsts)) {
5196             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5197         }
5198
5199         /* Put things back the way they were. */
5200         ctx = 0;
5201         aclsts = sys$get_security(&obj_file_dsc,
5202                                   clean_dsc,
5203                                   NULL,
5204                                   OSS$M_WLOCK,
5205                                   findlst,
5206                                   &ctx,
5207                                   &access_mode);
5208
5209         if ($VMS_STATUS_SUCCESS(aclsts)) {
5210         int sec_flags;
5211
5212             sec_flags = 0;
5213             if (!$VMS_STATUS_SUCCESS(fndsts))
5214                 sec_flags = OSS$M_RELCTX;
5215
5216             /* Get rid of the new ACE */
5217             aclsts = sys$set_security(NULL, NULL, NULL,
5218                                   sec_flags, dellst, &ctx, &access_mode);
5219
5220             /* If there was an old ACE, put it back */
5221             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5222                 addlst[0].bufadr = &oldace;
5223                 aclsts = sys$set_security(NULL, NULL, NULL,
5224                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
5225                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5226                     set_errno(EVMSERR);
5227                     set_vaxc_errno(aclsts);
5228                     rnsts = aclsts;
5229                 }
5230             } else {
5231             int aclsts2;
5232
5233                 /* Try to clear the lock on the ACL list */
5234                 aclsts2 = sys$set_security(NULL, NULL, NULL,
5235                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
5236
5237                 /* Rename errors are most important */
5238                 if (!$VMS_STATUS_SUCCESS(rnsts))
5239                     aclsts = rnsts;
5240                 set_errno(EVMSERR);
5241                 set_vaxc_errno(aclsts);
5242                 rnsts = aclsts;
5243             }
5244         }
5245         else {
5246             if (aclsts != SS$_ACLEMPTY)
5247                 rnsts = aclsts;
5248         }
5249     }
5250     else
5251         rnsts = fndsts;
5252
5253     PerlMem_free(vmsname);
5254     return rnsts;
5255 }
5256
5257
5258 /*{{{int rename(const char *, const char * */
5259 /* Not exactly what X/Open says to do, but doing it absolutely right
5260  * and efficiently would require a lot more work.  This should be close
5261  * enough to pass all but the most strict X/Open compliance test.
5262  */
5263 int
5264 Perl_rename(pTHX_ const char *src, const char * dst)
5265 {
5266 int retval;
5267 int pre_delete = 0;
5268 int src_sts;
5269 int dst_sts;
5270 Stat_t src_st;
5271 Stat_t dst_st;
5272
5273     /* Validate the source file */
5274     src_sts = flex_lstat(src, &src_st);
5275     if (src_sts != 0) {
5276
5277         /* No source file or other problem */
5278         return src_sts;
5279     }
5280     if (src_st.st_devnam[0] == 0)  {
5281         /* This may be possible so fail if it is seen. */
5282         errno = EIO;
5283         return -1;
5284     }
5285
5286     dst_sts = flex_lstat(dst, &dst_st);
5287     if (dst_sts == 0) {
5288
5289         if (dst_st.st_dev != src_st.st_dev) {
5290             /* Must be on the same device */
5291             errno = EXDEV;
5292             return -1;
5293         }
5294
5295         /* VMS_INO_T_COMPARE is true if the inodes are different
5296          * to match the output of memcmp
5297          */
5298
5299         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5300             /* That was easy, the files are the same! */
5301             return 0;
5302         }
5303
5304         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5305             /* If source is a directory, so must be dest */
5306                 errno = EISDIR;
5307                 return -1;
5308         }
5309
5310     }
5311
5312
5313     if ((dst_sts == 0) &&
5314         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5315
5316         /* We have issues here if vms_unlink_all_versions is set
5317          * If the destination exists, and is not a directory, then
5318          * we must delete in advance.
5319          *
5320          * If the src is a directory, then we must always pre-delete
5321          * the destination.
5322          *
5323          * If we successfully delete the dst in advance, and the rename fails
5324          * X/Open requires that errno be EIO.
5325          *
5326          */
5327
5328         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5329             int d_sts;
5330             d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam,
5331                                      S_ISDIR(dst_st.st_mode));
5332
5333            /* Need to delete all versions ? */
5334            if ((d_sts == 0) && (vms_unlink_all_versions == 1)) {
5335                 int i = 0;
5336
5337                 while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) {
5338                     d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 0);
5339                     if (d_sts != 0)
5340                         break;
5341                     i++;
5342
5343                     /* Make sure that we do not loop forever */
5344                     if (i > 32767) {
5345                         errno = EIO;
5346                         d_sts = -1;
5347                         break;
5348                     }
5349                 }
5350            }
5351
5352             if (d_sts != 0)
5353                 return d_sts;
5354
5355             /* We killed the destination, so only errno now is EIO */
5356             pre_delete = 1;
5357         }
5358     }
5359
5360     /* Originally the idea was to call the CRTL rename() and only
5361      * try the lib$rename_file if it failed.
5362      * It turns out that there are too many variants in what the
5363      * the CRTL rename might do, so only use lib$rename_file
5364      */
5365     retval = -1;
5366
5367     {
5368         /* Is the source and dest both in VMS format */
5369         /* if the source is a directory, then need to fileify */
5370         /*  and dest must be a directory or non-existant. */
5371
5372         char * vms_dst;
5373         int sts;
5374         char * ret_str;
5375         unsigned long flags;
5376         struct dsc$descriptor_s old_file_dsc;
5377         struct dsc$descriptor_s new_file_dsc;
5378
5379         /* We need to modify the src and dst depending
5380          * on if one or more of them are directories.
5381          */
5382
5383         vms_dst = PerlMem_malloc(VMS_MAXRSS);
5384         if (vms_dst == NULL)
5385             _ckvmssts_noperl(SS$_INSFMEM);
5386
5387         if (S_ISDIR(src_st.st_mode)) {
5388         char * ret_str;
5389         char * vms_dir_file;
5390
5391             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5392             if (vms_dir_file == NULL)
5393                 _ckvmssts_noperl(SS$_INSFMEM);
5394
5395             /* If the dest is a directory, we must remove it
5396             if (dst_sts == 0) {
5397                 int d_sts;
5398                 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1);
5399                 if (d_sts != 0) {
5400                     PerlMem_free(vms_dst);
5401                     errno = EIO;
5402                     return sts;
5403                 }
5404
5405                 pre_delete = 1;
5406             }
5407
5408            /* The dest must be a VMS file specification */
5409            ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5410            if (ret_str == NULL) {
5411                 PerlMem_free(vms_dst);
5412                 errno = EIO;
5413                 return -1;
5414            }
5415
5416             /* The source must be a file specification */
5417             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5418             if (vms_dir_file == NULL)
5419                 _ckvmssts_noperl(SS$_INSFMEM);
5420
5421             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5422             if (ret_str == NULL) {
5423                 PerlMem_free(vms_dst);
5424                 PerlMem_free(vms_dir_file);
5425                 errno = EIO;
5426                 return -1;
5427             }
5428             PerlMem_free(vms_dst);
5429             vms_dst = vms_dir_file;
5430
5431         } else {
5432             /* File to file or file to new dir */
5433
5434             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5435                 /* VMS pathify a dir target */
5436                 ret_str = int_tovmspath(dst, vms_dst, NULL);
5437                 if (ret_str == NULL) {
5438                     PerlMem_free(vms_dst);
5439                     errno = EIO;
5440                     return -1;
5441                 }
5442             } else {
5443                 char * v_spec, * r_spec, * d_spec, * n_spec;
5444                 char * e_spec, * vs_spec;
5445                 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5446
5447                 /* fileify a target VMS file specification */
5448                 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5449                 if (ret_str == NULL) {
5450                     PerlMem_free(vms_dst);
5451                     errno = EIO;
5452                     return -1;
5453                 }
5454
5455                 sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len,
5456                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5457                              &e_len, &vs_spec, &vs_len);
5458                 if (sts == 0) {
5459                      if (e_len == 0) {
5460                          /* Get rid of the version */
5461                          if (vs_len != 0) {
5462                              *vs_spec = '\0';
5463                          }
5464                          /* Need to specify a '.' so that the extension */
5465                          /* is not inherited */
5466                          strcat(vms_dst,".");
5467                      }
5468                 }
5469             }
5470         }
5471
5472         old_file_dsc.dsc$a_pointer = src_st.st_devnam;
5473         old_file_dsc.dsc$w_length = strlen(src_st.st_devnam);
5474         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5475         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5476
5477         new_file_dsc.dsc$a_pointer = vms_dst;
5478         new_file_dsc.dsc$w_length = strlen(vms_dst);
5479         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5480         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5481
5482         flags = 0;
5483 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5484         flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5485 #endif
5486
5487         sts = lib$rename_file(&old_file_dsc,
5488                               &new_file_dsc,
5489                               NULL, NULL,
5490                               &flags,
5491                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5492         if (!$VMS_STATUS_SUCCESS(sts)) {
5493
5494            /* We could have failed because VMS style permissions do not
5495             * permit renames that UNIX will allow.  Just like the hack
5496             * in for kill_file.
5497             */
5498            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5499         }
5500
5501         PerlMem_free(vms_dst);
5502         if (!$VMS_STATUS_SUCCESS(sts)) {
5503             errno = EIO;
5504             return -1;
5505         }
5506         retval = 0;
5507     }
5508
5509     if (vms_unlink_all_versions) {
5510         /* Now get rid of any previous versions of the source file that
5511          * might still exist
5512          */
5513         int i = 0;
5514         dSAVEDERRNO;
5515         SAVE_ERRNO;
5516         src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5517                                    S_ISDIR(src_st.st_mode));
5518         while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) {
5519              src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5520                                        S_ISDIR(src_st.st_mode));
5521              if (src_sts != 0)
5522                  break;
5523              i++;
5524
5525              /* Make sure that we do not loop forever */
5526              if (i > 32767) {
5527                  src_sts = -1;
5528                  break;
5529              }
5530         }
5531         RESTORE_ERRNO;
5532     }
5533
5534     /* We deleted the destination, so must force the error to be EIO */
5535     if ((retval != 0) && (pre_delete != 0))
5536         errno = EIO;
5537
5538     return retval;
5539 }
5540 /*}}}*/
5541
5542
5543 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5544 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5545  * to expand file specification.  Allows for a single default file
5546  * specification and a simple mask of options.  If outbuf is non-NULL,
5547  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5548  * the resultant file specification is placed.  If outbuf is NULL, the
5549  * resultant file specification is placed into a static buffer.
5550  * The third argument, if non-NULL, is taken to be a default file
5551  * specification string.  The fourth argument is unused at present.
5552  * rmesexpand() returns the address of the resultant string if
5553  * successful, and NULL on error.
5554  *
5555  * New functionality for previously unused opts value:
5556  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5557  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5558  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5559  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5560  */
5561 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5562
5563 static char *
5564 int_rmsexpand
5565    (const char *filespec,
5566     char *outbuf,
5567     const char *defspec,
5568     unsigned opts,
5569     int * fs_utf8,
5570     int * dfs_utf8)
5571 {
5572   char * ret_spec;
5573   const char * in_spec;
5574   char * spec_buf;
5575   const char * def_spec;
5576   char * vmsfspec, *vmsdefspec;
5577   char * esa;
5578   char * esal = NULL;
5579   char * outbufl;
5580   struct FAB myfab = cc$rms_fab;
5581   rms_setup_nam(mynam);
5582   STRLEN speclen;
5583   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5584   int sts;
5585
5586   /* temp hack until UTF8 is actually implemented */
5587   if (fs_utf8 != NULL)
5588     *fs_utf8 = 0;
5589
5590   if (!filespec || !*filespec) {
5591     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5592     return NULL;
5593   }
5594
5595   vmsfspec = NULL;
5596   vmsdefspec = NULL;
5597   outbufl = NULL;
5598
5599   in_spec = filespec;
5600   isunix = 0;
5601   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5602       char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5603       int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5604
5605       /* If this is a UNIX file spec, convert it to VMS */
5606       sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5607                            &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5608                            &e_len, &vs_spec, &vs_len);
5609       if (sts != 0) {
5610           isunix = 1;
5611           char * ret_spec;
5612
5613           vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5614           if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5615           ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5616           if (ret_spec == NULL) {
5617               PerlMem_free(vmsfspec);
5618               return NULL;
5619           }
5620           in_spec = (const char *)vmsfspec;
5621
5622           /* Unless we are forcing to VMS format, a UNIX input means
5623            * UNIX output, and that requires long names to be used
5624            */
5625           if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5626 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5627               opts |= PERL_RMSEXPAND_M_LONG;
5628 #else
5629               NOOP;
5630 #endif
5631           else
5632               isunix = 0;
5633       }
5634
5635   }
5636
5637   rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
5638   rms_bind_fab_nam(myfab, mynam);
5639
5640   /* Process the default file specification if present */
5641   def_spec = defspec;
5642   if (defspec && *defspec) {
5643     int t_isunix;
5644     t_isunix = is_unix_filespec(defspec);
5645     if (t_isunix) {
5646       vmsdefspec = PerlMem_malloc(VMS_MAXRSS);
5647       if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5648       ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5649
5650       if (ret_spec == NULL) {
5651           /* Clean up and bail */
5652           PerlMem_free(vmsdefspec);
5653           if (vmsfspec != NULL)
5654               PerlMem_free(vmsfspec);
5655               return NULL;
5656           }
5657           def_spec = (const char *)vmsdefspec;
5658       }
5659       rms_set_dna(myfab, mynam,
5660                   (char *)def_spec, strlen(def_spec)); /* cast ok */
5661   }
5662
5663   /* Now we need the expansion buffers */
5664   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5665   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5666 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5667   esal = PerlMem_malloc(VMS_MAXRSS);
5668   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5669 #endif
5670   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5671
5672   /* If a NAML block is used RMS always writes to the long and short
5673    * addresses unless you suppress the short name.
5674    */
5675 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5676   outbufl = PerlMem_malloc(VMS_MAXRSS);
5677   if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5678 #endif
5679    rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5680
5681 #ifdef NAM$M_NO_SHORT_UPCASE
5682   if (decc_efs_case_preserve)
5683     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5684 #endif
5685
5686    /* We may not want to follow symbolic links */
5687 #ifdef NAML$M_OPEN_SPECIAL
5688   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5689     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5690 #endif
5691
5692   /* First attempt to parse as an existing file */
5693   retsts = sys$parse(&myfab,0,0);
5694   if (!(retsts & STS$K_SUCCESS)) {
5695
5696     /* Could not find the file, try as syntax only if error is not fatal */
5697     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5698     if (retsts == RMS$_DNF ||
5699         retsts == RMS$_DIR ||
5700         retsts == RMS$_DEV ||
5701         retsts == RMS$_PRV) {
5702       retsts = sys$parse(&myfab,0,0);
5703       if (retsts & STS$K_SUCCESS) goto int_expanded;
5704     }
5705
5706      /* Still could not parse the file specification */
5707     /*----------------------------------------------*/
5708     sts = rms_free_search_context(&myfab); /* Free search context */
5709     if (vmsdefspec != NULL)
5710         PerlMem_free(vmsdefspec);
5711     if (vmsfspec != NULL)
5712         PerlMem_free(vmsfspec);
5713     if (outbufl != NULL)
5714         PerlMem_free(outbufl);
5715     PerlMem_free(esa);
5716     if (esal != NULL)
5717         PerlMem_free(esal);
5718     set_vaxc_errno(retsts);
5719     if      (retsts == RMS$_PRV) set_errno(EACCES);
5720     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5721     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5722     else                         set_errno(EVMSERR);
5723     return NULL;
5724   }
5725   retsts = sys$search(&myfab,0,0);
5726   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5727     sts = rms_free_search_context(&myfab); /* Free search context */
5728     if (vmsdefspec != NULL)
5729         PerlMem_free(vmsdefspec);
5730     if (vmsfspec != NULL)
5731         PerlMem_free(vmsfspec);
5732     if (outbufl != NULL)
5733         PerlMem_free(outbufl);
5734     PerlMem_free(esa);
5735     if (esal != NULL)
5736         PerlMem_free(esal);
5737     set_vaxc_errno(retsts);
5738     if      (retsts == RMS$_PRV) set_errno(EACCES);
5739     else                         set_errno(EVMSERR);
5740     return NULL;
5741   }
5742
5743   /* If the input filespec contained any lowercase characters,
5744    * downcase the result for compatibility with Unix-minded code. */
5745 int_expanded:
5746   if (!decc_efs_case_preserve) {
5747     char * tbuf;
5748     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5749       if (islower(*tbuf)) { haslower = 1; break; }
5750   }
5751
5752    /* Is a long or a short name expected */
5753   /*------------------------------------*/
5754   spec_buf = NULL;
5755 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5756   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5757     if (rms_nam_rsll(mynam)) {
5758         spec_buf = outbufl;
5759         speclen = rms_nam_rsll(mynam);
5760     }
5761     else {
5762         spec_buf = esal; /* Not esa */
5763         speclen = rms_nam_esll(mynam);
5764     }
5765   }
5766   else {
5767 #endif
5768     if (rms_nam_rsl(mynam)) {
5769         spec_buf = outbuf;
5770         speclen = rms_nam_rsl(mynam);
5771     }
5772     else {
5773         spec_buf = esa; /* Not esal */
5774         speclen = rms_nam_esl(mynam);
5775     }
5776 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5777   }
5778 #endif
5779   spec_buf[speclen] = '\0';
5780
5781   /* Trim off null fields added by $PARSE
5782    * If type > 1 char, must have been specified in original or default spec
5783    * (not true for version; $SEARCH may have added version of existing file).
5784    */
5785   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5786   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5787     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5788              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5789   }
5790   else {
5791     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5792              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5793   }
5794   if (trimver || trimtype) {
5795     if (defspec && *defspec) {
5796       char *defesal = NULL;
5797       char *defesa = NULL;
5798       defesa = PerlMem_malloc(VMS_MAXRSS + 1);
5799       if (defesa != NULL) {
5800         struct FAB deffab = cc$rms_fab;
5801 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5802         defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5803         if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5804 #endif
5805         rms_setup_nam(defnam);
5806
5807         rms_bind_fab_nam(deffab, defnam);
5808
5809         /* Cast ok */
5810         rms_set_fna
5811             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5812
5813         /* RMS needs the esa/esal as a work area if wildcards are involved */
5814         rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5815
5816         rms_clear_nam_nop(defnam);
5817         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5818 #ifdef NAM$M_NO_SHORT_UPCASE
5819         if (decc_efs_case_preserve)
5820           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5821 #endif
5822 #ifdef NAML$M_OPEN_SPECIAL
5823         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5824           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5825 #endif
5826         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5827           if (trimver) {
5828              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5829           }
5830           if (trimtype) {
5831             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5832           }
5833         }
5834         if (defesal != NULL)
5835             PerlMem_free(defesal);
5836         PerlMem_free(defesa);
5837       } else {
5838           _ckvmssts_noperl(SS$_INSFMEM);
5839       }
5840     }
5841     if (trimver) {
5842       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5843         if (*(rms_nam_verl(mynam)) != '\"')
5844           speclen = rms_nam_verl(mynam) - spec_buf;
5845       }
5846       else {
5847         if (*(rms_nam_ver(mynam)) != '\"')
5848           speclen = rms_nam_ver(mynam) - spec_buf;
5849       }
5850     }
5851     if (trimtype) {
5852       /* If we didn't already trim version, copy down */
5853       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5854         if (speclen > rms_nam_verl(mynam) - spec_buf)
5855           memmove
5856            (rms_nam_typel(mynam),
5857             rms_nam_verl(mynam),
5858             speclen - (rms_nam_verl(mynam) - spec_buf));
5859           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5860       }
5861       else {
5862         if (speclen > rms_nam_ver(mynam) - spec_buf)
5863           memmove
5864            (rms_nam_type(mynam),
5865             rms_nam_ver(mynam),
5866             speclen - (rms_nam_ver(mynam) - spec_buf));
5867           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5868       }
5869     }
5870   }
5871
5872    /* Done with these copies of the input files */
5873   /*-------------------------------------------*/
5874   if (vmsfspec != NULL)
5875         PerlMem_free(vmsfspec);
5876   if (vmsdefspec != NULL)
5877         PerlMem_free(vmsdefspec);
5878
5879   /* If we just had a directory spec on input, $PARSE "helpfully"
5880    * adds an empty name and type for us */
5881 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5882   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5883     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5884         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5885         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5886       speclen = rms_nam_namel(mynam) - spec_buf;
5887   }
5888   else
5889 #endif
5890   {
5891     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5892         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5893         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5894       speclen = rms_nam_name(mynam) - spec_buf;
5895   }
5896
5897   /* Posix format specifications must have matching quotes */
5898   if (speclen < (VMS_MAXRSS - 1)) {
5899     if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5900       if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5901         spec_buf[speclen] = '\"';
5902         speclen++;
5903       }
5904     }
5905   }
5906   spec_buf[speclen] = '\0';
5907   if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
5908
5909   /* Have we been working with an expanded, but not resultant, spec? */
5910   /* Also, convert back to Unix syntax if necessary. */
5911   {
5912   int rsl;
5913
5914 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5915     if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5916       rsl = rms_nam_rsll(mynam);
5917     } else
5918 #endif
5919     {
5920       rsl = rms_nam_rsl(mynam);
5921     }
5922     if (!rsl) {
5923       /* rsl is not present, it means that spec_buf is either */
5924       /* esa or esal, and needs to be copied to outbuf */
5925       /* convert to Unix if desired */
5926       if (isunix) {
5927         ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5928       } else {
5929         /* VMS file specs are not in UTF-8 */
5930         if (fs_utf8 != NULL)
5931             *fs_utf8 = 0;
5932         strcpy(outbuf, spec_buf);
5933         ret_spec = outbuf;
5934       }
5935     }
5936     else {
5937       /* Now spec_buf is either outbuf or outbufl */
5938       /* We need the result into outbuf */
5939       if (isunix) {
5940            /* If we need this in UNIX, then we need another buffer */
5941            /* to keep things in order */
5942            char * src;
5943            char * new_src = NULL;
5944            if (spec_buf == outbuf) {
5945                new_src = PerlMem_malloc(VMS_MAXRSS);
5946                strcpy(new_src, spec_buf);
5947            } else {
5948                src = spec_buf;
5949            }
5950            ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5951            if (new_src) {
5952                PerlMem_free(new_src);
5953            }
5954       } else {
5955            /* VMS file specs are not in UTF-8 */
5956            if (fs_utf8 != NULL)
5957                *fs_utf8 = 0;
5958
5959            /* Copy the buffer if needed */
5960            if (outbuf != spec_buf)
5961                strcpy(outbuf, spec_buf);
5962            ret_spec = outbuf;
5963       }
5964     }
5965   }
5966
5967   /* Need to clean up the search context */
5968   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5969   sts = rms_free_search_context(&myfab); /* Free search context */
5970
5971   /* Clean up the extra buffers */
5972   if (esal != NULL)
5973       PerlMem_free(esal);
5974   PerlMem_free(esa);
5975   if (outbufl != NULL)
5976      PerlMem_free(outbufl);
5977
5978   /* Return the result */
5979   return ret_spec;
5980 }
5981
5982 /* Common simple case - Expand an already VMS spec */
5983 static char *
5984 int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5985     opts |= PERL_RMSEXPAND_M_VMS_IN;
5986     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5987 }
5988
5989 /* Common simple case - Expand to a VMS spec */
5990 static char *
5991 int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5992     opts |= PERL_RMSEXPAND_M_VMS;
5993     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5994 }
5995
5996
5997 /* Entry point used by perl routines */
5998 static char *
5999 mp_do_rmsexpand
6000    (pTHX_ const char *filespec,
6001     char *outbuf,
6002     int ts,
6003     const char *defspec,
6004     unsigned opts,
6005     int * fs_utf8,
6006     int * dfs_utf8)
6007 {
6008     static char __rmsexpand_retbuf[VMS_MAXRSS];
6009     char * expanded, *ret_spec, *ret_buf;
6010
6011     expanded = NULL;
6012     ret_buf = outbuf;
6013     if (ret_buf == NULL) {
6014         if (ts) {
6015             Newx(expanded, VMS_MAXRSS, char);
6016             if (expanded == NULL)
6017                 _ckvmssts(SS$_INSFMEM);
6018             ret_buf = expanded;
6019         } else {
6020             ret_buf = __rmsexpand_retbuf;
6021         }
6022     }
6023
6024
6025     ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
6026                              opts, fs_utf8,  dfs_utf8);
6027
6028     if (ret_spec == NULL) {
6029        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6030        if (expanded)
6031            Safefree(expanded);
6032     }
6033
6034     return ret_spec;
6035 }
6036 /*}}}*/
6037 /* External entry points */
6038 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
6039 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
6040 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
6041 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
6042 char *Perl_rmsexpand_utf8
6043   (pTHX_ const char *spec, char *buf, const char *def,
6044    unsigned opt, int * fs_utf8, int * dfs_utf8)
6045 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
6046 char *Perl_rmsexpand_utf8_ts
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,1,def,opt, fs_utf8, dfs_utf8); }
6050
6051
6052 /*
6053 ** The following routines are provided to make life easier when
6054 ** converting among VMS-style and Unix-style directory specifications.
6055 ** All will take input specifications in either VMS or Unix syntax. On
6056 ** failure, all return NULL.  If successful, the routines listed below
6057 ** return a pointer to a buffer containing the appropriately
6058 ** reformatted spec (and, therefore, subsequent calls to that routine
6059 ** will clobber the result), while the routines of the same names with
6060 ** a _ts suffix appended will return a pointer to a mallocd string
6061 ** containing the appropriately reformatted spec.
6062 ** In all cases, only explicit syntax is altered; no check is made that
6063 ** the resulting string is valid or that the directory in question
6064 ** actually exists.
6065 **
6066 **   fileify_dirspec() - convert a directory spec into the name of the
6067 **     directory file (i.e. what you can stat() to see if it's a dir).
6068 **     The style (VMS or Unix) of the result is the same as the style
6069 **     of the parameter passed in.
6070 **   pathify_dirspec() - convert a directory spec into a path (i.e.
6071 **     what you prepend to a filename to indicate what directory it's in).
6072 **     The style (VMS or Unix) of the result is the same as the style
6073 **     of the parameter passed in.
6074 **   tounixpath() - convert a directory spec into a Unix-style path.
6075 **   tovmspath() - convert a directory spec into a VMS-style path.
6076 **   tounixspec() - convert any file spec into a Unix-style file spec.
6077 **   tovmsspec() - convert any file spec into a VMS-style spec.
6078 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
6079 **
6080 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
6081 ** Permission is given to distribute this code as part of the Perl
6082 ** standard distribution under the terms of the GNU General Public
6083 ** License or the Perl Artistic License.  Copies of each may be
6084 ** found in the Perl standard distribution.
6085  */
6086
6087 /*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6088 static char *
6089 int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
6090 {
6091     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
6092     char *cp1, *cp2, *lastdir;
6093     char *trndir, *vmsdir;
6094     unsigned short int trnlnm_iter_count;
6095     int is_vms = 0;
6096     int is_unix = 0;
6097     int sts;
6098     if (utf8_fl != NULL)
6099         *utf8_fl = 0;
6100
6101     if (!dir || !*dir) {
6102       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6103     }
6104     dirlen = strlen(dir);
6105     while (dirlen && dir[dirlen-1] == '/') --dirlen;
6106     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
6107       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
6108         dir = "/sys$disk";
6109         dirlen = 9;
6110       }
6111       else
6112         dirlen = 1;
6113     }
6114     if (dirlen > (VMS_MAXRSS - 1)) {
6115       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
6116       return NULL;
6117     }
6118     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
6119     if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6120     if (!strpbrk(dir+1,"/]>:")  &&
6121         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
6122       strcpy(trndir,*dir == '/' ? dir + 1: dir);
6123       trnlnm_iter_count = 0;
6124       while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
6125         trnlnm_iter_count++;
6126         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6127       }
6128       dirlen = strlen(trndir);
6129     }
6130     else {
6131       strncpy(trndir,dir,dirlen);
6132       trndir[dirlen] = '\0';
6133     }
6134
6135     /* At this point we are done with *dir and use *trndir which is a
6136      * copy that can be modified.  *dir must not be modified.
6137      */
6138
6139     /* If we were handed a rooted logical name or spec, treat it like a
6140      * simple directory, so that
6141      *    $ Define myroot dev:[dir.]
6142      *    ... do_fileify_dirspec("myroot",buf,1) ...
6143      * does something useful.
6144      */
6145     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
6146       trndir[--dirlen] = '\0';
6147       trndir[dirlen-1] = ']';
6148     }
6149     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
6150       trndir[--dirlen] = '\0';
6151       trndir[dirlen-1] = '>';
6152     }
6153
6154     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
6155       /* If we've got an explicit filename, we can just shuffle the string. */
6156       if (*(cp1+1)) hasfilename = 1;
6157       /* Similarly, we can just back up a level if we've got multiple levels
6158          of explicit directories in a VMS spec which ends with directories. */
6159       else {
6160         for (cp2 = cp1; cp2 > trndir; cp2--) {
6161           if (*cp2 == '.') {
6162             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
6163 /* fix-me, can not scan EFS file specs backward like this */
6164               *cp2 = *cp1; *cp1 = '\0';
6165               hasfilename = 1;
6166               break;
6167             }
6168           }
6169           if (*cp2 == '[' || *cp2 == '<') break;
6170         }
6171       }
6172     }
6173
6174     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
6175     if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6176     cp1 = strpbrk(trndir,"]:>");
6177     if (hasfilename || !cp1) { /* filename present or not VMS */
6178
6179       if (decc_efs_charset && !cp1) {
6180
6181           /* EFS handling for UNIX mode */
6182
6183           /* Just remove the trailing '/' and we should be done */
6184           STRLEN trndir_len;
6185           trndir_len = strlen(trndir);
6186
6187           if (trndir_len > 1) {
6188               trndir_len--;
6189               if (trndir[trndir_len] == '/') {
6190                   trndir[trndir_len] = '\0';
6191               }
6192           }
6193           strcpy(buf, trndir);
6194           PerlMem_free(trndir);
6195           PerlMem_free(vmsdir);
6196           return buf;
6197       }
6198
6199       /* For non-EFS mode, this is left for backwards compatibility */
6200       /* For EFS mode, this is only done for VMS format filespecs as */
6201       /* Perl programs generally have problems when a UNIX format spec */
6202       /* returns a VMS format spec */
6203       if (trndir[0] == '.') {
6204         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
6205           PerlMem_free(trndir);
6206           PerlMem_free(vmsdir);
6207           return int_fileify_dirspec("[]", buf, NULL);
6208         }
6209         else if (trndir[1] == '.' &&
6210                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
6211           PerlMem_free(trndir);
6212           PerlMem_free(vmsdir);
6213           return int_fileify_dirspec("[-]", buf, NULL);
6214         }
6215       }
6216       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
6217         dirlen -= 1;                 /* to last element */
6218         lastdir = strrchr(trndir,'/');
6219       }
6220       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
6221         /* If we have "/." or "/..", VMSify it and let the VMS code
6222          * below expand it, rather than repeating the code to handle
6223          * relative components of a filespec here */
6224         do {
6225           if (*(cp1+2) == '.') cp1++;
6226           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
6227             char * ret_chr;
6228             if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
6229                 PerlMem_free(trndir);
6230                 PerlMem_free(vmsdir);
6231                 return NULL;
6232             }
6233             if (strchr(vmsdir,'/') != NULL) {
6234               /* If int_tovmsspec() returned it, it must have VMS syntax
6235                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
6236                * the time to check this here only so we avoid a recursion
6237                * loop; otherwise, gigo.
6238                */
6239               PerlMem_free(trndir);
6240               PerlMem_free(vmsdir);
6241               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
6242               return NULL;
6243             }
6244             if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6245                 PerlMem_free(trndir);
6246                 PerlMem_free(vmsdir);
6247                 return NULL;
6248             }
6249             ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6250             PerlMem_free(trndir);
6251             PerlMem_free(vmsdir);
6252             return ret_chr;
6253           }
6254           cp1++;
6255         } while ((cp1 = strstr(cp1,"/.")) != NULL);
6256         lastdir = strrchr(trndir,'/');
6257       }
6258       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
6259         char * ret_chr;
6260         /* Ditto for specs that end in an MFD -- let the VMS code
6261          * figure out whether it's a real device or a rooted logical. */
6262
6263         /* This should not happen any more.  Allowing the fake /000000
6264          * in a UNIX pathname causes all sorts of problems when trying
6265          * to run in UNIX emulation.  So the VMS to UNIX conversions
6266          * now remove the fake /000000 directories.
6267          */
6268
6269         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6270         if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6271             PerlMem_free(trndir);
6272             PerlMem_free(vmsdir);
6273             return NULL;
6274         }
6275         if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6276             PerlMem_free(trndir);
6277             PerlMem_free(vmsdir);
6278             return NULL;
6279         }
6280         ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6281         PerlMem_free(trndir);
6282         PerlMem_free(vmsdir);
6283         return ret_chr;
6284       }
6285       else {
6286
6287         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6288              !(lastdir = cp1 = strrchr(trndir,']')) &&
6289              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6290
6291         cp2 = strrchr(cp1,'.');
6292         if (cp2) {
6293             int e_len, vs_len = 0;
6294             int is_dir = 0;
6295             char * cp3;
6296             cp3 = strchr(cp2,';');
6297             e_len = strlen(cp2);
6298             if (cp3) {
6299                 vs_len = strlen(cp3);
6300                 e_len = e_len - vs_len;
6301             }
6302             is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6303             if (!is_dir) {
6304                 if (!decc_efs_charset) {
6305                     /* If this is not EFS, then not a directory */
6306                     PerlMem_free(trndir);
6307                     PerlMem_free(vmsdir);
6308                     set_errno(ENOTDIR);
6309                     set_vaxc_errno(RMS$_DIR);
6310                     return NULL;
6311                 }
6312             } else {
6313                 /* Ok, here we have an issue, technically if a .dir shows */
6314                 /* from inside a directory, then we should treat it as */
6315                 /* xxx^.dir.dir.  But we do not have that context at this */
6316                 /* point unless this is totally restructured, so we remove */
6317                 /* The .dir for now, and fix this better later */
6318                 dirlen = cp2 - trndir;
6319             }
6320         }
6321
6322       }
6323
6324       retlen = dirlen + 6;
6325       memcpy(buf, trndir, dirlen);
6326       buf[dirlen] = '\0';
6327
6328       /* We've picked up everything up to the directory file name.
6329          Now just add the type and version, and we're set. */
6330
6331       /* We should only add type for VMS syntax, but historically Perl
6332          has added it for UNIX style also */
6333
6334       /* Fix me - we should not be using the same routine for VMS and
6335          UNIX format files.  Things are too tangled so we need to lookup
6336          what syntax the output is */
6337
6338       is_unix = 0;
6339       is_vms = 0;
6340       lastdir = strrchr(trndir,'/');
6341       if (lastdir) {
6342           is_unix = 1;
6343       } else {
6344           lastdir = strpbrk(trndir,"]:>");
6345           if (lastdir) {
6346               is_vms = 1;
6347           }
6348       }
6349
6350       if ((is_vms == 0) && (is_unix == 0)) {
6351           /* We still do not  know? */
6352           is_unix = decc_filename_unix_report;
6353           if (is_unix == 0)
6354               is_vms = 1;
6355       }
6356
6357       if ((is_unix && !decc_efs_charset) || is_vms) {
6358
6359            /* It is a bug to add a .dir to a UNIX format directory spec */
6360            /* However Perl on VMS may have programs that expect this so */
6361            /* If not using EFS character specifications allow it. */
6362
6363            if ((!decc_efs_case_preserve) && vms_process_case_tolerant) {
6364                /* Traditionally Perl expects filenames in lower case */
6365                strcat(buf, ".dir");
6366            } else {
6367                /* VMS expects the .DIR to be in upper case */
6368                strcat(buf, ".DIR");
6369            }
6370
6371            /* It is also a bug to put a VMS format version on a UNIX file */
6372            /* specification.  Perl self tests are looking for this */
6373            if (is_vms || !(decc_efs_charset || decc_filename_unix_report))
6374                strcat(buf, ";1");
6375       }
6376       PerlMem_free(trndir);
6377       PerlMem_free(vmsdir);
6378       return buf;
6379     }
6380     else {  /* VMS-style directory spec */
6381
6382       char *esa, *esal, term, *cp;
6383       char *my_esa;
6384       int my_esa_len;
6385       unsigned long int sts, cmplen, haslower = 0;
6386       unsigned int nam_fnb;
6387       char * nam_type;
6388       struct FAB dirfab = cc$rms_fab;
6389       rms_setup_nam(savnam);
6390       rms_setup_nam(dirnam);
6391
6392       esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6393       if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6394       esal = NULL;
6395 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6396       esal = PerlMem_malloc(VMS_MAXRSS);
6397       if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6398 #endif
6399       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6400       rms_bind_fab_nam(dirfab, dirnam);
6401       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6402       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6403 #ifdef NAM$M_NO_SHORT_UPCASE
6404       if (decc_efs_case_preserve)
6405         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6406 #endif
6407
6408       for (cp = trndir; *cp; cp++)
6409         if (islower(*cp)) { haslower = 1; break; }
6410       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6411         if ((dirfab.fab$l_sts == RMS$_DIR) ||
6412             (dirfab.fab$l_sts == RMS$_DNF) ||
6413             (dirfab.fab$l_sts == RMS$_PRV)) {
6414             rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6415             sts = sys$parse(&dirfab);
6416         }
6417         if (!sts) {
6418           PerlMem_free(esa);
6419           if (esal != NULL)
6420               PerlMem_free(esal);
6421           PerlMem_free(trndir);
6422           PerlMem_free(vmsdir);
6423           set_errno(EVMSERR);
6424           set_vaxc_errno(dirfab.fab$l_sts);
6425           return NULL;
6426         }
6427       }
6428       else {
6429         savnam = dirnam;
6430         /* Does the file really exist? */
6431         if (sys$search(&dirfab)& STS$K_SUCCESS) {
6432           /* Yes; fake the fnb bits so we'll check type below */
6433           rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6434         }
6435         else { /* No; just work with potential name */
6436           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6437           else {
6438             int fab_sts;
6439             fab_sts = dirfab.fab$l_sts;
6440             sts = rms_free_search_context(&dirfab);
6441             PerlMem_free(esa);
6442             if (esal != NULL)
6443                 PerlMem_free(esal);
6444             PerlMem_free(trndir);
6445             PerlMem_free(vmsdir);
6446             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
6447             return NULL;
6448           }
6449         }
6450       }
6451
6452       /* Make sure we are using the right buffer */
6453 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6454       if (esal != NULL) {
6455         my_esa = esal;
6456         my_esa_len = rms_nam_esll(dirnam);
6457       } else {
6458 #endif
6459         my_esa = esa;
6460         my_esa_len = rms_nam_esl(dirnam);
6461 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6462       }
6463 #endif
6464       my_esa[my_esa_len] = '\0';
6465       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6466         cp1 = strchr(my_esa,']');
6467         if (!cp1) cp1 = strchr(my_esa,'>');
6468         if (cp1) {  /* Should always be true */
6469           my_esa_len -= cp1 - my_esa - 1;
6470           memmove(my_esa, cp1 + 1, my_esa_len);
6471         }
6472       }
6473       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6474         /* Yep; check version while we're at it, if it's there. */
6475         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6476         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6477           /* Something other than .DIR[;1].  Bzzt. */
6478           sts = rms_free_search_context(&dirfab);
6479           PerlMem_free(esa);
6480           if (esal != NULL)
6481              PerlMem_free(esal);
6482           PerlMem_free(trndir);
6483           PerlMem_free(vmsdir);
6484           set_errno(ENOTDIR);
6485           set_vaxc_errno(RMS$_DIR);
6486           return NULL;
6487         }
6488       }
6489
6490       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6491         /* They provided at least the name; we added the type, if necessary, */
6492         strcpy(buf, my_esa);
6493         sts = rms_free_search_context(&dirfab);
6494         PerlMem_free(trndir);
6495         PerlMem_free(esa);
6496         if (esal != NULL)
6497             PerlMem_free(esal);
6498         PerlMem_free(vmsdir);
6499         return buf;
6500       }
6501       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6502         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6503         *cp1 = '\0';
6504         my_esa_len -= 9;
6505       }
6506       if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6507       if (cp1 == NULL) { /* should never happen */
6508         sts = rms_free_search_context(&dirfab);
6509         PerlMem_free(trndir);
6510         PerlMem_free(esa);
6511         if (esal != NULL)
6512             PerlMem_free(esal);
6513         PerlMem_free(vmsdir);
6514         return NULL;
6515       }
6516       term = *cp1;
6517       *cp1 = '\0';
6518       retlen = strlen(my_esa);
6519       cp1 = strrchr(my_esa,'.');
6520       /* ODS-5 directory specifications can have extra "." in them. */
6521       /* Fix-me, can not scan EFS file specifications backwards */
6522       while (cp1 != NULL) {
6523         if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6524           break;
6525         else {
6526            cp1--;
6527            while ((cp1 > my_esa) && (*cp1 != '.'))
6528              cp1--;
6529         }
6530         if (cp1 == my_esa)
6531           cp1 = NULL;
6532       }
6533
6534       if ((cp1) != NULL) {
6535         /* There's more than one directory in the path.  Just roll back. */
6536         *cp1 = term;
6537         strcpy(buf, my_esa);
6538       }
6539       else {
6540         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6541           /* Go back and expand rooted logical name */
6542           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6543 #ifdef NAM$M_NO_SHORT_UPCASE
6544           if (decc_efs_case_preserve)
6545             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6546 #endif
6547           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6548             sts = rms_free_search_context(&dirfab);
6549             PerlMem_free(esa);
6550             if (esal != NULL)
6551                 PerlMem_free(esal);
6552             PerlMem_free(trndir);
6553             PerlMem_free(vmsdir);
6554             set_errno(EVMSERR);
6555             set_vaxc_errno(dirfab.fab$l_sts);
6556             return NULL;
6557           }
6558
6559           /* This changes the length of the string of course */
6560           if (esal != NULL) {
6561               my_esa_len = rms_nam_esll(dirnam);
6562           } else {
6563               my_esa_len = rms_nam_esl(dirnam);
6564           }
6565
6566           retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6567           cp1 = strstr(my_esa,"][");
6568           if (!cp1) cp1 = strstr(my_esa,"]<");
6569           dirlen = cp1 - my_esa;
6570           memcpy(buf, my_esa, dirlen);
6571           if (!strncmp(cp1+2,"000000]",7)) {
6572             buf[dirlen-1] = '\0';
6573             /* fix-me Not full ODS-5, just extra dots in directories for now */
6574             cp1 = buf + dirlen - 1;
6575             while (cp1 > buf)
6576             {
6577               if (*cp1 == '[')
6578                 break;
6579               if (*cp1 == '.') {
6580                 if (*(cp1-1) != '^')
6581                   break;
6582               }
6583               cp1--;
6584             }
6585             if (*cp1 == '.') *cp1 = ']';
6586             else {
6587               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6588               memmove(cp1+1,"000000]",7);
6589             }
6590           }
6591           else {
6592             memmove(buf+dirlen, cp1+2, retlen-dirlen);
6593             buf[retlen] = '\0';
6594             /* Convert last '.' to ']' */
6595             cp1 = buf+retlen-1;
6596             while (*cp != '[') {
6597               cp1--;
6598               if (*cp1 == '.') {
6599                 /* Do not trip on extra dots in ODS-5 directories */
6600                 if ((cp1 == buf) || (*(cp1-1) != '^'))
6601                 break;
6602               }
6603             }
6604             if (*cp1 == '.') *cp1 = ']';
6605             else {
6606               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6607               memmove(cp1+1,"000000]",7);
6608             }
6609           }
6610         }
6611         else {  /* This is a top-level dir.  Add the MFD to the path. */
6612           cp1 = my_esa;
6613           cp2 = buf;
6614           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6615           strcpy(cp2,":[000000]");
6616           cp1 += 2;
6617           strcpy(cp2+9,cp1);
6618         }
6619       }
6620       sts = rms_free_search_context(&dirfab);
6621       /* We've set up the string up through the filename.  Add the
6622          type and version, and we're done. */
6623       strcat(buf,".DIR;1");
6624
6625       /* $PARSE may have upcased filespec, so convert output to lower
6626        * case if input contained any lowercase characters. */
6627       if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
6628       PerlMem_free(trndir);
6629       PerlMem_free(esa);
6630       if (esal != NULL)
6631         PerlMem_free(esal);
6632       PerlMem_free(vmsdir);
6633       return buf;
6634     }
6635 }  /* end of int_fileify_dirspec() */
6636
6637
6638 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6639 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
6640 {
6641     static char __fileify_retbuf[VMS_MAXRSS];
6642     char * fileified, *ret_spec, *ret_buf;
6643
6644     fileified = NULL;
6645     ret_buf = buf;
6646     if (ret_buf == NULL) {
6647         if (ts) {
6648             Newx(fileified, VMS_MAXRSS, char);
6649             if (fileified == NULL)
6650                 _ckvmssts(SS$_INSFMEM);
6651             ret_buf = fileified;
6652         } else {
6653             ret_buf = __fileify_retbuf;
6654         }
6655     }
6656
6657     ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6658
6659     if (ret_spec == NULL) {
6660        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6661        if (fileified)
6662            Safefree(fileified);
6663     }
6664
6665     return ret_spec;
6666 }  /* end of do_fileify_dirspec() */
6667 /*}}}*/
6668
6669 /* External entry points */
6670 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6671 { return do_fileify_dirspec(dir,buf,0,NULL); }
6672 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6673 { return do_fileify_dirspec(dir,buf,1,NULL); }
6674 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6675 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6676 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6677 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6678
6679 static char * int_pathify_dirspec_simple(const char * dir, char * buf,
6680     char * v_spec, int v_len, char * r_spec, int r_len,
6681     char * d_spec, int d_len, char * n_spec, int n_len,
6682     char * e_spec, int e_len, char * vs_spec, int vs_len) {
6683
6684     /* VMS specification - Try to do this the simple way */
6685     if ((v_len + r_len > 0) || (d_len > 0)) {
6686         int is_dir;
6687
6688         /* No name or extension component, already a directory */
6689         if ((n_len + e_len + vs_len) == 0) {
6690             strcpy(buf, dir);
6691             return buf;
6692         }
6693
6694         /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6695         /* This results from catfile() being used instead of catdir() */
6696         /* So even though it should not work, we need to allow it */
6697
6698         /* If this is .DIR;1 then do a simple conversion */
6699         is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6700         if (is_dir || (e_len == 0) && (d_len > 0)) {
6701              int len;
6702              len = v_len + r_len + d_len - 1;
6703              char dclose = d_spec[d_len - 1];
6704              strncpy(buf, dir, len);
6705              buf[len] = '.';
6706              len++;
6707              strncpy(&buf[len], n_spec, n_len);
6708              len += n_len;
6709              buf[len] = dclose;
6710              buf[len + 1] = '\0';
6711              return buf;
6712         }
6713
6714 #ifdef HAS_SYMLINK
6715         else if (d_len > 0) {
6716             /* In the olden days, a directory needed to have a .DIR */
6717             /* extension to be a valid directory, but now it could  */
6718             /* be a symbolic link */
6719             int len;
6720             len = v_len + r_len + d_len - 1;
6721             char dclose = d_spec[d_len - 1];
6722             strncpy(buf, dir, len);
6723             buf[len] = '.';
6724             len++;
6725             strncpy(&buf[len], n_spec, n_len);
6726             len += n_len;
6727             if (e_len > 0) {
6728                 if (decc_efs_charset) {
6729                     buf[len] = '^';
6730                     len++;
6731                     strncpy(&buf[len], e_spec, e_len);
6732                     len += e_len;
6733                 } else {
6734                     set_vaxc_errno(RMS$_DIR);
6735                     set_errno(ENOTDIR);
6736                     return NULL;
6737                 }
6738             }
6739             buf[len] = dclose;
6740             buf[len + 1] = '\0';
6741             return buf;
6742         }
6743 #else
6744         else {
6745             set_vaxc_errno(RMS$_DIR);
6746             set_errno(ENOTDIR);
6747             return NULL;
6748         }
6749 #endif
6750     }
6751     set_vaxc_errno(RMS$_DIR);
6752     set_errno(ENOTDIR);
6753     return NULL;
6754 }
6755
6756
6757 /* Internal routine to make sure or convert a directory to be in a */
6758 /* path specification.  No utf8 flag because it is not changed or used */
6759 static char *int_pathify_dirspec(const char *dir, char *buf)
6760 {
6761     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6762     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6763     char * exp_spec, *ret_spec;
6764     char * trndir;
6765     unsigned short int trnlnm_iter_count;
6766     STRLEN trnlen;
6767     int need_to_lower;
6768
6769     if (vms_debug_fileify) {
6770         if (dir == NULL)
6771             fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6772         else
6773             fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6774     }
6775
6776     /* We may need to lower case the result if we translated  */
6777     /* a logical name or got the current working directory */
6778     need_to_lower = 0;
6779
6780     if (!dir || !*dir) {
6781       set_errno(EINVAL);
6782       set_vaxc_errno(SS$_BADPARAM);
6783       return NULL;
6784     }
6785
6786     trndir = PerlMem_malloc(VMS_MAXRSS);
6787     if (trndir == NULL)
6788         _ckvmssts_noperl(SS$_INSFMEM);
6789
6790     /* If no directory specified use the current default */
6791     if (*dir)
6792         strcpy(trndir, dir);
6793     else {
6794         getcwd(trndir, VMS_MAXRSS - 1);
6795         need_to_lower = 1;
6796     }
6797
6798     /* now deal with bare names that could be logical names */
6799     trnlnm_iter_count = 0;
6800     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6801            && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6802         trnlnm_iter_count++;
6803         need_to_lower = 1;
6804         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6805             break;
6806         trnlen = strlen(trndir);
6807
6808         /* Trap simple rooted lnms, and return lnm:[000000] */
6809         if (!strcmp(trndir+trnlen-2,".]")) {
6810             strcpy(buf, dir);
6811             strcat(buf, ":[000000]");
6812             PerlMem_free(trndir);
6813
6814             if (vms_debug_fileify) {
6815                 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6816             }
6817             return buf;
6818         }
6819     }
6820
6821     /* At this point we do not work with *dir, but the copy in  *trndir */
6822
6823     if (need_to_lower && !decc_efs_case_preserve) {
6824         /* Legacy mode, lower case the returned value */
6825         __mystrtolower(trndir);
6826     }
6827
6828
6829     /* Some special cases, '..', '.' */
6830     sts = 0;
6831     if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6832        /* Force UNIX filespec */
6833        sts = 1;
6834
6835     } else {
6836         /* Is this Unix or VMS format? */
6837         sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6838                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6839                              &e_len, &vs_spec, &vs_len);
6840         if (sts == 0) {
6841
6842             /* Just a filename? */
6843             if ((v_len + r_len + d_len) == 0) {
6844
6845                 /* Now we have a problem, this could be Unix or VMS */
6846                 /* We have to guess.  .DIR usually means VMS */
6847
6848                 /* In UNIX report mode, the .DIR extension is removed */
6849                 /* if one shows up, it is for a non-directory or a directory */
6850                 /* in EFS charset mode */
6851
6852                 /* So if we are in Unix report mode, assume that this */
6853                 /* is a relative Unix directory specification */
6854
6855                 sts = 1;
6856                 if (!decc_filename_unix_report && decc_efs_charset) {
6857                     int is_dir;
6858                     is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6859
6860                     if (is_dir) {
6861                         /* Traditional mode, assume .DIR is directory */
6862                         buf[0] = '[';
6863                         buf[1] = '.';
6864                         strncpy(&buf[2], n_spec, n_len);
6865                         buf[n_len + 2] = ']';
6866                         buf[n_len + 3] = '\0';
6867                         PerlMem_free(trndir);
6868                         if (vms_debug_fileify) {
6869                             fprintf(stderr,
6870                                     "int_pathify_dirspec: buf = %s\n",
6871                                     buf);
6872                         }
6873                         return buf;
6874                     }
6875                 }
6876             }
6877         }
6878     }
6879     if (sts == 0) {
6880         ret_spec = int_pathify_dirspec_simple(trndir, buf,
6881             v_spec, v_len, r_spec, r_len,
6882             d_spec, d_len, n_spec, n_len,
6883             e_spec, e_len, vs_spec, vs_len);
6884
6885         if (ret_spec != NULL) {
6886             PerlMem_free(trndir);
6887             if (vms_debug_fileify) {
6888                 fprintf(stderr,
6889                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6890             }
6891             return ret_spec;
6892         }
6893
6894         /* Simple way did not work, which means that a logical name */
6895         /* was present for the directory specification.             */
6896         /* Need to use an rmsexpand variant to decode it completely */
6897         exp_spec = PerlMem_malloc(VMS_MAXRSS);
6898         if (exp_spec == NULL)
6899             _ckvmssts_noperl(SS$_INSFMEM);
6900
6901         ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6902         if (ret_spec != NULL) {
6903             sts = vms_split_path(exp_spec, &v_spec, &v_len,
6904                                  &r_spec, &r_len, &d_spec, &d_len,
6905                                  &n_spec, &n_len, &e_spec,
6906                                  &e_len, &vs_spec, &vs_len);
6907             if (sts == 0) {
6908                 ret_spec = int_pathify_dirspec_simple(
6909                     exp_spec, buf, v_spec, v_len, r_spec, r_len,
6910                     d_spec, d_len, n_spec, n_len,
6911                     e_spec, e_len, vs_spec, vs_len);
6912
6913                 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6914                     /* Legacy mode, lower case the returned value */
6915                     __mystrtolower(ret_spec);
6916                 }
6917             } else {
6918                 set_vaxc_errno(RMS$_DIR);
6919                 set_errno(ENOTDIR);
6920                 ret_spec = NULL;
6921             }
6922         }
6923         PerlMem_free(exp_spec);
6924         PerlMem_free(trndir);
6925         if (vms_debug_fileify) {
6926             if (ret_spec == NULL)
6927                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6928             else
6929                 fprintf(stderr,
6930                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6931         }
6932         return ret_spec;
6933
6934     } else {
6935         /* Unix specification, Could be trivial conversion */
6936         STRLEN dir_len;
6937         dir_len = strlen(trndir);
6938
6939         /* If the extended file character set is in effect */
6940         /* then pathify is simple */
6941
6942         if (!decc_efs_charset) {
6943             /* Have to deal with traiing '.dir' or extra '.' */
6944             /* that should not be there in legacy mode, but is */
6945
6946             char * lastdot;
6947             char * lastslash;
6948             int is_dir;
6949
6950             lastslash = strrchr(trndir, '/');
6951             if (lastslash == NULL)
6952                 lastslash = trndir;
6953             else
6954                 lastslash++;
6955
6956             lastdot = NULL;
6957
6958             /* '..' or '.' are valid directory components */
6959             is_dir = 0;
6960             if (lastslash[0] == '.') {
6961                 if (lastslash[1] == '\0') {
6962                    is_dir = 1;
6963                 } else if (lastslash[1] == '.') {
6964                     if (lastslash[2] == '\0') {
6965                         is_dir = 1;
6966                     } else {
6967                         /* And finally allow '...' */
6968                         if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
6969                             is_dir = 1;
6970                         }
6971                     }
6972                 }
6973             }
6974
6975             if (!is_dir) {
6976                lastdot = strrchr(lastslash, '.');
6977             }
6978             if (lastdot != NULL) {
6979                 STRLEN e_len;
6980
6981                 /* '.dir' is discarded, and any other '.' is invalid */
6982                 e_len = strlen(lastdot);
6983
6984                 is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
6985
6986                 if (is_dir) {
6987                     dir_len = dir_len - 4;
6988
6989                 }
6990             }
6991         }
6992
6993         strcpy(buf, trndir);
6994         if (buf[dir_len - 1] != '/') {
6995             buf[dir_len] = '/';
6996             buf[dir_len + 1] = '\0';
6997         }
6998
6999         /* Under ODS-2 rules, '.' becomes '_', so fix it up */
7000         if (!decc_efs_charset) {
7001              int dir_start = 0;
7002              char * str = buf;
7003              if (str[0] == '.') {
7004                  char * dots = str;
7005                  int cnt = 1;
7006                  while ((dots[cnt] == '.') && (cnt < 3))
7007                      cnt++;
7008                  if (cnt <= 3) {
7009                      if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
7010                          dir_start = 1;
7011                          str += cnt;
7012                      }
7013                  }
7014              }
7015              for (; *str; ++str) {
7016                  while (*str == '/') {
7017                      dir_start = 1;
7018                      *str++;
7019                  }
7020                  if (dir_start) {
7021
7022                      /* Have to skip up to three dots which could be */
7023                      /* directories, 3 dots being a VMS extension for Perl */
7024                      char * dots = str;
7025                      int cnt = 0;
7026                      while ((dots[cnt] == '.') && (cnt < 3)) {
7027                          cnt++;
7028                      }
7029                      if (dots[cnt] == '\0')
7030                          break;
7031                      if ((cnt > 1) && (dots[cnt] != '/')) {
7032                          dir_start = 0;
7033                      } else {
7034                          str += cnt;
7035                      }
7036
7037                      /* too many dots? */
7038                      if ((cnt == 0) || (cnt > 3)) {
7039                          dir_start = 0;
7040                      }
7041                  }
7042                  if (!dir_start && (*str == '.')) {
7043                      *str = '_';
7044                  }
7045              }
7046         }
7047         PerlMem_free(trndir);
7048         ret_spec = buf;
7049         if (vms_debug_fileify) {
7050             if (ret_spec == NULL)
7051                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
7052             else
7053                 fprintf(stderr,
7054                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
7055         }
7056         return ret_spec;
7057     }
7058 }
7059
7060 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
7061 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
7062 {
7063     static char __pathify_retbuf[VMS_MAXRSS];
7064     char * pathified, *ret_spec, *ret_buf;
7065
7066     pathified = NULL;
7067     ret_buf = buf;
7068     if (ret_buf == NULL) {
7069         if (ts) {
7070             Newx(pathified, VMS_MAXRSS, char);
7071             if (pathified == NULL)
7072                 _ckvmssts(SS$_INSFMEM);
7073             ret_buf = pathified;
7074         } else {
7075             ret_buf = __pathify_retbuf;
7076         }
7077     }
7078
7079     ret_spec = int_pathify_dirspec(dir, ret_buf);
7080
7081     if (ret_spec == NULL) {
7082        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7083        if (pathified)
7084            Safefree(pathified);
7085     }
7086
7087     return ret_spec;
7088
7089 }  /* end of do_pathify_dirspec() */
7090
7091
7092 /* External entry points */
7093 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
7094 { return do_pathify_dirspec(dir,buf,0,NULL); }
7095 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
7096 { return do_pathify_dirspec(dir,buf,1,NULL); }
7097 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
7098 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
7099 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
7100 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
7101
7102 /* Internal tounixspec routine that does not use a thread context */
7103 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
7104 static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
7105 {
7106   char *dirend, *cp1, *cp3, *tmp;
7107   const char *cp2;
7108   int devlen, dirlen, retlen = VMS_MAXRSS;
7109   int expand = 1; /* guarantee room for leading and trailing slashes */
7110   unsigned short int trnlnm_iter_count;
7111   int cmp_rslt;
7112   if (utf8_fl != NULL)
7113     *utf8_fl = 0;
7114
7115   if (vms_debug_fileify) {
7116       if (spec == NULL)
7117           fprintf(stderr, "int_tounixspec: spec = NULL\n");
7118       else
7119           fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
7120   }
7121
7122
7123   if (spec == NULL) {
7124       set_errno(EINVAL);
7125       set_vaxc_errno(SS$_BADPARAM);
7126       return NULL;
7127   }
7128   if (strlen(spec) > (VMS_MAXRSS-1)) {
7129       set_errno(E2BIG);
7130       set_vaxc_errno(SS$_BUFFEROVF);
7131       return NULL;
7132   }
7133
7134   /* New VMS specific format needs translation
7135    * glob passes filenames with trailing '\n' and expects this preserved.
7136    */
7137   if (decc_posix_compliant_pathnames) {
7138     if (strncmp(spec, "\"^UP^", 5) == 0) {
7139       char * uspec;
7140       char *tunix;
7141       int tunix_len;
7142       int nl_flag;
7143
7144       tunix = PerlMem_malloc(VMS_MAXRSS);
7145       if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7146       strcpy(tunix, spec);
7147       tunix_len = strlen(tunix);
7148       nl_flag = 0;
7149       if (tunix[tunix_len - 1] == '\n') {
7150         tunix[tunix_len - 1] = '\"';
7151         tunix[tunix_len] = '\0';
7152         tunix_len--;
7153         nl_flag = 1;
7154       }
7155       uspec = decc$translate_vms(tunix);
7156       PerlMem_free(tunix);
7157       if ((int)uspec > 0) {
7158         strcpy(rslt,uspec);
7159         if (nl_flag) {
7160           strcat(rslt,"\n");
7161         }
7162         else {
7163           /* If we can not translate it, makemaker wants as-is */
7164           strcpy(rslt, spec);
7165         }
7166         return rslt;
7167       }
7168     }
7169   }
7170
7171   cmp_rslt = 0; /* Presume VMS */
7172   cp1 = strchr(spec, '/');
7173   if (cp1 == NULL)
7174     cmp_rslt = 0;
7175
7176     /* Look for EFS ^/ */
7177     if (decc_efs_charset) {
7178       while (cp1 != NULL) {
7179         cp2 = cp1 - 1;
7180         if (*cp2 != '^') {
7181           /* Found illegal VMS, assume UNIX */
7182           cmp_rslt = 1;
7183           break;
7184         }
7185       cp1++;
7186       cp1 = strchr(cp1, '/');
7187     }
7188   }
7189
7190   /* Look for "." and ".." */
7191   if (decc_filename_unix_report) {
7192     if (spec[0] == '.') {
7193       if ((spec[1] == '\0') || (spec[1] == '\n')) {
7194         cmp_rslt = 1;
7195       }
7196       else {
7197         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
7198           cmp_rslt = 1;
7199         }
7200       }
7201     }
7202   }
7203   /* This is already UNIX or at least nothing VMS understands */
7204   if (cmp_rslt) {
7205     strcpy(rslt,spec);
7206     if (vms_debug_fileify) {
7207         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7208     }
7209     return rslt;
7210   }
7211
7212   cp1 = rslt;
7213   cp2 = spec;
7214   dirend = strrchr(spec,']');
7215   if (dirend == NULL) dirend = strrchr(spec,'>');
7216   if (dirend == NULL) dirend = strchr(spec,':');
7217   if (dirend == NULL) {
7218     strcpy(rslt,spec);
7219     if (vms_debug_fileify) {
7220         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7221     }
7222     return rslt;
7223   }
7224
7225   /* Special case 1 - sys$posix_root = / */
7226 #if __CRTL_VER >= 70000000
7227   if (!decc_disable_posix_root) {
7228     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
7229       *cp1 = '/';
7230       cp1++;
7231       cp2 = cp2 + 15;
7232       }
7233   }
7234 #endif
7235
7236   /* Special case 2 - Convert NLA0: to /dev/null */
7237 #if __CRTL_VER < 70000000
7238   cmp_rslt = strncmp(spec,"NLA0:", 5);
7239   if (cmp_rslt != 0)
7240      cmp_rslt = strncmp(spec,"nla0:", 5);
7241 #else
7242   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
7243 #endif
7244   if (cmp_rslt == 0) {
7245     strcpy(rslt, "/dev/null");
7246     cp1 = cp1 + 9;
7247     cp2 = cp2 + 5;
7248     if (spec[6] != '\0') {
7249       cp1[9] == '/';
7250       cp1++;
7251       cp2++;
7252     }
7253   }
7254
7255    /* Also handle special case "SYS$SCRATCH:" */
7256 #if __CRTL_VER < 70000000
7257   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
7258   if (cmp_rslt != 0)
7259      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
7260 #else
7261   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
7262 #endif
7263   tmp = PerlMem_malloc(VMS_MAXRSS);
7264   if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7265   if (cmp_rslt == 0) {
7266   int islnm;
7267
7268     islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
7269     if (!islnm) {
7270       strcpy(rslt, "/tmp");
7271       cp1 = cp1 + 4;
7272       cp2 = cp2 + 12;
7273       if (spec[12] != '\0') {
7274         cp1[4] == '/';
7275         cp1++;
7276         cp2++;
7277       }
7278     }
7279   }
7280
7281   if (*cp2 != '[' && *cp2 != '<') {
7282     *(cp1++) = '/';
7283   }
7284   else {  /* the VMS spec begins with directories */
7285     cp2++;
7286     if (*cp2 == ']' || *cp2 == '>') {
7287       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
7288       PerlMem_free(tmp);
7289       return rslt;
7290     }
7291     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
7292       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
7293         PerlMem_free(tmp);
7294         if (vms_debug_fileify) {
7295             fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7296         }
7297         return NULL;
7298       }
7299       trnlnm_iter_count = 0;
7300       do {
7301         cp3 = tmp;
7302         while (*cp3 != ':' && *cp3) cp3++;
7303         *(cp3++) = '\0';
7304         if (strchr(cp3,']') != NULL) break;
7305         trnlnm_iter_count++;
7306         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7307       } while (vmstrnenv(tmp,tmp,0,fildev,0));
7308       cp1 = rslt;
7309       cp3 = tmp;
7310       *(cp1++) = '/';
7311       while (*cp3) {
7312         *(cp1++) = *(cp3++);
7313         if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7314             PerlMem_free(tmp);
7315             set_errno(ENAMETOOLONG);
7316             set_vaxc_errno(SS$_BUFFEROVF);
7317             if (vms_debug_fileify) {
7318                 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7319             }
7320             return NULL; /* No room */
7321         }
7322       }
7323       *(cp1++) = '/';
7324     }
7325     if ((*cp2 == '^')) {
7326         /* EFS file escape, pass the next character as is */
7327         /* Fix me: HEX encoding for Unicode not implemented */
7328         cp2++;
7329     }
7330     else if ( *cp2 == '.') {
7331       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7332         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7333         cp2 += 3;
7334       }
7335       else cp2++;
7336     }
7337   }
7338   PerlMem_free(tmp);
7339   for (; cp2 <= dirend; cp2++) {
7340     if ((*cp2 == '^')) {
7341         /* EFS file escape, pass the next character as is */
7342         /* Fix me: HEX encoding for Unicode not implemented */
7343         *(cp1++) = *(++cp2);
7344         /* An escaped dot stays as is -- don't convert to slash */
7345         if (*cp2 == '.') cp2++;
7346     }
7347     if (*cp2 == ':') {
7348       *(cp1++) = '/';
7349       if (*(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7350     }
7351     else if (*cp2 == ']' || *cp2 == '>') {
7352       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7353     }
7354     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7355       *(cp1++) = '/';
7356       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7357         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7358                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7359         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7360             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7361       }
7362       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7363         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7364         cp2 += 2;
7365       }
7366     }
7367     else if (*cp2 == '-') {
7368       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7369         while (*cp2 == '-') {
7370           cp2++;
7371           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7372         }
7373         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7374                                                          /* filespecs like */
7375           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
7376           if (vms_debug_fileify) {
7377               fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7378           }
7379           return NULL;
7380         }
7381       }
7382       else *(cp1++) = *cp2;
7383     }
7384     else *(cp1++) = *cp2;
7385   }
7386   /* Translate the rest of the filename. */
7387   while (*cp2) {
7388       int dot_seen;
7389       dot_seen = 0;
7390       switch(*cp2) {
7391       /* Fixme - for compatibility with the CRTL we should be removing */
7392       /* spaces from the file specifications, but this may show that */
7393       /* some tests that were appearing to pass are not really passing */
7394       case '%':
7395           cp2++;
7396           *(cp1++) = '?';
7397           break;
7398       case '^':
7399           /* Fix me hex expansions not implemented */
7400           cp2++;  /* '^.' --> '.' and other. */
7401           if (*cp2) {
7402               if (*cp2 == '_') {
7403                   cp2++;
7404                   *(cp1++) = ' ';
7405               } else {
7406                   *(cp1++) = *(cp2++);
7407               }
7408           }
7409           break;
7410       case ';':
7411           if (decc_filename_unix_no_version) {
7412               /* Easy, drop the version */
7413               while (*cp2)
7414                   cp2++;
7415               break;
7416           } else {
7417               /* Punt - passing the version as a dot will probably */
7418               /* break perl in weird ways, but so did passing */
7419               /* through the ; as a version.  Follow the CRTL and */
7420               /* hope for the best. */
7421               cp2++;
7422               *(cp1++) = '.';
7423           }
7424           break;
7425       case '.':
7426           if (dot_seen) {
7427               /* We will need to fix this properly later */
7428               /* As Perl may be installed on an ODS-5 volume, but not */
7429               /* have the EFS_CHARSET enabled, it still may encounter */
7430               /* filenames with extra dots in them, and a precedent got */
7431               /* set which allowed them to work, that we will uphold here */
7432               /* If extra dots are present in a name and no ^ is on them */
7433               /* VMS assumes that the first one is the extension delimiter */
7434               /* the rest have an implied ^. */
7435
7436               /* this is also a conflict as the . is also a version */
7437               /* delimiter in VMS, */
7438
7439               *(cp1++) = *(cp2++);
7440               break;
7441           }
7442           dot_seen = 1;
7443           /* This is an extension */
7444           if (decc_readdir_dropdotnotype) {
7445               cp2++;
7446               if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7447                   /* Drop the dot for the extension */
7448                   break;
7449               } else {
7450                   *(cp1++) = '.';
7451               }
7452               break;
7453           }
7454       default:
7455           *(cp1++) = *(cp2++);
7456       }
7457   }
7458   *cp1 = '\0';
7459
7460   /* This still leaves /000000/ when working with a
7461    * VMS device root or concealed root.
7462    */
7463   {
7464   int ulen;
7465   char * zeros;
7466
7467       ulen = strlen(rslt);
7468
7469       /* Get rid of "000000/ in rooted filespecs */
7470       if (ulen > 7) {
7471         zeros = strstr(rslt, "/000000/");
7472         if (zeros != NULL) {
7473           int mlen;
7474           mlen = ulen - (zeros - rslt) - 7;
7475           memmove(zeros, &zeros[7], mlen);
7476           ulen = ulen - 7;
7477           rslt[ulen] = '\0';
7478         }
7479       }
7480   }
7481
7482   if (vms_debug_fileify) {
7483       fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7484   }
7485   return rslt;
7486
7487 }  /* end of int_tounixspec() */
7488
7489
7490 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7491 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7492 {
7493     static char __tounixspec_retbuf[VMS_MAXRSS];
7494     char * unixspec, *ret_spec, *ret_buf;
7495
7496     unixspec = NULL;
7497     ret_buf = buf;
7498     if (ret_buf == NULL) {
7499         if (ts) {
7500             Newx(unixspec, VMS_MAXRSS, char);
7501             if (unixspec == NULL)
7502                 _ckvmssts(SS$_INSFMEM);
7503             ret_buf = unixspec;
7504         } else {
7505             ret_buf = __tounixspec_retbuf;
7506         }
7507     }
7508
7509     ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7510
7511     if (ret_spec == NULL) {
7512        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7513        if (unixspec)
7514            Safefree(unixspec);
7515     }
7516
7517     return ret_spec;
7518
7519 }  /* end of do_tounixspec() */
7520 /*}}}*/
7521 /* External entry points */
7522 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
7523   { return do_tounixspec(spec,buf,0, NULL); }
7524 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7525   { return do_tounixspec(spec,buf,1, NULL); }
7526 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7527   { return do_tounixspec(spec,buf,0, utf8_fl); }
7528 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7529   { return do_tounixspec(spec,buf,1, utf8_fl); }
7530
7531 #if __CRTL_VER >= 70200000 && !defined(__VAX)
7532
7533 /*
7534  This procedure is used to identify if a path is based in either
7535  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7536  it returns the OpenVMS format directory for it.
7537
7538  It is expecting specifications of only '/' or '/xxxx/'
7539
7540  If a posix root does not exist, or 'xxxx' is not a directory
7541  in the posix root, it returns a failure.
7542
7543  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7544
7545  It is used only internally by posix_to_vmsspec_hardway().
7546  */
7547
7548 static int posix_root_to_vms
7549   (char *vmspath, int vmspath_len,
7550    const char *unixpath,
7551    const int * utf8_fl)
7552 {
7553 int sts;
7554 struct FAB myfab = cc$rms_fab;
7555 rms_setup_nam(mynam);
7556 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7557 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7558 char * esa, * esal, * rsa, * rsal;
7559 char *vms_delim;
7560 int dir_flag;
7561 int unixlen;
7562
7563     dir_flag = 0;
7564     vmspath[0] = '\0';
7565     unixlen = strlen(unixpath);
7566     if (unixlen == 0) {
7567       return RMS$_FNF;
7568     }
7569
7570 #if __CRTL_VER >= 80200000
7571   /* If not a posix spec already, convert it */
7572   if (decc_posix_compliant_pathnames) {
7573     if (strncmp(unixpath,"\"^UP^",5) != 0) {
7574       sprintf(vmspath,"\"^UP^%s\"",unixpath);
7575     }
7576     else {
7577       /* This is already a VMS specification, no conversion */
7578       unixlen--;
7579       strncpy(vmspath,unixpath, vmspath_len);
7580     }
7581   }
7582   else
7583 #endif
7584   {
7585   int path_len;
7586   int i,j;
7587
7588      /* Check to see if this is under the POSIX root */
7589      if (decc_disable_posix_root) {
7590         return RMS$_FNF;
7591      }
7592
7593      /* Skip leading / */
7594      if (unixpath[0] == '/') {
7595         unixpath++;
7596         unixlen--;
7597      }
7598
7599
7600      strcpy(vmspath,"SYS$POSIX_ROOT:");
7601
7602      /* If this is only the / , or blank, then... */
7603      if (unixpath[0] == '\0') {
7604         /* by definition, this is the answer */
7605         return SS$_NORMAL;
7606      }
7607
7608      /* Need to look up a directory */
7609      vmspath[15] = '[';
7610      vmspath[16] = '\0';
7611
7612      /* Copy and add '^' escape characters as needed */
7613      j = 16;
7614      i = 0;
7615      while (unixpath[i] != 0) {
7616      int k;
7617
7618         j += copy_expand_unix_filename_escape
7619             (&vmspath[j], &unixpath[i], &k, utf8_fl);
7620         i += k;
7621      }
7622
7623      path_len = strlen(vmspath);
7624      if (vmspath[path_len - 1] == '/')
7625         path_len--;
7626      vmspath[path_len] = ']';
7627      path_len++;
7628      vmspath[path_len] = '\0';
7629
7630   }
7631   vmspath[vmspath_len] = 0;
7632   if (unixpath[unixlen - 1] == '/')
7633   dir_flag = 1;
7634   esal = PerlMem_malloc(VMS_MAXRSS);
7635   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7636   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7637   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7638   rsal = PerlMem_malloc(VMS_MAXRSS);
7639   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7640   rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7641   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7642   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7643   rms_bind_fab_nam(myfab, mynam);
7644   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7645   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7646   if (decc_efs_case_preserve)
7647     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7648 #ifdef NAML$M_OPEN_SPECIAL
7649   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7650 #endif
7651
7652   /* Set up the remaining naml fields */
7653   sts = sys$parse(&myfab);
7654
7655   /* It failed! Try again as a UNIX filespec */
7656   if (!(sts & 1)) {
7657     PerlMem_free(esal);
7658     PerlMem_free(esa);
7659     PerlMem_free(rsal);
7660     PerlMem_free(rsa);
7661     return sts;
7662   }
7663
7664    /* get the Device ID and the FID */
7665    sts = sys$search(&myfab);
7666
7667    /* These are no longer needed */
7668    PerlMem_free(esa);
7669    PerlMem_free(rsal);
7670    PerlMem_free(rsa);
7671
7672    /* on any failure, returned the POSIX ^UP^ filespec */
7673    if (!(sts & 1)) {
7674       PerlMem_free(esal);
7675       return sts;
7676    }
7677    specdsc.dsc$a_pointer = vmspath;
7678    specdsc.dsc$w_length = vmspath_len;
7679
7680    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7681    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7682    sts = lib$fid_to_name
7683       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7684
7685   /* on any failure, returned the POSIX ^UP^ filespec */
7686   if (!(sts & 1)) {
7687      /* This can happen if user does not have permission to read directories */
7688      if (strncmp(unixpath,"\"^UP^",5) != 0)
7689        sprintf(vmspath,"\"^UP^%s\"",unixpath);
7690      else
7691        strcpy(vmspath, unixpath);
7692   }
7693   else {
7694     vmspath[specdsc.dsc$w_length] = 0;
7695
7696     /* Are we expecting a directory? */
7697     if (dir_flag != 0) {
7698     int i;
7699     char *eptr;
7700
7701       eptr = NULL;
7702
7703       i = specdsc.dsc$w_length - 1;
7704       while (i > 0) {
7705       int zercnt;
7706         zercnt = 0;
7707         /* Version must be '1' */
7708         if (vmspath[i--] != '1')
7709           break;
7710         /* Version delimiter is one of ".;" */
7711         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7712           break;
7713         i--;
7714         if (vmspath[i--] != 'R')
7715           break;
7716         if (vmspath[i--] != 'I')
7717           break;
7718         if (vmspath[i--] != 'D')
7719           break;
7720         if (vmspath[i--] != '.')
7721           break;
7722         eptr = &vmspath[i+1];
7723         while (i > 0) {
7724           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7725             if (vmspath[i-1] != '^') {
7726               if (zercnt != 6) {
7727                 *eptr = vmspath[i];
7728                 eptr[1] = '\0';
7729                 vmspath[i] = '.';
7730                 break;
7731               }
7732               else {
7733                 /* Get rid of 6 imaginary zero directory filename */
7734                 vmspath[i+1] = '\0';
7735               }
7736             }
7737           }
7738           if (vmspath[i] == '0')
7739             zercnt++;
7740           else
7741             zercnt = 10;
7742           i--;
7743         }
7744         break;
7745       }
7746     }
7747   }
7748   PerlMem_free(esal);
7749   return sts;
7750 }
7751
7752 /* /dev/mumble needs to be handled special.
7753    /dev/null becomes NLA0:, And there is the potential for other stuff
7754    like /dev/tty which may need to be mapped to something.
7755 */
7756
7757 static int
7758 slash_dev_special_to_vms
7759    (const char * unixptr,
7760     char * vmspath,
7761     int vmspath_len)
7762 {
7763 char * nextslash;
7764 int len;
7765 int cmp;
7766 int islnm;
7767
7768     unixptr += 4;
7769     nextslash = strchr(unixptr, '/');
7770     len = strlen(unixptr);
7771     if (nextslash != NULL)
7772         len = nextslash - unixptr;
7773     cmp = strncmp("null", unixptr, 5);
7774     if (cmp == 0) {
7775         if (vmspath_len >= 6) {
7776             strcpy(vmspath, "_NLA0:");
7777             return SS$_NORMAL;
7778         }
7779     }
7780 }
7781
7782
7783 /* The built in routines do not understand perl's special needs, so
7784     doing a manual conversion from UNIX to VMS
7785
7786     If the utf8_fl is not null and points to a non-zero value, then
7787     treat 8 bit characters as UTF-8.
7788
7789     The sequence starting with '$(' and ending with ')' will be passed
7790     through with out interpretation instead of being escaped.
7791
7792   */
7793 static int posix_to_vmsspec_hardway
7794   (char *vmspath, int vmspath_len,
7795    const char *unixpath,
7796    int dir_flag,
7797    int * utf8_fl) {
7798
7799 char *esa;
7800 const char *unixptr;
7801 const char *unixend;
7802 char *vmsptr;
7803 const char *lastslash;
7804 const char *lastdot;
7805 int unixlen;
7806 int vmslen;
7807 int dir_start;
7808 int dir_dot;
7809 int quoted;
7810 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7811 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7812
7813   if (utf8_fl != NULL)
7814     *utf8_fl = 0;
7815
7816   unixptr = unixpath;
7817   dir_dot = 0;
7818
7819   /* Ignore leading "/" characters */
7820   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7821     unixptr++;
7822   }
7823   unixlen = strlen(unixptr);
7824
7825   /* Do nothing with blank paths */
7826   if (unixlen == 0) {
7827     vmspath[0] = '\0';
7828     return SS$_NORMAL;
7829   }
7830
7831   quoted = 0;
7832   /* This could have a "^UP^ on the front */
7833   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7834     quoted = 1;
7835     unixptr+= 5;
7836     unixlen-= 5;
7837   }
7838
7839   lastslash = strrchr(unixptr,'/');
7840   lastdot = strrchr(unixptr,'.');
7841   unixend = strrchr(unixptr,'\"');
7842   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7843     unixend = unixptr + unixlen;
7844   }
7845
7846   /* last dot is last dot or past end of string */
7847   if (lastdot == NULL)
7848     lastdot = unixptr + unixlen;
7849
7850   /* if no directories, set last slash to beginning of string */
7851   if (lastslash == NULL) {
7852     lastslash = unixptr;
7853   }
7854   else {
7855     /* Watch out for trailing "." after last slash, still a directory */
7856     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7857       lastslash = unixptr + unixlen;
7858     }
7859
7860     /* Watch out for traiing ".." after last slash, still a directory */
7861     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7862       lastslash = unixptr + unixlen;
7863     }
7864
7865     /* dots in directories are aways escaped */
7866     if (lastdot < lastslash)
7867       lastdot = unixptr + unixlen;
7868   }
7869
7870   /* if (unixptr < lastslash) then we are in a directory */
7871
7872   dir_start = 0;
7873
7874   vmsptr = vmspath;
7875   vmslen = 0;
7876
7877   /* Start with the UNIX path */
7878   if (*unixptr != '/') {
7879     /* relative paths */
7880
7881     /* If allowing logical names on relative pathnames, then handle here */
7882     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7883         !decc_posix_compliant_pathnames) {
7884     char * nextslash;
7885     int seg_len;
7886     char * trn;
7887     int islnm;
7888
7889         /* Find the next slash */
7890         nextslash = strchr(unixptr,'/');
7891
7892         esa = PerlMem_malloc(vmspath_len);
7893         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7894
7895         trn = PerlMem_malloc(VMS_MAXRSS);
7896         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7897
7898         if (nextslash != NULL) {
7899
7900             seg_len = nextslash - unixptr;
7901             strncpy(esa, unixptr, seg_len);
7902             esa[seg_len] = 0;
7903         }
7904         else {
7905             strcpy(esa, unixptr);
7906             seg_len = strlen(unixptr);
7907         }
7908         /* trnlnm(section) */
7909         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7910
7911         if (islnm) {
7912             /* Now fix up the directory */
7913
7914             /* Split up the path to find the components */
7915             sts = vms_split_path
7916                   (trn,
7917                    &v_spec,
7918                    &v_len,
7919                    &r_spec,
7920                    &r_len,
7921                    &d_spec,
7922                    &d_len,
7923                    &n_spec,
7924                    &n_len,
7925                    &e_spec,
7926                    &e_len,
7927                    &vs_spec,
7928                    &vs_len);
7929
7930             while (sts == 0) {
7931             char * strt;
7932             int cmp;
7933
7934                 /* A logical name must be a directory  or the full
7935                    specification.  It is only a full specification if
7936                    it is the only component */
7937                 if ((unixptr[seg_len] == '\0') ||
7938                     (unixptr[seg_len+1] == '\0')) {
7939
7940                     /* Is a directory being required? */
7941                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7942                         /* Not a logical name */
7943                         break;
7944                     }
7945
7946
7947                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7948                         /* This must be a directory */
7949                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7950                             strcpy(vmsptr, esa);
7951                             vmslen=strlen(vmsptr);
7952                             vmsptr[vmslen] = ':';
7953                             vmslen++;
7954                             vmsptr[vmslen] = '\0';
7955                             return SS$_NORMAL;
7956                         }
7957                     }
7958
7959                 }
7960
7961
7962                 /* must be dev/directory - ignore version */
7963                 if ((n_len + e_len) != 0)
7964                     break;
7965
7966                 /* transfer the volume */
7967                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7968                     strncpy(vmsptr, v_spec, v_len);
7969                     vmsptr += v_len;
7970                     vmsptr[0] = '\0';
7971                     vmslen += v_len;
7972                 }
7973
7974                 /* unroot the rooted directory */
7975                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7976                     r_spec[0] = '[';
7977                     r_spec[r_len - 1] = ']';
7978
7979                     /* This should not be there, but nothing is perfect */
7980                     if (r_len > 9) {
7981                         cmp = strcmp(&r_spec[1], "000000.");
7982                         if (cmp == 0) {
7983                             r_spec += 7;
7984                             r_spec[7] = '[';
7985                             r_len -= 7;
7986                             if (r_len == 2)
7987                                 r_len = 0;
7988                         }
7989                     }
7990                     if (r_len > 0) {
7991                         strncpy(vmsptr, r_spec, r_len);
7992                         vmsptr += r_len;
7993                         vmslen += r_len;
7994                         vmsptr[0] = '\0';
7995                     }
7996                 }
7997                 /* Bring over the directory. */
7998                 if ((d_len > 0) &&
7999                     ((d_len + vmslen) < vmspath_len)) {
8000                     d_spec[0] = '[';
8001                     d_spec[d_len - 1] = ']';
8002                     if (d_len > 9) {
8003                         cmp = strcmp(&d_spec[1], "000000.");
8004                         if (cmp == 0) {
8005                             d_spec += 7;
8006                             d_spec[7] = '[';
8007                             d_len -= 7;
8008                             if (d_len == 2)
8009                                 d_len = 0;
8010                         }
8011                     }
8012
8013                     if (r_len > 0) {
8014                         /* Remove the redundant root */
8015                         if (r_len > 0) {
8016                             /* remove the ][ */
8017                             vmsptr--;
8018                             vmslen--;
8019                             d_spec++;
8020                             d_len--;
8021                         }
8022                         strncpy(vmsptr, d_spec, d_len);
8023                             vmsptr += d_len;
8024                             vmslen += d_len;
8025                             vmsptr[0] = '\0';
8026                     }
8027                 }
8028                 break;
8029             }
8030         }
8031
8032         PerlMem_free(esa);
8033         PerlMem_free(trn);
8034     }
8035
8036     if (lastslash > unixptr) {
8037     int dotdir_seen;
8038
8039       /* skip leading ./ */
8040       dotdir_seen = 0;
8041       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
8042         dotdir_seen = 1;
8043         unixptr++;
8044         unixptr++;
8045       }
8046
8047       /* Are we still in a directory? */
8048       if (unixptr <= lastslash) {
8049         *vmsptr++ = '[';
8050         vmslen = 1;
8051         dir_start = 1;
8052
8053         /* if not backing up, then it is relative forward. */
8054         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
8055               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
8056           *vmsptr++ = '.';
8057           vmslen++;
8058           dir_dot = 1;
8059           }
8060        }
8061        else {
8062          if (dotdir_seen) {
8063            /* Perl wants an empty directory here to tell the difference
8064             * between a DCL commmand and a filename
8065             */
8066           *vmsptr++ = '[';
8067           *vmsptr++ = ']';
8068           vmslen = 2;
8069         }
8070       }
8071     }
8072     else {
8073       /* Handle two special files . and .. */
8074       if (unixptr[0] == '.') {
8075         if (&unixptr[1] == unixend) {
8076           *vmsptr++ = '[';
8077           *vmsptr++ = ']';
8078           vmslen += 2;
8079           *vmsptr++ = '\0';
8080           return SS$_NORMAL;
8081         }
8082         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
8083           *vmsptr++ = '[';
8084           *vmsptr++ = '-';
8085           *vmsptr++ = ']';
8086           vmslen += 3;
8087           *vmsptr++ = '\0';
8088           return SS$_NORMAL;
8089         }
8090       }
8091     }
8092   }
8093   else {        /* Absolute PATH handling */
8094   int sts;
8095   char * nextslash;
8096   int seg_len;
8097     /* Need to find out where root is */
8098
8099     /* In theory, this procedure should never get an absolute POSIX pathname
8100      * that can not be found on the POSIX root.
8101      * In practice, that can not be relied on, and things will show up
8102      * here that are a VMS device name or concealed logical name instead.
8103      * So to make things work, this procedure must be tolerant.
8104      */
8105     esa = PerlMem_malloc(vmspath_len);
8106     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8107
8108     sts = SS$_NORMAL;
8109     nextslash = strchr(&unixptr[1],'/');
8110     seg_len = 0;
8111     if (nextslash != NULL) {
8112     int cmp;
8113       seg_len = nextslash - &unixptr[1];
8114       strncpy(vmspath, unixptr, seg_len + 1);
8115       vmspath[seg_len+1] = 0;
8116       cmp = 1;
8117       if (seg_len == 3) {
8118         cmp = strncmp(vmspath, "dev", 4);
8119         if (cmp == 0) {
8120             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
8121             if (sts = SS$_NORMAL)
8122                 return SS$_NORMAL;
8123         }
8124       }
8125       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
8126     }
8127
8128     if ($VMS_STATUS_SUCCESS(sts)) {
8129       /* This is verified to be a real path */
8130
8131       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
8132       if ($VMS_STATUS_SUCCESS(sts)) {
8133         strcpy(vmspath, esa);
8134         vmslen = strlen(vmspath);
8135         vmsptr = vmspath + vmslen;
8136         unixptr++;
8137         if (unixptr < lastslash) {
8138         char * rptr;
8139           vmsptr--;
8140           *vmsptr++ = '.';
8141           dir_start = 1;
8142           dir_dot = 1;
8143           if (vmslen > 7) {
8144           int cmp;
8145             rptr = vmsptr - 7;
8146             cmp = strcmp(rptr,"000000.");
8147             if (cmp == 0) {
8148               vmslen -= 7;
8149               vmsptr -= 7;
8150               vmsptr[1] = '\0';
8151             } /* removing 6 zeros */
8152           } /* vmslen < 7, no 6 zeros possible */
8153         } /* Not in a directory */
8154       } /* Posix root found */
8155       else {
8156         /* No posix root, fall back to default directory */
8157         strcpy(vmspath, "SYS$DISK:[");
8158         vmsptr = &vmspath[10];
8159         vmslen = 10;
8160         if (unixptr > lastslash) {
8161            *vmsptr = ']';
8162            vmsptr++;
8163            vmslen++;
8164         }
8165         else {
8166            dir_start = 1;
8167         }
8168       }
8169     } /* end of verified real path handling */
8170     else {
8171     int add_6zero;
8172     int islnm;
8173
8174       /* Ok, we have a device or a concealed root that is not in POSIX
8175        * or we have garbage.  Make the best of it.
8176        */
8177
8178       /* Posix to VMS destroyed this, so copy it again */
8179       strncpy(vmspath, &unixptr[1], seg_len);
8180       vmspath[seg_len] = 0;
8181       vmslen = seg_len;
8182       vmsptr = &vmsptr[vmslen];
8183       islnm = 0;
8184
8185       /* Now do we need to add the fake 6 zero directory to it? */
8186       add_6zero = 1;
8187       if ((*lastslash == '/') && (nextslash < lastslash)) {
8188         /* No there is another directory */
8189         add_6zero = 0;
8190       }
8191       else {
8192       int trnend;
8193       int cmp;
8194
8195         /* now we have foo:bar or foo:[000000]bar to decide from */
8196         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
8197
8198         if (!islnm && !decc_posix_compliant_pathnames) {
8199
8200             cmp = strncmp("bin", vmspath, 4);
8201             if (cmp == 0) {
8202                 /* bin => SYS$SYSTEM: */
8203                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
8204             }
8205             else {
8206                 /* tmp => SYS$SCRATCH: */
8207                 cmp = strncmp("tmp", vmspath, 4);
8208                 if (cmp == 0) {
8209                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
8210                 }
8211             }
8212         }
8213
8214         trnend = islnm ? islnm - 1 : 0;
8215
8216         /* if this was a logical name, ']' or '>' must be present */
8217         /* if not a logical name, then assume a device and hope. */
8218         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
8219
8220         /* if log name and trailing '.' then rooted - treat as device */
8221         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
8222
8223         /* Fix me, if not a logical name, a device lookup should be
8224          * done to see if the device is file structured.  If the device
8225          * is not file structured, the 6 zeros should not be put on.
8226          *
8227          * As it is, perl is occasionally looking for dev:[000000]tty.
8228          * which looks a little strange.
8229          *
8230          * Not that easy to detect as "/dev" may be file structured with
8231          * special device files.
8232          */
8233
8234         if (!islnm && (add_6zero == 0) && (*nextslash == '/') &&
8235             (&nextslash[1] == unixend)) {
8236           /* No real directory present */
8237           add_6zero = 1;
8238         }
8239       }
8240
8241       /* Put the device delimiter on */
8242       *vmsptr++ = ':';
8243       vmslen++;
8244       unixptr = nextslash;
8245       unixptr++;
8246
8247       /* Start directory if needed */
8248       if (!islnm || add_6zero) {
8249         *vmsptr++ = '[';
8250         vmslen++;
8251         dir_start = 1;
8252       }
8253
8254       /* add fake 000000] if needed */
8255       if (add_6zero) {
8256         *vmsptr++ = '0';
8257         *vmsptr++ = '0';
8258         *vmsptr++ = '0';
8259         *vmsptr++ = '0';
8260         *vmsptr++ = '0';
8261         *vmsptr++ = '0';
8262         *vmsptr++ = ']';
8263         vmslen += 7;
8264         dir_start = 0;
8265       }
8266
8267     } /* non-POSIX translation */
8268     PerlMem_free(esa);
8269   } /* End of relative/absolute path handling */
8270
8271   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
8272   int dash_flag;
8273   int in_cnt;
8274   int out_cnt;
8275
8276     dash_flag = 0;
8277
8278     if (dir_start != 0) {
8279
8280       /* First characters in a directory are handled special */
8281       while ((*unixptr == '/') ||
8282              ((*unixptr == '.') &&
8283               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8284                 (&unixptr[1]==unixend)))) {
8285       int loop_flag;
8286
8287         loop_flag = 0;
8288
8289         /* Skip redundant / in specification */
8290         while ((*unixptr == '/') && (dir_start != 0)) {
8291           loop_flag = 1;
8292           unixptr++;
8293           if (unixptr == lastslash)
8294             break;
8295         }
8296         if (unixptr == lastslash)
8297           break;
8298
8299         /* Skip redundant ./ characters */
8300         while ((*unixptr == '.') &&
8301                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8302           loop_flag = 1;
8303           unixptr++;
8304           if (unixptr == lastslash)
8305             break;
8306           if (*unixptr == '/')
8307             unixptr++;
8308         }
8309         if (unixptr == lastslash)
8310           break;
8311
8312         /* Skip redundant ../ characters */
8313         while ((*unixptr == '.') && (unixptr[1] == '.') &&
8314              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8315           /* Set the backing up flag */
8316           loop_flag = 1;
8317           dir_dot = 0;
8318           dash_flag = 1;
8319           *vmsptr++ = '-';
8320           vmslen++;
8321           unixptr++; /* first . */
8322           unixptr++; /* second . */
8323           if (unixptr == lastslash)
8324             break;
8325           if (*unixptr == '/') /* The slash */
8326             unixptr++;
8327         }
8328         if (unixptr == lastslash)
8329           break;
8330
8331         /* To do: Perl expects /.../ to be translated to [...] on VMS */
8332         /* Not needed when VMS is pretending to be UNIX. */
8333
8334         /* Is this loop stuck because of too many dots? */
8335         if (loop_flag == 0) {
8336           /* Exit the loop and pass the rest through */
8337           break;
8338         }
8339       }
8340
8341       /* Are we done with directories yet? */
8342       if (unixptr >= lastslash) {
8343
8344         /* Watch out for trailing dots */
8345         if (dir_dot != 0) {
8346             vmslen --;
8347             vmsptr--;
8348         }
8349         *vmsptr++ = ']';
8350         vmslen++;
8351         dash_flag = 0;
8352         dir_start = 0;
8353         if (*unixptr == '/')
8354           unixptr++;
8355       }
8356       else {
8357         /* Have we stopped backing up? */
8358         if (dash_flag) {
8359           *vmsptr++ = '.';
8360           vmslen++;
8361           dash_flag = 0;
8362           /* dir_start continues to be = 1 */
8363         }
8364         if (*unixptr == '-') {
8365           *vmsptr++ = '^';
8366           *vmsptr++ = *unixptr++;
8367           vmslen += 2;
8368           dir_start = 0;
8369
8370           /* Now are we done with directories yet? */
8371           if (unixptr >= lastslash) {
8372
8373             /* Watch out for trailing dots */
8374             if (dir_dot != 0) {
8375               vmslen --;
8376               vmsptr--;
8377             }
8378
8379             *vmsptr++ = ']';
8380             vmslen++;
8381             dash_flag = 0;
8382             dir_start = 0;
8383           }
8384         }
8385       }
8386     }
8387
8388     /* All done? */
8389     if (unixptr >= unixend)
8390       break;
8391
8392     /* Normal characters - More EFS work probably needed */
8393     dir_start = 0;
8394     dir_dot = 0;
8395
8396     switch(*unixptr) {
8397     case '/':
8398         /* remove multiple / */
8399         while (unixptr[1] == '/') {
8400            unixptr++;
8401         }
8402         if (unixptr == lastslash) {
8403           /* Watch out for trailing dots */
8404           if (dir_dot != 0) {
8405             vmslen --;
8406             vmsptr--;
8407           }
8408           *vmsptr++ = ']';
8409         }
8410         else {
8411           dir_start = 1;
8412           *vmsptr++ = '.';
8413           dir_dot = 1;
8414
8415           /* To do: Perl expects /.../ to be translated to [...] on VMS */
8416           /* Not needed when VMS is pretending to be UNIX. */
8417
8418         }
8419         dash_flag = 0;
8420         if (unixptr != unixend)
8421           unixptr++;
8422         vmslen++;
8423         break;
8424     case '.':
8425         if ((unixptr < lastdot) || (unixptr < lastslash) ||
8426             (&unixptr[1] == unixend)) {
8427           *vmsptr++ = '^';
8428           *vmsptr++ = '.';
8429           vmslen += 2;
8430           unixptr++;
8431
8432           /* trailing dot ==> '^..' on VMS */
8433           if (unixptr == unixend) {
8434             *vmsptr++ = '.';
8435             vmslen++;
8436             unixptr++;
8437           }
8438           break;
8439         }
8440
8441         *vmsptr++ = *unixptr++;
8442         vmslen ++;
8443         break;
8444     case '"':
8445         if (quoted && (&unixptr[1] == unixend)) {
8446             unixptr++;
8447             break;
8448         }
8449         in_cnt = copy_expand_unix_filename_escape
8450                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8451         vmsptr += out_cnt;
8452         unixptr += in_cnt;
8453         break;
8454     case '~':
8455     case ';':
8456     case '\\':
8457     case '?':
8458     case ' ':
8459     default:
8460         in_cnt = copy_expand_unix_filename_escape
8461                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8462         vmsptr += out_cnt;
8463         unixptr += in_cnt;
8464         break;
8465     }
8466   }
8467
8468   /* Make sure directory is closed */
8469   if (unixptr == lastslash) {
8470     char *vmsptr2;
8471     vmsptr2 = vmsptr - 1;
8472
8473     if (*vmsptr2 != ']') {
8474       *vmsptr2--;
8475
8476       /* directories do not end in a dot bracket */
8477       if (*vmsptr2 == '.') {
8478         vmsptr2--;
8479
8480         /* ^. is allowed */
8481         if (*vmsptr2 != '^') {
8482           vmsptr--; /* back up over the dot */
8483         }
8484       }
8485       *vmsptr++ = ']';
8486     }
8487   }
8488   else {
8489     char *vmsptr2;
8490     /* Add a trailing dot if a file with no extension */
8491     vmsptr2 = vmsptr - 1;
8492     if ((vmslen > 1) &&
8493         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8494         (*vmsptr2 != ')') && (*lastdot != '.') && (*vmsptr2 != ':')) {
8495         *vmsptr++ = '.';
8496         vmslen++;
8497     }
8498   }
8499
8500   *vmsptr = '\0';
8501   return SS$_NORMAL;
8502 }
8503 #endif
8504
8505  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
8506 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
8507 {
8508 char * result;
8509 int utf8_flag;
8510
8511    /* If a UTF8 flag is being passed, honor it */
8512    utf8_flag = 0;
8513    if (utf8_fl != NULL) {
8514      utf8_flag = *utf8_fl;
8515     *utf8_fl = 0;
8516    }
8517
8518    if (utf8_flag) {
8519      /* If there is a possibility of UTF8, then if any UTF8 characters
8520         are present, then they must be converted to VTF-7
8521       */
8522      result = strcpy(rslt, path); /* FIX-ME */
8523    }
8524    else
8525      result = strcpy(rslt, path);
8526
8527    return result;
8528 }
8529
8530
8531
8532 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8533 static char *int_tovmsspec
8534    (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
8535   char *dirend;
8536   char *lastdot;
8537   char *vms_delim;
8538   register char *cp1;
8539   const char *cp2;
8540   unsigned long int infront = 0, hasdir = 1;
8541   int rslt_len;
8542   int no_type_seen;
8543   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8544   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8545
8546   if (vms_debug_fileify) {
8547       if (path == NULL)
8548           fprintf(stderr, "int_tovmsspec: path = NULL\n");
8549       else
8550           fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8551   }
8552
8553   if (path == NULL) {
8554       /* If we fail, we should be setting errno */
8555       set_errno(EINVAL);
8556       set_vaxc_errno(SS$_BADPARAM);
8557       return NULL;
8558   }
8559   rslt_len = VMS_MAXRSS-1;
8560
8561   /* '.' and '..' are "[]" and "[-]" for a quick check */
8562   if (path[0] == '.') {
8563     if (path[1] == '\0') {
8564       strcpy(rslt,"[]");
8565       if (utf8_flag != NULL)
8566         *utf8_flag = 0;
8567       return rslt;
8568     }
8569     else {
8570       if (path[1] == '.' && path[2] == '\0') {
8571         strcpy(rslt,"[-]");
8572         if (utf8_flag != NULL)
8573            *utf8_flag = 0;
8574         return rslt;
8575       }
8576     }
8577   }
8578
8579    /* Posix specifications are now a native VMS format */
8580   /*--------------------------------------------------*/
8581 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8582   if (decc_posix_compliant_pathnames) {
8583     if (strncmp(path,"\"^UP^",5) == 0) {
8584       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8585       return rslt;
8586     }
8587   }
8588 #endif
8589
8590   /* This is really the only way to see if this is already in VMS format */
8591   sts = vms_split_path
8592        (path,
8593         &v_spec,
8594         &v_len,
8595         &r_spec,
8596         &r_len,
8597         &d_spec,
8598         &d_len,
8599         &n_spec,
8600         &n_len,
8601         &e_spec,
8602         &e_len,
8603         &vs_spec,
8604         &vs_len);
8605   if (sts == 0) {
8606     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8607        replacement, because the above parse just took care of most of
8608        what is needed to do vmspath when the specification is already
8609        in VMS format.
8610
8611        And if it is not already, it is easier to do the conversion as
8612        part of this routine than to call this routine and then work on
8613        the result.
8614      */
8615
8616     /* If VMS punctuation was found, it is already VMS format */
8617     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8618       if (utf8_flag != NULL)
8619         *utf8_flag = 0;
8620       strcpy(rslt, path);
8621       if (vms_debug_fileify) {
8622           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8623       }
8624       return rslt;
8625     }
8626     /* Now, what to do with trailing "." cases where there is no
8627        extension?  If this is a UNIX specification, and EFS characters
8628        are enabled, then the trailing "." should be converted to a "^.".
8629        But if this was already a VMS specification, then it should be
8630        left alone.
8631
8632        So in the case of ambiguity, leave the specification alone.
8633      */
8634
8635
8636     /* If there is a possibility of UTF8, then if any UTF8 characters
8637         are present, then they must be converted to VTF-7
8638      */
8639     if (utf8_flag != NULL)
8640       *utf8_flag = 0;
8641     strcpy(rslt, path);
8642     if (vms_debug_fileify) {
8643         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8644     }
8645     return rslt;
8646   }
8647
8648   dirend = strrchr(path,'/');
8649
8650   if (dirend == NULL) {
8651      char *macro_start;
8652      int has_macro;
8653
8654      /* If we get here with no UNIX directory delimiters, then this is
8655         not a complete file specification, either garbage a UNIX glob
8656         specification that can not be converted to a VMS wildcard, or
8657         it a UNIX shell macro.  MakeMaker wants shell macros passed
8658         through AS-IS,
8659
8660         utf8 flag setting needs to be preserved.
8661       */
8662       hasdir = 0;
8663
8664       has_macro = 0;
8665       macro_start = strchr(path,'$');
8666       if (macro_start != NULL) {
8667           if (macro_start[1] == '(') {
8668               has_macro = 1;
8669           }
8670       }
8671       if ((decc_efs_charset == 0) || (has_macro)) {
8672           strcpy(rslt, path);
8673           if (vms_debug_fileify) {
8674               fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8675           }
8676           return rslt;
8677       }
8678   }
8679
8680 /* If EFS charset mode active, handle the conversion */
8681 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8682   if (decc_efs_charset) {
8683     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8684     if (vms_debug_fileify) {
8685         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8686     }
8687     return rslt;
8688   }
8689 #endif
8690
8691   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
8692     if (!*(dirend+2)) dirend +=2;
8693     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8694     if (decc_efs_charset == 0) {
8695       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8696     }
8697   }
8698
8699   cp1 = rslt;
8700   cp2 = path;
8701   lastdot = strrchr(cp2,'.');
8702   if (*cp2 == '/') {
8703     char *trndev;
8704     int islnm, rooted;
8705     STRLEN trnend;
8706
8707     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8708     if (!*(cp2+1)) {
8709       if (decc_disable_posix_root) {
8710         strcpy(rslt,"sys$disk:[000000]");
8711       }
8712       else {
8713         strcpy(rslt,"sys$posix_root:[000000]");
8714       }
8715       if (utf8_flag != NULL)
8716         *utf8_flag = 0;
8717       if (vms_debug_fileify) {
8718           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8719       }
8720       return rslt;
8721     }
8722     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8723     *cp1 = '\0';
8724     trndev = PerlMem_malloc(VMS_MAXRSS);
8725     if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8726     islnm =  simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8727
8728      /* DECC special handling */
8729     if (!islnm) {
8730       if (strcmp(rslt,"bin") == 0) {
8731         strcpy(rslt,"sys$system");
8732         cp1 = rslt + 10;
8733         *cp1 = 0;
8734         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8735       }
8736       else if (strcmp(rslt,"tmp") == 0) {
8737         strcpy(rslt,"sys$scratch");
8738         cp1 = rslt + 11;
8739         *cp1 = 0;
8740         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8741       }
8742       else if (!decc_disable_posix_root) {
8743         strcpy(rslt, "sys$posix_root");
8744         cp1 = rslt + 14;
8745         *cp1 = 0;
8746         cp2 = path;
8747         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8748         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8749       }
8750       else if (strcmp(rslt,"dev") == 0) {
8751         if (strncmp(cp2,"/null", 5) == 0) {
8752           if ((cp2[5] == 0) || (cp2[5] == '/')) {
8753             strcpy(rslt,"NLA0");
8754             cp1 = rslt + 4;
8755             *cp1 = 0;
8756             cp2 = cp2 + 5;
8757             islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8758           }
8759         }
8760       }
8761     }
8762
8763     trnend = islnm ? strlen(trndev) - 1 : 0;
8764     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8765     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8766     /* If the first element of the path is a logical name, determine
8767      * whether it has to be translated so we can add more directories. */
8768     if (!islnm || rooted) {
8769       *(cp1++) = ':';
8770       *(cp1++) = '[';
8771       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8772       else cp2++;
8773     }
8774     else {
8775       if (cp2 != dirend) {
8776         strcpy(rslt,trndev);
8777         cp1 = rslt + trnend;
8778         if (*cp2 != 0) {
8779           *(cp1++) = '.';
8780           cp2++;
8781         }
8782       }
8783       else {
8784         if (decc_disable_posix_root) {
8785           *(cp1++) = ':';
8786           hasdir = 0;
8787         }
8788       }
8789     }
8790     PerlMem_free(trndev);
8791   }
8792   else {
8793     *(cp1++) = '[';
8794     if (*cp2 == '.') {
8795       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8796         cp2 += 2;         /* skip over "./" - it's redundant */
8797         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8798       }
8799       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8800         *(cp1++) = '-';                                 /* "../" --> "-" */
8801         cp2 += 3;
8802       }
8803       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8804                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8805         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8806         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8807         cp2 += 4;
8808       }
8809       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8810         /* Escape the extra dots in EFS file specifications */
8811         *(cp1++) = '^';
8812       }
8813       if (cp2 > dirend) cp2 = dirend;
8814     }
8815     else *(cp1++) = '.';
8816   }
8817   for (; cp2 < dirend; cp2++) {
8818     if (*cp2 == '/') {
8819       if (*(cp2-1) == '/') continue;
8820       if (*(cp1-1) != '.') *(cp1++) = '.';
8821       infront = 0;
8822     }
8823     else if (!infront && *cp2 == '.') {
8824       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8825       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8826       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8827         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8828         else if (*(cp1-2) == '[') *(cp1-1) = '-';
8829         else {  /* back up over previous directory name */
8830           cp1--;
8831           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
8832           if (*(cp1-1) == '[') {
8833             memcpy(cp1,"000000.",7);
8834             cp1 += 7;
8835           }
8836         }
8837         cp2 += 2;
8838         if (cp2 == dirend) break;
8839       }
8840       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8841                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8842         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8843         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8844         if (!*(cp2+3)) {
8845           *(cp1++) = '.';  /* Simulate trailing '/' */
8846           cp2 += 2;  /* for loop will incr this to == dirend */
8847         }
8848         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8849       }
8850       else {
8851         if (decc_efs_charset == 0)
8852           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8853         else {
8854           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
8855           *(cp1++) = '.';
8856         }
8857       }
8858     }
8859     else {
8860       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
8861       if (*cp2 == '.') {
8862         if (decc_efs_charset == 0)
8863           *(cp1++) = '_';
8864         else {
8865           *(cp1++) = '^';
8866           *(cp1++) = '.';
8867         }
8868       }
8869       else                  *(cp1++) =  *cp2;
8870       infront = 1;
8871     }
8872   }
8873   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8874   if (hasdir) *(cp1++) = ']';
8875   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
8876   /* fixme for ODS5 */
8877   no_type_seen = 0;
8878   if (cp2 > lastdot)
8879     no_type_seen = 1;
8880   while (*cp2) {
8881     switch(*cp2) {
8882     case '?':
8883         if (decc_efs_charset == 0)
8884           *(cp1++) = '%';
8885         else
8886           *(cp1++) = '?';
8887         cp2++;
8888     case ' ':
8889         *(cp1)++ = '^';
8890         *(cp1)++ = '_';
8891         cp2++;
8892         break;
8893     case '.':
8894         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8895             decc_readdir_dropdotnotype) {
8896           *(cp1)++ = '^';
8897           *(cp1)++ = '.';
8898           cp2++;
8899
8900           /* trailing dot ==> '^..' on VMS */
8901           if (*cp2 == '\0') {
8902             *(cp1++) = '.';
8903             no_type_seen = 0;
8904           }
8905         }
8906         else {
8907           *(cp1++) = *(cp2++);
8908           no_type_seen = 0;
8909         }
8910         break;
8911     case '$':
8912          /* This could be a macro to be passed through */
8913         *(cp1++) = *(cp2++);
8914         if (*cp2 == '(') {
8915         const char * save_cp2;
8916         char * save_cp1;
8917         int is_macro;
8918
8919             /* paranoid check */
8920             save_cp2 = cp2;
8921             save_cp1 = cp1;
8922             is_macro = 0;
8923
8924             /* Test through */
8925             *(cp1++) = *(cp2++);
8926             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8927                 *(cp1++) = *(cp2++);
8928                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8929                     *(cp1++) = *(cp2++);
8930                 }
8931                 if (*cp2 == ')') {
8932                     *(cp1++) = *(cp2++);
8933                     is_macro = 1;
8934                 }
8935             }
8936             if (is_macro == 0) {
8937                 /* Not really a macro - never mind */
8938                 cp2 = save_cp2;
8939                 cp1 = save_cp1;
8940             }
8941         }
8942         break;
8943     case '\"':
8944     case '~':
8945     case '`':
8946     case '!':
8947     case '#':
8948     case '%':
8949     case '^':
8950         /* Don't escape again if following character is
8951          * already something we escape.
8952          */
8953         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8954             *(cp1++) = *(cp2++);
8955             break;
8956         }
8957         /* But otherwise fall through and escape it. */
8958     case '&':
8959     case '(':
8960     case ')':
8961     case '=':
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         *(cp1++) = '^';
8975         *(cp1++) = *(cp2++);
8976         break;
8977     case ';':
8978         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8979          * which is wrong.  UNIX notation should be ".dir." unless
8980          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8981          * changing this behavior could break more things at this time.
8982          * efs character set effectively does not allow "." to be a version
8983          * delimiter as a further complication about changing this.
8984          */
8985         if (decc_filename_unix_report != 0) {
8986           *(cp1++) = '^';
8987         }
8988         *(cp1++) = *(cp2++);
8989         break;
8990     default:
8991         *(cp1++) = *(cp2++);
8992     }
8993   }
8994   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8995   char *lcp1;
8996     lcp1 = cp1;
8997     lcp1--;
8998      /* Fix me for "^]", but that requires making sure that you do
8999       * not back up past the start of the filename
9000       */
9001     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
9002       *cp1++ = '.';
9003   }
9004   *cp1 = '\0';
9005
9006   if (utf8_flag != NULL)
9007     *utf8_flag = 0;
9008   if (vms_debug_fileify) {
9009       fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
9010   }
9011   return rslt;
9012
9013 }  /* end of int_tovmsspec() */
9014
9015
9016 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
9017 static char *mp_do_tovmsspec
9018    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
9019   static char __tovmsspec_retbuf[VMS_MAXRSS];
9020     char * vmsspec, *ret_spec, *ret_buf;
9021
9022     vmsspec = NULL;
9023     ret_buf = buf;
9024     if (ret_buf == NULL) {
9025         if (ts) {
9026             Newx(vmsspec, VMS_MAXRSS, char);
9027             if (vmsspec == NULL)
9028                 _ckvmssts(SS$_INSFMEM);
9029             ret_buf = vmsspec;
9030         } else {
9031             ret_buf = __tovmsspec_retbuf;
9032         }
9033     }
9034
9035     ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
9036
9037     if (ret_spec == NULL) {
9038        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
9039        if (vmsspec)
9040            Safefree(vmsspec);
9041     }
9042
9043     return ret_spec;
9044
9045 }  /* end of mp_do_tovmsspec() */
9046 /*}}}*/
9047 /* External entry points */
9048 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
9049   { return do_tovmsspec(path,buf,0,NULL); }
9050 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
9051   { return do_tovmsspec(path,buf,1,NULL); }
9052 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9053   { return do_tovmsspec(path,buf,0,utf8_fl); }
9054 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9055   { return do_tovmsspec(path,buf,1,utf8_fl); }
9056
9057 /*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
9058 /* Internal routine for use with out an explict context present */
9059 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl) {
9060
9061     char * ret_spec, *pathified;
9062
9063     if (path == NULL)
9064         return NULL;
9065
9066     pathified = PerlMem_malloc(VMS_MAXRSS);
9067     if (pathified == NULL)
9068         _ckvmssts_noperl(SS$_INSFMEM);
9069
9070     ret_spec = int_pathify_dirspec(path, pathified);
9071
9072     if (ret_spec == NULL) {
9073         PerlMem_free(pathified);
9074         return NULL;
9075     }
9076
9077     ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
9078
9079     PerlMem_free(pathified);
9080     return ret_spec;
9081
9082 }
9083
9084 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
9085 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
9086   static char __tovmspath_retbuf[VMS_MAXRSS];
9087   int vmslen;
9088   char *pathified, *vmsified, *cp;
9089
9090   if (path == NULL) return NULL;
9091   pathified = PerlMem_malloc(VMS_MAXRSS);
9092   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
9093   if (int_pathify_dirspec(path, pathified) == NULL) {
9094     PerlMem_free(pathified);
9095     return NULL;
9096   }
9097
9098   vmsified = NULL;
9099   if (buf == NULL)
9100      Newx(vmsified, VMS_MAXRSS, char);
9101   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
9102     PerlMem_free(pathified);
9103     if (vmsified) Safefree(vmsified);
9104     return NULL;
9105   }
9106   PerlMem_free(pathified);
9107   if (buf) {
9108     return buf;
9109   }
9110   else if (ts) {
9111     vmslen = strlen(vmsified);
9112     Newx(cp,vmslen+1,char);
9113     memcpy(cp,vmsified,vmslen);
9114     cp[vmslen] = '\0';
9115     Safefree(vmsified);
9116     return cp;
9117   }
9118   else {
9119     strcpy(__tovmspath_retbuf,vmsified);
9120     Safefree(vmsified);
9121     return __tovmspath_retbuf;
9122   }
9123
9124 }  /* end of do_tovmspath() */
9125 /*}}}*/
9126 /* External entry points */
9127 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
9128   { return do_tovmspath(path,buf,0, NULL); }
9129 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
9130   { return do_tovmspath(path,buf,1, NULL); }
9131 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
9132   { return do_tovmspath(path,buf,0,utf8_fl); }
9133 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
9134   { return do_tovmspath(path,buf,1,utf8_fl); }
9135
9136
9137 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
9138 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
9139   static char __tounixpath_retbuf[VMS_MAXRSS];
9140   int unixlen;
9141   char *pathified, *unixified, *cp;
9142
9143   if (path == NULL) return NULL;
9144   pathified = PerlMem_malloc(VMS_MAXRSS);
9145   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
9146   if (int_pathify_dirspec(path, pathified) == NULL) {
9147     PerlMem_free(pathified);
9148     return NULL;
9149   }
9150
9151   unixified = NULL;
9152   if (buf == NULL) {
9153       Newx(unixified, VMS_MAXRSS, char);
9154   }
9155   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
9156     PerlMem_free(pathified);
9157     if (unixified) Safefree(unixified);
9158     return NULL;
9159   }
9160   PerlMem_free(pathified);
9161   if (buf) {
9162     return buf;
9163   }
9164   else if (ts) {
9165     unixlen = strlen(unixified);
9166     Newx(cp,unixlen+1,char);
9167     memcpy(cp,unixified,unixlen);
9168     cp[unixlen] = '\0';
9169     Safefree(unixified);
9170     return cp;
9171   }
9172   else {
9173     strcpy(__tounixpath_retbuf,unixified);
9174     Safefree(unixified);
9175     return __tounixpath_retbuf;
9176   }
9177
9178 }  /* end of do_tounixpath() */
9179 /*}}}*/
9180 /* External entry points */
9181 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
9182   { return do_tounixpath(path,buf,0,NULL); }
9183 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
9184   { return do_tounixpath(path,buf,1,NULL); }
9185 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9186   { return do_tounixpath(path,buf,0,utf8_fl); }
9187 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9188   { return do_tounixpath(path,buf,1,utf8_fl); }
9189
9190 /*
9191  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
9192  *
9193  *****************************************************************************
9194  *                                                                           *
9195  *  Copyright (C) 1989-1994, 2007 by                                         *
9196  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
9197  *                                                                           *
9198  *  Permission is hereby granted for the reproduction of this software       *
9199  *  on condition that this copyright notice is included in source            *
9200  *  distributions of the software.  The code may be modified and             *
9201  *  distributed under the same terms as Perl itself.                         *
9202  *                                                                           *
9203  *  27-Aug-1994 Modified for inclusion in perl5                              *
9204  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
9205  *****************************************************************************
9206  */
9207
9208 /*
9209  * getredirection() is intended to aid in porting C programs
9210  * to VMS (Vax-11 C).  The native VMS environment does not support
9211  * '>' and '<' I/O redirection, or command line wild card expansion,
9212  * or a command line pipe mechanism using the '|' AND background
9213  * command execution '&'.  All of these capabilities are provided to any
9214  * C program which calls this procedure as the first thing in the
9215  * main program.
9216  * The piping mechanism will probably work with almost any 'filter' type
9217  * of program.  With suitable modification, it may useful for other
9218  * portability problems as well.
9219  *
9220  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
9221  */
9222 struct list_item
9223     {
9224     struct list_item *next;
9225     char *value;
9226     };
9227
9228 static void add_item(struct list_item **head,
9229                      struct list_item **tail,
9230                      char *value,
9231                      int *count);
9232
9233 static void mp_expand_wild_cards(pTHX_ char *item,
9234                                 struct list_item **head,
9235                                 struct list_item **tail,
9236                                 int *count);
9237
9238 static int background_process(pTHX_ int argc, char **argv);
9239
9240 static void pipe_and_fork(pTHX_ char **cmargv);
9241
9242 /*{{{ void getredirection(int *ac, char ***av)*/
9243 static void
9244 mp_getredirection(pTHX_ int *ac, char ***av)
9245 /*
9246  * Process vms redirection arg's.  Exit if any error is seen.
9247  * If getredirection() processes an argument, it is erased
9248  * from the vector.  getredirection() returns a new argc and argv value.
9249  * In the event that a background command is requested (by a trailing "&"),
9250  * this routine creates a background subprocess, and simply exits the program.
9251  *
9252  * Warning: do not try to simplify the code for vms.  The code
9253  * presupposes that getredirection() is called before any data is
9254  * read from stdin or written to stdout.
9255  *
9256  * Normal usage is as follows:
9257  *
9258  *      main(argc, argv)
9259  *      int             argc;
9260  *      char            *argv[];
9261  *      {
9262  *              getredirection(&argc, &argv);
9263  *      }
9264  */
9265 {
9266     int                 argc = *ac;     /* Argument Count         */
9267     char                **argv = *av;   /* Argument Vector        */
9268     char                *ap;            /* Argument pointer       */
9269     int                 j;              /* argv[] index           */
9270     int                 item_count = 0; /* Count of Items in List */
9271     struct list_item    *list_head = 0; /* First Item in List       */
9272     struct list_item    *list_tail;     /* Last Item in List        */
9273     char                *in = NULL;     /* Input File Name          */
9274     char                *out = NULL;    /* Output File Name         */
9275     char                *outmode = "w"; /* Mode to Open Output File */
9276     char                *err = NULL;    /* Error File Name          */
9277     char                *errmode = "w"; /* Mode to Open Error File  */
9278     int                 cmargc = 0;     /* Piped Command Arg Count  */
9279     char                **cmargv = NULL;/* Piped Command Arg Vector */
9280
9281     /*
9282      * First handle the case where the last thing on the line ends with
9283      * a '&'.  This indicates the desire for the command to be run in a
9284      * subprocess, so we satisfy that desire.
9285      */
9286     ap = argv[argc-1];
9287     if (0 == strcmp("&", ap))
9288        exit(background_process(aTHX_ --argc, argv));
9289     if (*ap && '&' == ap[strlen(ap)-1])
9290         {
9291         ap[strlen(ap)-1] = '\0';
9292        exit(background_process(aTHX_ argc, argv));
9293         }
9294     /*
9295      * Now we handle the general redirection cases that involve '>', '>>',
9296      * '<', and pipes '|'.
9297      */
9298     for (j = 0; j < argc; ++j)
9299         {
9300         if (0 == strcmp("<", argv[j]))
9301             {
9302             if (j+1 >= argc)
9303                 {
9304                 fprintf(stderr,"No input file after < on command line");
9305                 exit(LIB$_WRONUMARG);
9306                 }
9307             in = argv[++j];
9308             continue;
9309             }
9310         if ('<' == *(ap = argv[j]))
9311             {
9312             in = 1 + ap;
9313             continue;
9314             }
9315         if (0 == strcmp(">", ap))
9316             {
9317             if (j+1 >= argc)
9318                 {
9319                 fprintf(stderr,"No output file after > on command line");
9320                 exit(LIB$_WRONUMARG);
9321                 }
9322             out = argv[++j];
9323             continue;
9324             }
9325         if ('>' == *ap)
9326             {
9327             if ('>' == ap[1])
9328                 {
9329                 outmode = "a";
9330                 if ('\0' == ap[2])
9331                     out = argv[++j];
9332                 else
9333                     out = 2 + ap;
9334                 }
9335             else
9336                 out = 1 + ap;
9337             if (j >= argc)
9338                 {
9339                 fprintf(stderr,"No output file after > or >> on command line");
9340                 exit(LIB$_WRONUMARG);
9341                 }
9342             continue;
9343             }
9344         if (('2' == *ap) && ('>' == ap[1]))
9345             {
9346             if ('>' == ap[2])
9347                 {
9348                 errmode = "a";
9349                 if ('\0' == ap[3])
9350                     err = argv[++j];
9351                 else
9352                     err = 3 + ap;
9353                 }
9354             else
9355                 if ('\0' == ap[2])
9356                     err = argv[++j];
9357                 else
9358                     err = 2 + ap;
9359             if (j >= argc)
9360                 {
9361                 fprintf(stderr,"No output file after 2> or 2>> on command line");
9362                 exit(LIB$_WRONUMARG);
9363                 }
9364             continue;
9365             }
9366         if (0 == strcmp("|", argv[j]))
9367             {
9368             if (j+1 >= argc)
9369                 {
9370                 fprintf(stderr,"No command into which to pipe on command line");
9371                 exit(LIB$_WRONUMARG);
9372                 }
9373             cmargc = argc-(j+1);
9374             cmargv = &argv[j+1];
9375             argc = j;
9376             continue;
9377             }
9378         if ('|' == *(ap = argv[j]))
9379             {
9380             ++argv[j];
9381             cmargc = argc-j;
9382             cmargv = &argv[j];
9383             argc = j;
9384             continue;
9385             }
9386         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9387         }
9388     /*
9389      * Allocate and fill in the new argument vector, Some Unix's terminate
9390      * the list with an extra null pointer.
9391      */
9392     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9393     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9394     *av = argv;
9395     for (j = 0; j < item_count; ++j, list_head = list_head->next)
9396         argv[j] = list_head->value;
9397     *ac = item_count;
9398     if (cmargv != NULL)
9399         {
9400         if (out != NULL)
9401             {
9402             fprintf(stderr,"'|' and '>' may not both be specified on command line");
9403             exit(LIB$_INVARGORD);
9404             }
9405         pipe_and_fork(aTHX_ cmargv);
9406         }
9407
9408     /* Check for input from a pipe (mailbox) */
9409
9410     if (in == NULL && 1 == isapipe(0))
9411         {
9412         char mbxname[L_tmpnam];
9413         long int bufsize;
9414         long int dvi_item = DVI$_DEVBUFSIZ;
9415         $DESCRIPTOR(mbxnam, "");
9416         $DESCRIPTOR(mbxdevnam, "");
9417
9418         /* Input from a pipe, reopen it in binary mode to disable       */
9419         /* carriage control processing.                                 */
9420
9421         fgetname(stdin, mbxname, 1);
9422         mbxnam.dsc$a_pointer = mbxname;
9423         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9424         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9425         mbxdevnam.dsc$a_pointer = mbxname;
9426         mbxdevnam.dsc$w_length = sizeof(mbxname);
9427         dvi_item = DVI$_DEVNAM;
9428         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9429         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9430         set_errno(0);
9431         set_vaxc_errno(1);
9432         freopen(mbxname, "rb", stdin);
9433         if (errno != 0)
9434             {
9435             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9436             exit(vaxc$errno);
9437             }
9438         }
9439     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9440         {
9441         fprintf(stderr,"Can't open input file %s as stdin",in);
9442         exit(vaxc$errno);
9443         }
9444     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9445         {
9446         fprintf(stderr,"Can't open output file %s as stdout",out);
9447         exit(vaxc$errno);
9448         }
9449         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
9450
9451     if (err != NULL) {
9452         if (strcmp(err,"&1") == 0) {
9453             dup2(fileno(stdout), fileno(stderr));
9454             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
9455         } else {
9456         FILE *tmperr;
9457         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9458             {
9459             fprintf(stderr,"Can't open error file %s as stderr",err);
9460             exit(vaxc$errno);
9461             }
9462             fclose(tmperr);
9463            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9464                 {
9465                 exit(vaxc$errno);
9466                 }
9467             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
9468         }
9469         }
9470 #ifdef ARGPROC_DEBUG
9471     PerlIO_printf(Perl_debug_log, "Arglist:\n");
9472     for (j = 0; j < *ac;  ++j)
9473         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9474 #endif
9475    /* Clear errors we may have hit expanding wildcards, so they don't
9476       show up in Perl's $! later */
9477    set_errno(0); set_vaxc_errno(1);
9478 }  /* end of getredirection() */
9479 /*}}}*/
9480
9481 static void add_item(struct list_item **head,
9482                      struct list_item **tail,
9483                      char *value,
9484                      int *count)
9485 {
9486     if (*head == 0)
9487         {
9488         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9489         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9490         *tail = *head;
9491         }
9492     else {
9493         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9494         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9495         *tail = (*tail)->next;
9496         }
9497     (*tail)->value = value;
9498     ++(*count);
9499 }
9500
9501 static void mp_expand_wild_cards(pTHX_ char *item,
9502                               struct list_item **head,
9503                               struct list_item **tail,
9504                               int *count)
9505 {
9506 int expcount = 0;
9507 unsigned long int context = 0;
9508 int isunix = 0;
9509 int item_len = 0;
9510 char *had_version;
9511 char *had_device;
9512 int had_directory;
9513 char *devdir,*cp;
9514 char *vmsspec;
9515 $DESCRIPTOR(filespec, "");
9516 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9517 $DESCRIPTOR(resultspec, "");
9518 unsigned long int lff_flags = 0;
9519 int sts;
9520 int rms_sts;
9521
9522 #ifdef VMS_LONGNAME_SUPPORT
9523     lff_flags = LIB$M_FIL_LONG_NAMES;
9524 #endif
9525
9526     for (cp = item; *cp; cp++) {
9527         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9528         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9529     }
9530     if (!*cp || isspace(*cp))
9531         {
9532         add_item(head, tail, item, count);
9533         return;
9534         }
9535     else
9536         {
9537      /* "double quoted" wild card expressions pass as is */
9538      /* From DCL that means using e.g.:                  */
9539      /* perl program """perl.*"""                        */
9540      item_len = strlen(item);
9541      if ( '"' == *item && '"' == item[item_len-1] )
9542        {
9543        item++;
9544        item[item_len-2] = '\0';
9545        add_item(head, tail, item, count);
9546        return;
9547        }
9548      }
9549     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9550     resultspec.dsc$b_class = DSC$K_CLASS_D;
9551     resultspec.dsc$a_pointer = NULL;
9552     vmsspec = PerlMem_malloc(VMS_MAXRSS);
9553     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9554     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9555       filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9556     if (!isunix || !filespec.dsc$a_pointer)
9557       filespec.dsc$a_pointer = item;
9558     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9559     /*
9560      * Only return version specs, if the caller specified a version
9561      */
9562     had_version = strchr(item, ';');
9563     /*
9564      * Only return device and directory specs, if the caller specifed either.
9565      */
9566     had_device = strchr(item, ':');
9567     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9568
9569     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9570                                  (&filespec, &resultspec, &context,
9571                                   &defaultspec, 0, &rms_sts, &lff_flags)))
9572         {
9573         char *string;
9574         char *c;
9575
9576         string = PerlMem_malloc(resultspec.dsc$w_length+1);
9577         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9578         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
9579         string[resultspec.dsc$w_length] = '\0';
9580         if (NULL == had_version)
9581             *(strrchr(string, ';')) = '\0';
9582         if ((!had_directory) && (had_device == NULL))
9583             {
9584             if (NULL == (devdir = strrchr(string, ']')))
9585                 devdir = strrchr(string, '>');
9586             strcpy(string, devdir + 1);
9587             }
9588         /*
9589          * Be consistent with what the C RTL has already done to the rest of
9590          * the argv items and lowercase all of these names.
9591          */
9592         if (!decc_efs_case_preserve) {
9593             for (c = string; *c; ++c)
9594             if (isupper(*c))
9595                 *c = tolower(*c);
9596         }
9597         if (isunix) trim_unixpath(string,item,1);
9598         add_item(head, tail, string, count);
9599         ++expcount;
9600     }
9601     PerlMem_free(vmsspec);
9602     if (sts != RMS$_NMF)
9603         {
9604         set_vaxc_errno(sts);
9605         switch (sts)
9606             {
9607             case RMS$_FNF: case RMS$_DNF:
9608                 set_errno(ENOENT); break;
9609             case RMS$_DIR:
9610                 set_errno(ENOTDIR); break;
9611             case RMS$_DEV:
9612                 set_errno(ENODEV); break;
9613             case RMS$_FNM: case RMS$_SYN:
9614                 set_errno(EINVAL); break;
9615             case RMS$_PRV:
9616                 set_errno(EACCES); break;
9617             default:
9618                 _ckvmssts_noperl(sts);
9619             }
9620         }
9621     if (expcount == 0)
9622         add_item(head, tail, item, count);
9623     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9624     _ckvmssts_noperl(lib$find_file_end(&context));
9625 }
9626
9627 static int child_st[2];/* Event Flag set when child process completes   */
9628
9629 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
9630
9631 static unsigned long int exit_handler(int *status)
9632 {
9633 short iosb[4];
9634
9635     if (0 == child_st[0])
9636         {
9637 #ifdef ARGPROC_DEBUG
9638         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
9639 #endif
9640         fflush(stdout);     /* Have to flush pipe for binary data to    */
9641                             /* terminate properly -- <tp@mccall.com>    */
9642         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
9643         sys$dassgn(child_chan);
9644         fclose(stdout);
9645         sys$synch(0, child_st);
9646         }
9647     return(1);
9648 }
9649
9650 static void sig_child(int chan)
9651 {
9652 #ifdef ARGPROC_DEBUG
9653     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
9654 #endif
9655     if (child_st[0] == 0)
9656         child_st[0] = 1;
9657 }
9658
9659 static struct exit_control_block exit_block =
9660     {
9661     0,
9662     exit_handler,
9663     1,
9664     &exit_block.exit_status,
9665     0
9666     };
9667
9668 static void
9669 pipe_and_fork(pTHX_ char **cmargv)
9670 {
9671     PerlIO *fp;
9672     struct dsc$descriptor_s *vmscmd;
9673     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9674     int sts, j, l, ismcr, quote, tquote = 0;
9675
9676     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9677     vms_execfree(vmscmd);
9678
9679     j = l = 0;
9680     p = subcmd;
9681     q = cmargv[0];
9682     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
9683               && toupper(*(q+2)) == 'R' && !*(q+3);
9684
9685     while (q && l < MAX_DCL_LINE_LENGTH) {
9686         if (!*q) {
9687             if (j > 0 && quote) {
9688                 *p++ = '"';
9689                 l++;
9690             }
9691             q = cmargv[++j];
9692             if (q) {
9693                 if (ismcr && j > 1) quote = 1;
9694                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
9695                 *p++ = ' ';
9696                 l++;
9697                 if (quote || tquote) {
9698                     *p++ = '"';
9699                     l++;
9700                 }
9701             }
9702         } else {
9703             if ((quote||tquote) && *q == '"') {
9704                 *p++ = '"';
9705                 l++;
9706             }
9707             *p++ = *q++;
9708             l++;
9709         }
9710     }
9711     *p = '\0';
9712
9713     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9714     if (fp == NULL) {
9715         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9716     }
9717 }
9718
9719 static int background_process(pTHX_ int argc, char **argv)
9720 {
9721 char command[MAX_DCL_SYMBOL + 1] = "$";
9722 $DESCRIPTOR(value, "");
9723 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9724 static $DESCRIPTOR(null, "NLA0:");
9725 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9726 char pidstring[80];
9727 $DESCRIPTOR(pidstr, "");
9728 int pid;
9729 unsigned long int flags = 17, one = 1, retsts;
9730 int len;
9731
9732     strcat(command, argv[0]);
9733     len = strlen(command);
9734     while (--argc && (len < MAX_DCL_SYMBOL))
9735         {
9736         strcat(command, " \"");
9737         strcat(command, *(++argv));
9738         strcat(command, "\"");
9739         len = strlen(command);
9740         }
9741     value.dsc$a_pointer = command;
9742     value.dsc$w_length = strlen(value.dsc$a_pointer);
9743     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9744     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9745     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9746         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9747     }
9748     else {
9749         _ckvmssts_noperl(retsts);
9750     }
9751 #ifdef ARGPROC_DEBUG
9752     PerlIO_printf(Perl_debug_log, "%s\n", command);
9753 #endif
9754     sprintf(pidstring, "%08X", pid);
9755     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9756     pidstr.dsc$a_pointer = pidstring;
9757     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9758     lib$set_symbol(&pidsymbol, &pidstr);
9759     return(SS$_NORMAL);
9760 }
9761 /*}}}*/
9762 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9763
9764
9765 /* OS-specific initialization at image activation (not thread startup) */
9766 /* Older VAXC header files lack these constants */
9767 #ifndef JPI$_RIGHTS_SIZE
9768 #  define JPI$_RIGHTS_SIZE 817
9769 #endif
9770 #ifndef KGB$M_SUBSYSTEM
9771 #  define KGB$M_SUBSYSTEM 0x8
9772 #endif
9773
9774 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9775
9776 /*{{{void vms_image_init(int *, char ***)*/
9777 void
9778 vms_image_init(int *argcp, char ***argvp)
9779 {
9780   int status;
9781   char eqv[LNM$C_NAMLENGTH+1] = "";
9782   unsigned int len, tabct = 8, tabidx = 0;
9783   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9784   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9785   unsigned short int dummy, rlen;
9786   struct dsc$descriptor_s **tabvec;
9787 #if defined(PERL_IMPLICIT_CONTEXT)
9788   pTHX = NULL;
9789 #endif
9790   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
9791                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
9792                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9793                                  {          0,                0,    0,      0} };
9794
9795 #ifdef KILL_BY_SIGPRC
9796     Perl_csighandler_init();
9797 #endif
9798
9799 #if __CRTL_VER >= 70300000 && !defined(__VAX)
9800     /* This was moved from the pre-image init handler because on threaded */
9801     /* Perl it was always returning 0 for the default value. */
9802     status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9803     if (status > 0) {
9804         int s;
9805         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9806         if (s > 0) {
9807             int initial;
9808             initial = decc$feature_get_value(s, 4);
9809             if (initial > 0) {
9810                 /* initial is: 0 if nothing has set the feature */
9811                 /*            -1 if initialized to default */
9812                 /*             1 if set by logical name */
9813                 /*             2 if set by decc$feature_set_value */
9814                 decc_disable_posix_root = decc$feature_get_value(s, 1);
9815
9816                 /* If the value is not valid, force the feature off */
9817                 if (decc_disable_posix_root < 0) {
9818                     decc$feature_set_value(s, 1, 1);
9819                     decc_disable_posix_root = 1;
9820                 }
9821             }
9822             else {
9823                 /* Nothing has asked for it explicitly, so use our own default. */
9824                 decc_disable_posix_root = 1;
9825                 decc$feature_set_value(s, 1, 1);
9826             }
9827         }
9828     }
9829 #endif
9830
9831   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9832   _ckvmssts_noperl(iosb[0]);
9833   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9834     if (iprv[i]) {           /* Running image installed with privs? */
9835       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
9836       will_taint = TRUE;
9837       break;
9838     }
9839   }
9840   /* Rights identifiers might trigger tainting as well. */
9841   if (!will_taint && (rlen || rsz)) {
9842     while (rlen < rsz) {
9843       /* We didn't get all the identifiers on the first pass.  Allocate a
9844        * buffer much larger than $GETJPI wants (rsz is size in bytes that
9845        * were needed to hold all identifiers at time of last call; we'll
9846        * allocate that many unsigned long ints), and go back and get 'em.
9847        * If it gave us less than it wanted to despite ample buffer space,
9848        * something's broken.  Is your system missing a system identifier?
9849        */
9850       if (rsz <= jpilist[1].buflen) {
9851          /* Perl_croak accvios when used this early in startup. */
9852          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9853                          rsz, (unsigned long) jpilist[1].buflen,
9854                          "Check your rights database for corruption.\n");
9855          exit(SS$_ABORT);
9856       }
9857       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9858       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9859       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9860       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9861       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9862       _ckvmssts_noperl(iosb[0]);
9863     }
9864     mask = jpilist[1].bufadr;
9865     /* Check attribute flags for each identifier (2nd longword); protected
9866      * subsystem identifiers trigger tainting.
9867      */
9868     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9869       if (mask[i] & KGB$M_SUBSYSTEM) {
9870         will_taint = TRUE;
9871         break;
9872       }
9873     }
9874     if (mask != rlst) PerlMem_free(mask);
9875   }
9876
9877   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9878    * logical, some versions of the CRTL will add a phanthom /000000/
9879    * directory.  This needs to be removed.
9880    */
9881   if (decc_filename_unix_report) {
9882   char * zeros;
9883   int ulen;
9884     ulen = strlen(argvp[0][0]);
9885     if (ulen > 7) {
9886       zeros = strstr(argvp[0][0], "/000000/");
9887       if (zeros != NULL) {
9888         int mlen;
9889         mlen = ulen - (zeros - argvp[0][0]) - 7;
9890         memmove(zeros, &zeros[7], mlen);
9891         ulen = ulen - 7;
9892         argvp[0][0][ulen] = '\0';
9893       }
9894     }
9895     /* It also may have a trailing dot that needs to be removed otherwise
9896      * it will be converted to VMS mode incorrectly.
9897      */
9898     ulen--;
9899     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9900       argvp[0][0][ulen] = '\0';
9901   }
9902
9903   /* We need to use this hack to tell Perl it should run with tainting,
9904    * since its tainting flag may be part of the PL_curinterp struct, which
9905    * hasn't been allocated when vms_image_init() is called.
9906    */
9907   if (will_taint) {
9908     char **newargv, **oldargv;
9909     oldargv = *argvp;
9910     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9911     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9912     newargv[0] = oldargv[0];
9913     newargv[1] = PerlMem_malloc(3 * sizeof(char));
9914     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9915     strcpy(newargv[1], "-T");
9916     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9917     (*argcp)++;
9918     newargv[*argcp] = NULL;
9919     /* We orphan the old argv, since we don't know where it's come from,
9920      * so we don't know how to free it.
9921      */
9922     *argvp = newargv;
9923   }
9924   else {  /* Did user explicitly request tainting? */
9925     int i;
9926     char *cp, **av = *argvp;
9927     for (i = 1; i < *argcp; i++) {
9928       if (*av[i] != '-') break;
9929       for (cp = av[i]+1; *cp; cp++) {
9930         if (*cp == 'T') { will_taint = 1; break; }
9931         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9932                   strchr("DFIiMmx",*cp)) break;
9933       }
9934       if (will_taint) break;
9935     }
9936   }
9937
9938   for (tabidx = 0;
9939        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9940        tabidx++) {
9941     if (!tabidx) {
9942       tabvec = (struct dsc$descriptor_s **)
9943             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9944       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9945     }
9946     else if (tabidx >= tabct) {
9947       tabct += 8;
9948       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9949       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9950     }
9951     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9952     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9953     tabvec[tabidx]->dsc$w_length  = 0;
9954     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9955     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
9956     tabvec[tabidx]->dsc$a_pointer = NULL;
9957     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9958   }
9959   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9960
9961   getredirection(argcp,argvp);
9962 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9963   {
9964 # include <reentrancy.h>
9965   decc$set_reentrancy(C$C_MULTITHREAD);
9966   }
9967 #endif
9968   return;
9969 }
9970 /*}}}*/
9971
9972
9973 /* trim_unixpath()
9974  * Trim Unix-style prefix off filespec, so it looks like what a shell
9975  * glob expansion would return (i.e. from specified prefix on, not
9976  * full path).  Note that returned filespec is Unix-style, regardless
9977  * of whether input filespec was VMS-style or Unix-style.
9978  *
9979  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9980  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9981  * vector of options; at present, only bit 0 is used, and if set tells
9982  * trim unixpath to try the current default directory as a prefix when
9983  * presented with a possibly ambiguous ... wildcard.
9984  *
9985  * Returns !=0 on success, with trimmed filespec replacing contents of
9986  * fspec, and 0 on failure, with contents of fpsec unchanged.
9987  */
9988 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9989 int
9990 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9991 {
9992   char *unixified, *unixwild,
9993        *template, *base, *end, *cp1, *cp2;
9994   register int tmplen, reslen = 0, dirs = 0;
9995
9996   if (!wildspec || !fspec) return 0;
9997
9998   unixwild = PerlMem_malloc(VMS_MAXRSS);
9999   if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10000   template = unixwild;
10001   if (strpbrk(wildspec,"]>:") != NULL) {
10002     if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
10003         PerlMem_free(unixwild);
10004         return 0;
10005     }
10006   }
10007   else {
10008     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
10009     unixwild[VMS_MAXRSS-1] = 0;
10010   }
10011   unixified = PerlMem_malloc(VMS_MAXRSS);
10012   if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10013   if (strpbrk(fspec,"]>:") != NULL) {
10014     if (int_tounixspec(fspec, unixified, NULL) == NULL) {
10015         PerlMem_free(unixwild);
10016         PerlMem_free(unixified);
10017         return 0;
10018     }
10019     else base = unixified;
10020     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
10021      * check to see that final result fits into (isn't longer than) fspec */
10022     reslen = strlen(fspec);
10023   }
10024   else base = fspec;
10025
10026   /* No prefix or absolute path on wildcard, so nothing to remove */
10027   if (!*template || *template == '/') {
10028     PerlMem_free(unixwild);
10029     if (base == fspec) {
10030         PerlMem_free(unixified);
10031         return 1;
10032     }
10033     tmplen = strlen(unixified);
10034     if (tmplen > reslen) {
10035         PerlMem_free(unixified);
10036         return 0;  /* not enough space */
10037     }
10038     /* Copy unixified resultant, including trailing NUL */
10039     memmove(fspec,unixified,tmplen+1);
10040     PerlMem_free(unixified);
10041     return 1;
10042   }
10043
10044   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
10045   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
10046     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
10047     for (cp1 = end ;cp1 >= base; cp1--)
10048       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
10049         { cp1++; break; }
10050     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
10051     PerlMem_free(unixified);
10052     PerlMem_free(unixwild);
10053     return 1;
10054   }
10055   else {
10056     char *tpl, *lcres;
10057     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
10058     int ells = 1, totells, segdirs, match;
10059     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
10060                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10061
10062     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
10063     totells = ells;
10064     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
10065     tpl = PerlMem_malloc(VMS_MAXRSS);
10066     if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10067     if (ellipsis == template && opts & 1) {
10068       /* Template begins with an ellipsis.  Since we can't tell how many
10069        * directory names at the front of the resultant to keep for an
10070        * arbitrary starting point, we arbitrarily choose the current
10071        * default directory as a starting point.  If it's there as a prefix,
10072        * clip it off.  If not, fall through and act as if the leading
10073        * ellipsis weren't there (i.e. return shortest possible path that
10074        * could match template).
10075        */
10076       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
10077           PerlMem_free(tpl);
10078           PerlMem_free(unixified);
10079           PerlMem_free(unixwild);
10080           return 0;
10081       }
10082       if (!decc_efs_case_preserve) {
10083         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
10084           if (_tolower(*cp1) != _tolower(*cp2)) break;
10085       }
10086       segdirs = dirs - totells;  /* Min # of dirs we must have left */
10087       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
10088       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
10089         memmove(fspec,cp2+1,end - cp2);
10090         PerlMem_free(tpl);
10091         PerlMem_free(unixified);
10092         PerlMem_free(unixwild);
10093         return 1;
10094       }
10095     }
10096     /* First off, back up over constant elements at end of path */
10097     if (dirs) {
10098       for (front = end ; front >= base; front--)
10099          if (*front == '/' && !dirs--) { front++; break; }
10100     }
10101     lcres = PerlMem_malloc(VMS_MAXRSS);
10102     if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10103     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
10104          cp1++,cp2++) {
10105             if (!decc_efs_case_preserve) {
10106                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
10107             }
10108             else {
10109                 *cp2 = *cp1;
10110             }
10111     }
10112     if (cp1 != '\0') {
10113         PerlMem_free(tpl);
10114         PerlMem_free(unixified);
10115         PerlMem_free(unixwild);
10116         PerlMem_free(lcres);
10117         return 0;  /* Path too long. */
10118     }
10119     lcend = cp2;
10120     *cp2 = '\0';  /* Pick up with memcpy later */
10121     lcfront = lcres + (front - base);
10122     /* Now skip over each ellipsis and try to match the path in front of it. */
10123     while (ells--) {
10124       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
10125         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
10126             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
10127       if (cp1 < template) break; /* template started with an ellipsis */
10128       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
10129         ellipsis = cp1; continue;
10130       }
10131       wilddsc.dsc$a_pointer = tpl;
10132       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
10133       nextell = cp1;
10134       for (segdirs = 0, cp2 = tpl;
10135            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
10136            cp1++, cp2++) {
10137          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
10138          else {
10139             if (!decc_efs_case_preserve) {
10140               *cp2 = _tolower(*cp1);  /* else lowercase for match */
10141             }
10142             else {
10143               *cp2 = *cp1;  /* else preserve case for match */
10144             }
10145          }
10146          if (*cp2 == '/') segdirs++;
10147       }
10148       if (cp1 != ellipsis - 1) {
10149           PerlMem_free(tpl);
10150           PerlMem_free(unixified);
10151           PerlMem_free(unixwild);
10152           PerlMem_free(lcres);
10153           return 0; /* Path too long */
10154       }
10155       /* Back up at least as many dirs as in template before matching */
10156       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
10157         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
10158       for (match = 0; cp1 > lcres;) {
10159         resdsc.dsc$a_pointer = cp1;
10160         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
10161           match++;
10162           if (match == 1) lcfront = cp1;
10163         }
10164         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
10165       }
10166       if (!match) {
10167         PerlMem_free(tpl);
10168         PerlMem_free(unixified);
10169         PerlMem_free(unixwild);
10170         PerlMem_free(lcres);
10171         return 0;  /* Can't find prefix ??? */
10172       }
10173       if (match > 1 && opts & 1) {
10174         /* This ... wildcard could cover more than one set of dirs (i.e.
10175          * a set of similar dir names is repeated).  If the template
10176          * contains more than 1 ..., upstream elements could resolve the
10177          * ambiguity, but it's not worth a full backtracking setup here.
10178          * As a quick heuristic, clip off the current default directory
10179          * if it's present to find the trimmed spec, else use the
10180          * shortest string that this ... could cover.
10181          */
10182         char def[NAM$C_MAXRSS+1], *st;
10183
10184         if (getcwd(def, sizeof def,0) == NULL) {
10185             PerlMem_free(unixified);
10186             PerlMem_free(unixwild);
10187             PerlMem_free(lcres);
10188             PerlMem_free(tpl);
10189             return 0;
10190         }
10191         if (!decc_efs_case_preserve) {
10192           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
10193             if (_tolower(*cp1) != _tolower(*cp2)) break;
10194         }
10195         segdirs = dirs - totells;  /* Min # of dirs we must have left */
10196         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
10197         if (*cp1 == '\0' && *cp2 == '/') {
10198           memmove(fspec,cp2+1,end - cp2);
10199           PerlMem_free(tpl);
10200           PerlMem_free(unixified);
10201           PerlMem_free(unixwild);
10202           PerlMem_free(lcres);
10203           return 1;
10204         }
10205         /* Nope -- stick with lcfront from above and keep going. */
10206       }
10207     }
10208     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
10209     PerlMem_free(tpl);
10210     PerlMem_free(unixified);
10211     PerlMem_free(unixwild);
10212     PerlMem_free(lcres);
10213     return 1;
10214     ellipsis = nextell;
10215   }
10216
10217 }  /* end of trim_unixpath() */
10218 /*}}}*/
10219
10220
10221 /*
10222  *  VMS readdir() routines.
10223  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
10224  *
10225  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
10226  *  Minor modifications to original routines.
10227  */
10228
10229 /* readdir may have been redefined by reentr.h, so make sure we get
10230  * the local version for what we do here.
10231  */
10232 #ifdef readdir
10233 # undef readdir
10234 #endif
10235 #if !defined(PERL_IMPLICIT_CONTEXT)
10236 # define readdir Perl_readdir
10237 #else
10238 # define readdir(a) Perl_readdir(aTHX_ a)
10239 #endif
10240
10241     /* Number of elements in vms_versions array */
10242 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
10243
10244 /*
10245  *  Open a directory, return a handle for later use.
10246  */
10247 /*{{{ DIR *opendir(char*name) */
10248 DIR *
10249 Perl_opendir(pTHX_ const char *name)
10250 {
10251     DIR *dd;
10252     char *dir;
10253     Stat_t sb;
10254
10255     Newx(dir, VMS_MAXRSS, char);
10256     if (int_tovmspath(name, dir, NULL) == NULL) {
10257       Safefree(dir);
10258       return NULL;
10259     }
10260     /* Check access before stat; otherwise stat does not
10261      * accurately report whether it's a directory.
10262      */
10263     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
10264       /* cando_by_name has already set errno */
10265       Safefree(dir);
10266       return NULL;
10267     }
10268     if (flex_stat(dir,&sb) == -1) return NULL;
10269     if (!S_ISDIR(sb.st_mode)) {
10270       Safefree(dir);
10271       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
10272       return NULL;
10273     }
10274     /* Get memory for the handle, and the pattern. */
10275     Newx(dd,1,DIR);
10276     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
10277
10278     /* Fill in the fields; mainly playing with the descriptor. */
10279     sprintf(dd->pattern, "%s*.*",dir);
10280     Safefree(dir);
10281     dd->context = 0;
10282     dd->count = 0;
10283     dd->flags = 0;
10284     /* By saying we always want the result of readdir() in unix format, we
10285      * are really saying we want all the escapes removed.  Otherwise the caller,
10286      * having no way to know whether it's already in VMS format, might send it
10287      * through tovmsspec again, thus double escaping.
10288      */
10289     dd->flags = PERL_VMSDIR_M_UNIXSPECS;
10290     dd->pat.dsc$a_pointer = dd->pattern;
10291     dd->pat.dsc$w_length = strlen(dd->pattern);
10292     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
10293     dd->pat.dsc$b_class = DSC$K_CLASS_S;
10294 #if defined(USE_ITHREADS)
10295     Newx(dd->mutex,1,perl_mutex);
10296     MUTEX_INIT( (perl_mutex *) dd->mutex );
10297 #else
10298     dd->mutex = NULL;
10299 #endif
10300
10301     return dd;
10302 }  /* end of opendir() */
10303 /*}}}*/
10304
10305 /*
10306  *  Set the flag to indicate we want versions or not.
10307  */
10308 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10309 void
10310 vmsreaddirversions(DIR *dd, int flag)
10311 {
10312     if (flag)
10313         dd->flags |= PERL_VMSDIR_M_VERSIONS;
10314     else
10315         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10316 }
10317 /*}}}*/
10318
10319 /*
10320  *  Free up an opened directory.
10321  */
10322 /*{{{ void closedir(DIR *dd)*/
10323 void
10324 Perl_closedir(DIR *dd)
10325 {
10326     int sts;
10327
10328     sts = lib$find_file_end(&dd->context);
10329     Safefree(dd->pattern);
10330 #if defined(USE_ITHREADS)
10331     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10332     Safefree(dd->mutex);
10333 #endif
10334     Safefree(dd);
10335 }
10336 /*}}}*/
10337
10338 /*
10339  *  Collect all the version numbers for the current file.
10340  */
10341 static void
10342 collectversions(pTHX_ DIR *dd)
10343 {
10344     struct dsc$descriptor_s     pat;
10345     struct dsc$descriptor_s     res;
10346     struct dirent *e;
10347     char *p, *text, *buff;
10348     int i;
10349     unsigned long context, tmpsts;
10350
10351     /* Convenient shorthand. */
10352     e = &dd->entry;
10353
10354     /* Add the version wildcard, ignoring the "*.*" put on before */
10355     i = strlen(dd->pattern);
10356     Newx(text,i + e->d_namlen + 3,char);
10357     strcpy(text, dd->pattern);
10358     sprintf(&text[i - 3], "%s;*", e->d_name);
10359
10360     /* Set up the pattern descriptor. */
10361     pat.dsc$a_pointer = text;
10362     pat.dsc$w_length = i + e->d_namlen - 1;
10363     pat.dsc$b_dtype = DSC$K_DTYPE_T;
10364     pat.dsc$b_class = DSC$K_CLASS_S;
10365
10366     /* Set up result descriptor. */
10367     Newx(buff, VMS_MAXRSS, char);
10368     res.dsc$a_pointer = buff;
10369     res.dsc$w_length = VMS_MAXRSS - 1;
10370     res.dsc$b_dtype = DSC$K_DTYPE_T;
10371     res.dsc$b_class = DSC$K_CLASS_S;
10372
10373     /* Read files, collecting versions. */
10374     for (context = 0, e->vms_verscount = 0;
10375          e->vms_verscount < VERSIZE(e);
10376          e->vms_verscount++) {
10377         unsigned long rsts;
10378         unsigned long flags = 0;
10379
10380 #ifdef VMS_LONGNAME_SUPPORT
10381         flags = LIB$M_FIL_LONG_NAMES;
10382 #endif
10383         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10384         if (tmpsts == RMS$_NMF || context == 0) break;
10385         _ckvmssts(tmpsts);
10386         buff[VMS_MAXRSS - 1] = '\0';
10387         if ((p = strchr(buff, ';')))
10388             e->vms_versions[e->vms_verscount] = atoi(p + 1);
10389         else
10390             e->vms_versions[e->vms_verscount] = -1;
10391     }
10392
10393     _ckvmssts(lib$find_file_end(&context));
10394     Safefree(text);
10395     Safefree(buff);
10396
10397 }  /* end of collectversions() */
10398
10399 /*
10400  *  Read the next entry from the directory.
10401  */
10402 /*{{{ struct dirent *readdir(DIR *dd)*/
10403 struct dirent *
10404 Perl_readdir(pTHX_ DIR *dd)
10405 {
10406     struct dsc$descriptor_s     res;
10407     char *p, *buff;
10408     unsigned long int tmpsts;
10409     unsigned long rsts;
10410     unsigned long flags = 0;
10411     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10412     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10413
10414     /* Set up result descriptor, and get next file. */
10415     Newx(buff, VMS_MAXRSS, char);
10416     res.dsc$a_pointer = buff;
10417     res.dsc$w_length = VMS_MAXRSS - 1;
10418     res.dsc$b_dtype = DSC$K_DTYPE_T;
10419     res.dsc$b_class = DSC$K_CLASS_S;
10420
10421 #ifdef VMS_LONGNAME_SUPPORT
10422     flags = LIB$M_FIL_LONG_NAMES;
10423 #endif
10424
10425     tmpsts = lib$find_file
10426         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10427     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
10428     if (!(tmpsts & 1)) {
10429       set_vaxc_errno(tmpsts);
10430       switch (tmpsts) {
10431         case RMS$_PRV:
10432           set_errno(EACCES); break;
10433         case RMS$_DEV:
10434           set_errno(ENODEV); break;
10435         case RMS$_DIR:
10436           set_errno(ENOTDIR); break;
10437         case RMS$_FNF: case RMS$_DNF:
10438           set_errno(ENOENT); break;
10439         default:
10440           set_errno(EVMSERR);
10441       }
10442       Safefree(buff);
10443       return NULL;
10444     }
10445     dd->count++;
10446     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10447     buff[res.dsc$w_length] = '\0';
10448     p = buff + res.dsc$w_length;
10449     while (--p >= buff) if (!isspace(*p)) break;
10450     *p = '\0';
10451     if (!decc_efs_case_preserve) {
10452       for (p = buff; *p; p++) *p = _tolower(*p);
10453     }
10454
10455     /* Skip any directory component and just copy the name. */
10456     sts = vms_split_path
10457        (buff,
10458         &v_spec,
10459         &v_len,
10460         &r_spec,
10461         &r_len,
10462         &d_spec,
10463         &d_len,
10464         &n_spec,
10465         &n_len,
10466         &e_spec,
10467         &e_len,
10468         &vs_spec,
10469         &vs_len);
10470
10471     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10472
10473         /* In Unix report mode, remove the ".dir;1" from the name */
10474         /* if it is a real directory. */
10475         if (decc_filename_unix_report || decc_efs_charset) {
10476             if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
10477                 Stat_t statbuf;
10478                 int ret_sts;
10479
10480                 ret_sts = flex_lstat(buff, &statbuf);
10481                 if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10482                     e_len = 0;
10483                     e_spec[0] = 0;
10484                 }
10485             }
10486         }
10487
10488         /* Drop NULL extensions on UNIX file specification */
10489         if ((e_len == 1) && decc_readdir_dropdotnotype) {
10490             e_len = 0;
10491             e_spec[0] = '\0';
10492         }
10493     }
10494
10495     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
10496     dd->entry.d_name[n_len + e_len] = '\0';
10497     dd->entry.d_namlen = strlen(dd->entry.d_name);
10498
10499     /* Convert the filename to UNIX format if needed */
10500     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10501
10502         /* Translate the encoded characters. */
10503         /* Fixme: Unicode handling could result in embedded 0 characters */
10504         if (strchr(dd->entry.d_name, '^') != NULL) {
10505             char new_name[256];
10506             char * q;
10507             p = dd->entry.d_name;
10508             q = new_name;
10509             while (*p != 0) {
10510                 int inchars_read, outchars_added;
10511                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10512                 p += inchars_read;
10513                 q += outchars_added;
10514                 /* fix-me */
10515                 /* if outchars_added > 1, then this is a wide file specification */
10516                 /* Wide file specifications need to be passed in Perl */
10517                 /* counted strings apparently with a Unicode flag */
10518             }
10519             *q = 0;
10520             strcpy(dd->entry.d_name, new_name);
10521             dd->entry.d_namlen = strlen(dd->entry.d_name);
10522         }
10523     }
10524
10525     dd->entry.vms_verscount = 0;
10526     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10527     Safefree(buff);
10528     return &dd->entry;
10529
10530 }  /* end of readdir() */
10531 /*}}}*/
10532
10533 /*
10534  *  Read the next entry from the directory -- thread-safe version.
10535  */
10536 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10537 int
10538 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10539 {
10540     int retval;
10541
10542     MUTEX_LOCK( (perl_mutex *) dd->mutex );
10543
10544     entry = readdir(dd);
10545     *result = entry;
10546     retval = ( *result == NULL ? errno : 0 );
10547
10548     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10549
10550     return retval;
10551
10552 }  /* end of readdir_r() */
10553 /*}}}*/
10554
10555 /*
10556  *  Return something that can be used in a seekdir later.
10557  */
10558 /*{{{ long telldir(DIR *dd)*/
10559 long
10560 Perl_telldir(DIR *dd)
10561 {
10562     return dd->count;
10563 }
10564 /*}}}*/
10565
10566 /*
10567  *  Return to a spot where we used to be.  Brute force.
10568  */
10569 /*{{{ void seekdir(DIR *dd,long count)*/
10570 void
10571 Perl_seekdir(pTHX_ DIR *dd, long count)
10572 {
10573     int old_flags;
10574
10575     /* If we haven't done anything yet... */
10576     if (dd->count == 0)
10577         return;
10578
10579     /* Remember some state, and clear it. */
10580     old_flags = dd->flags;
10581     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10582     _ckvmssts(lib$find_file_end(&dd->context));
10583     dd->context = 0;
10584
10585     /* The increment is in readdir(). */
10586     for (dd->count = 0; dd->count < count; )
10587         readdir(dd);
10588
10589     dd->flags = old_flags;
10590
10591 }  /* end of seekdir() */
10592 /*}}}*/
10593
10594 /* VMS subprocess management
10595  *
10596  * my_vfork() - just a vfork(), after setting a flag to record that
10597  * the current script is trying a Unix-style fork/exec.
10598  *
10599  * vms_do_aexec() and vms_do_exec() are called in response to the
10600  * perl 'exec' function.  If this follows a vfork call, then they
10601  * call out the regular perl routines in doio.c which do an
10602  * execvp (for those who really want to try this under VMS).
10603  * Otherwise, they do exactly what the perl docs say exec should
10604  * do - terminate the current script and invoke a new command
10605  * (See below for notes on command syntax.)
10606  *
10607  * do_aspawn() and do_spawn() implement the VMS side of the perl
10608  * 'system' function.
10609  *
10610  * Note on command arguments to perl 'exec' and 'system': When handled
10611  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10612  * are concatenated to form a DCL command string.  If the first non-numeric
10613  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10614  * the command string is handed off to DCL directly.  Otherwise,
10615  * the first token of the command is taken as the filespec of an image
10616  * to run.  The filespec is expanded using a default type of '.EXE' and
10617  * the process defaults for device, directory, etc., and if found, the resultant
10618  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10619  * the command string as parameters.  This is perhaps a bit complicated,
10620  * but I hope it will form a happy medium between what VMS folks expect
10621  * from lib$spawn and what Unix folks expect from exec.
10622  */
10623
10624 static int vfork_called;
10625
10626 /*{{{int my_vfork()*/
10627 int
10628 my_vfork()
10629 {
10630   vfork_called++;
10631   return vfork();
10632 }
10633 /*}}}*/
10634
10635
10636 static void
10637 vms_execfree(struct dsc$descriptor_s *vmscmd)
10638 {
10639   if (vmscmd) {
10640       if (vmscmd->dsc$a_pointer) {
10641           PerlMem_free(vmscmd->dsc$a_pointer);
10642       }
10643       PerlMem_free(vmscmd);
10644   }
10645 }
10646
10647 static char *
10648 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10649 {
10650   char *junk, *tmps = NULL;
10651   register size_t cmdlen = 0;
10652   size_t rlen;
10653   register SV **idx;
10654   STRLEN n_a;
10655
10656   idx = mark;
10657   if (really) {
10658     tmps = SvPV(really,rlen);
10659     if (*tmps) {
10660       cmdlen += rlen + 1;
10661       idx++;
10662     }
10663   }
10664
10665   for (idx++; idx <= sp; idx++) {
10666     if (*idx) {
10667       junk = SvPVx(*idx,rlen);
10668       cmdlen += rlen ? rlen + 1 : 0;
10669     }
10670   }
10671   Newx(PL_Cmd, cmdlen+1, char);
10672
10673   if (tmps && *tmps) {
10674     strcpy(PL_Cmd,tmps);
10675     mark++;
10676   }
10677   else *PL_Cmd = '\0';
10678   while (++mark <= sp) {
10679     if (*mark) {
10680       char *s = SvPVx(*mark,n_a);
10681       if (!*s) continue;
10682       if (*PL_Cmd) strcat(PL_Cmd," ");
10683       strcat(PL_Cmd,s);
10684     }
10685   }
10686   return PL_Cmd;
10687
10688 }  /* end of setup_argstr() */
10689
10690
10691 static unsigned long int
10692 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10693                    struct dsc$descriptor_s **pvmscmd)
10694 {
10695   char * vmsspec;
10696   char * resspec;
10697   char image_name[NAM$C_MAXRSS+1];
10698   char image_argv[NAM$C_MAXRSS+1];
10699   $DESCRIPTOR(defdsc,".EXE");
10700   $DESCRIPTOR(defdsc2,".");
10701   struct dsc$descriptor_s resdsc;
10702   struct dsc$descriptor_s *vmscmd;
10703   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10704   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10705   register char *s, *rest, *cp, *wordbreak;
10706   char * cmd;
10707   int cmdlen;
10708   register int isdcl;
10709
10710   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10711   if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10712
10713   /* vmsspec is a DCL command buffer, not just a filename */
10714   vmsspec = PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10715   if (vmsspec == NULL)
10716       _ckvmssts_noperl(SS$_INSFMEM);
10717
10718   resspec = PerlMem_malloc(VMS_MAXRSS);
10719   if (resspec == NULL)
10720       _ckvmssts_noperl(SS$_INSFMEM);
10721
10722   /* Make a copy for modification */
10723   cmdlen = strlen(incmd);
10724   cmd = PerlMem_malloc(cmdlen+1);
10725   if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10726   strncpy(cmd, incmd, cmdlen);
10727   cmd[cmdlen] = 0;
10728   image_name[0] = 0;
10729   image_argv[0] = 0;
10730
10731   resdsc.dsc$a_pointer = resspec;
10732   resdsc.dsc$b_dtype  = DSC$K_DTYPE_T;
10733   resdsc.dsc$b_class  = DSC$K_CLASS_S;
10734   resdsc.dsc$w_length = VMS_MAXRSS - 1;
10735
10736   vmscmd->dsc$a_pointer = NULL;
10737   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
10738   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
10739   vmscmd->dsc$w_length = 0;
10740   if (pvmscmd) *pvmscmd = vmscmd;
10741
10742   if (suggest_quote) *suggest_quote = 0;
10743
10744   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10745     PerlMem_free(cmd);
10746     PerlMem_free(vmsspec);
10747     PerlMem_free(resspec);
10748     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
10749   }
10750
10751   s = cmd;
10752
10753   while (*s && isspace(*s)) s++;
10754
10755   if (*s == '@' || *s == '$') {
10756     vmsspec[0] = *s;  rest = s + 1;
10757     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10758   }
10759   else { cp = vmsspec; rest = s; }
10760   if (*rest == '.' || *rest == '/') {
10761     char *cp2;
10762     for (cp2 = resspec;
10763          *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10764          rest++, cp2++) *cp2 = *rest;
10765     *cp2 = '\0';
10766     if (int_tovmsspec(resspec, cp, 0, NULL)) {
10767       s = vmsspec;
10768
10769       /* When a UNIX spec with no file type is translated to VMS, */
10770       /* A trailing '.' is appended under ODS-5 rules.            */
10771       /* Here we do not want that trailing "." as it prevents     */
10772       /* Looking for a implied ".exe" type. */
10773       if (decc_efs_charset) {
10774           int i;
10775           i = strlen(vmsspec);
10776           if (vmsspec[i-1] == '.') {
10777               vmsspec[i-1] = '\0';
10778           }
10779       }
10780
10781       if (*rest) {
10782         for (cp2 = vmsspec + strlen(vmsspec);
10783              *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10784              rest++, cp2++) *cp2 = *rest;
10785         *cp2 = '\0';
10786       }
10787     }
10788   }
10789   /* Intuit whether verb (first word of cmd) is a DCL command:
10790    *   - if first nonspace char is '@', it's a DCL indirection
10791    * otherwise
10792    *   - if verb contains a filespec separator, it's not a DCL command
10793    *   - if it doesn't, caller tells us whether to default to a DCL
10794    *     command, or to a local image unless told it's DCL (by leading '$')
10795    */
10796   if (*s == '@') {
10797       isdcl = 1;
10798       if (suggest_quote) *suggest_quote = 1;
10799   } else {
10800     register char *filespec = strpbrk(s,":<[.;");
10801     rest = wordbreak = strpbrk(s," \"\t/");
10802     if (!wordbreak) wordbreak = s + strlen(s);
10803     if (*s == '$') check_img = 0;
10804     if (filespec && (filespec < wordbreak)) isdcl = 0;
10805     else isdcl = !check_img;
10806   }
10807
10808   if (!isdcl) {
10809     int rsts;
10810     imgdsc.dsc$a_pointer = s;
10811     imgdsc.dsc$w_length = wordbreak - s;
10812     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10813     if (!(retsts&1)) {
10814         _ckvmssts_noperl(lib$find_file_end(&cxt));
10815         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10816       if (!(retsts & 1) && *s == '$') {
10817         _ckvmssts_noperl(lib$find_file_end(&cxt));
10818         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10819         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10820         if (!(retsts&1)) {
10821           _ckvmssts_noperl(lib$find_file_end(&cxt));
10822           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10823         }
10824       }
10825     }
10826     _ckvmssts_noperl(lib$find_file_end(&cxt));
10827
10828     if (retsts & 1) {
10829       FILE *fp;
10830       s = resspec;
10831       while (*s && !isspace(*s)) s++;
10832       *s = '\0';
10833
10834       /* check that it's really not DCL with no file extension */
10835       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10836       if (fp) {
10837         char b[256] = {0,0,0,0};
10838         read(fileno(fp), b, 256);
10839         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10840         if (isdcl) {
10841           int shebang_len;
10842
10843           /* Check for script */
10844           shebang_len = 0;
10845           if ((b[0] == '#') && (b[1] == '!'))
10846              shebang_len = 2;
10847 #ifdef ALTERNATE_SHEBANG
10848           else {
10849             shebang_len = strlen(ALTERNATE_SHEBANG);
10850             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10851               char * perlstr;
10852                 perlstr = strstr("perl",b);
10853                 if (perlstr == NULL)
10854                   shebang_len = 0;
10855             }
10856             else
10857               shebang_len = 0;
10858           }
10859 #endif
10860
10861           if (shebang_len > 0) {
10862           int i;
10863           int j;
10864           char tmpspec[NAM$C_MAXRSS + 1];
10865
10866             i = shebang_len;
10867              /* Image is following after white space */
10868             /*--------------------------------------*/
10869             while (isprint(b[i]) && isspace(b[i]))
10870                 i++;
10871
10872             j = 0;
10873             while (isprint(b[i]) && !isspace(b[i])) {
10874                 tmpspec[j++] = b[i++];
10875                 if (j >= NAM$C_MAXRSS)
10876                    break;
10877             }
10878             tmpspec[j] = '\0';
10879
10880              /* There may be some default parameters to the image */
10881             /*---------------------------------------------------*/
10882             j = 0;
10883             while (isprint(b[i])) {
10884                 image_argv[j++] = b[i++];
10885                 if (j >= NAM$C_MAXRSS)
10886                    break;
10887             }
10888             while ((j > 0) && !isprint(image_argv[j-1]))
10889                 j--;
10890             image_argv[j] = 0;
10891
10892             /* It will need to be converted to VMS format and validated */
10893             if (tmpspec[0] != '\0') {
10894               char * iname;
10895
10896                /* Try to find the exact program requested to be run */
10897               /*---------------------------------------------------*/
10898               iname = int_rmsexpand
10899                  (tmpspec, image_name, ".exe",
10900                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10901               if (iname != NULL) {
10902                 if (cando_by_name_int
10903                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10904                   /* MCR prefix needed */
10905                   isdcl = 0;
10906                 }
10907                 else {
10908                    /* Try again with a null type */
10909                   /*----------------------------*/
10910                   iname = int_rmsexpand
10911                     (tmpspec, image_name, ".",
10912                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10913                   if (iname != NULL) {
10914                     if (cando_by_name_int
10915                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10916                       /* MCR prefix needed */
10917                       isdcl = 0;
10918                     }
10919                   }
10920                 }
10921
10922                  /* Did we find the image to run the script? */
10923                 /*------------------------------------------*/
10924                 if (isdcl) {
10925                   char *tchr;
10926
10927                    /* Assume DCL or foreign command exists */
10928                   /*--------------------------------------*/
10929                   tchr = strrchr(tmpspec, '/');
10930                   if (tchr != NULL) {
10931                     tchr++;
10932                   }
10933                   else {
10934                     tchr = tmpspec;
10935                   }
10936                   strcpy(image_name, tchr);
10937                 }
10938               }
10939             }
10940           }
10941         }
10942         fclose(fp);
10943       }
10944       if (check_img && isdcl) {
10945           PerlMem_free(cmd);
10946           PerlMem_free(resspec);
10947           PerlMem_free(vmsspec);
10948           return RMS$_FNF;
10949       }
10950
10951       if (cando_by_name(S_IXUSR,0,resspec)) {
10952         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10953         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10954         if (!isdcl) {
10955             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
10956             if (image_name[0] != 0) {
10957                 strcat(vmscmd->dsc$a_pointer, image_name);
10958                 strcat(vmscmd->dsc$a_pointer, " ");
10959             }
10960         } else if (image_name[0] != 0) {
10961             strcpy(vmscmd->dsc$a_pointer, image_name);
10962             strcat(vmscmd->dsc$a_pointer, " ");
10963         } else {
10964             strcpy(vmscmd->dsc$a_pointer,"@");
10965         }
10966         if (suggest_quote) *suggest_quote = 1;
10967
10968         /* If there is an image name, use original command */
10969         if (image_name[0] == 0)
10970             strcat(vmscmd->dsc$a_pointer,resspec);
10971         else {
10972             rest = cmd;
10973             while (*rest && isspace(*rest)) rest++;
10974         }
10975
10976         if (image_argv[0] != 0) {
10977           strcat(vmscmd->dsc$a_pointer,image_argv);
10978           strcat(vmscmd->dsc$a_pointer, " ");
10979         }
10980         if (rest) {
10981            int rest_len;
10982            int vmscmd_len;
10983
10984            rest_len = strlen(rest);
10985            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10986            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10987               strcat(vmscmd->dsc$a_pointer,rest);
10988            else
10989              retsts = CLI$_BUFOVF;
10990         }
10991         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10992         PerlMem_free(cmd);
10993         PerlMem_free(vmsspec);
10994         PerlMem_free(resspec);
10995         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10996       }
10997       else
10998         retsts = RMS$_PRV;
10999     }
11000   }
11001   /* It's either a DCL command or we couldn't find a suitable image */
11002   vmscmd->dsc$w_length = strlen(cmd);
11003
11004   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
11005   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
11006   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
11007
11008   PerlMem_free(cmd);
11009   PerlMem_free(resspec);
11010   PerlMem_free(vmsspec);
11011
11012   /* check if it's a symbol (for quoting purposes) */
11013   if (suggest_quote && !*suggest_quote) {
11014     int iss;
11015     char equiv[LNM$C_NAMLENGTH];
11016     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11017     eqvdsc.dsc$a_pointer = equiv;
11018
11019     iss = lib$get_symbol(vmscmd,&eqvdsc);
11020     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
11021   }
11022   if (!(retsts & 1)) {
11023     /* just hand off status values likely to be due to user error */
11024     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
11025         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
11026        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
11027     else { _ckvmssts_noperl(retsts); }
11028   }
11029
11030   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
11031
11032 }  /* end of setup_cmddsc() */
11033
11034
11035 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
11036 bool
11037 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
11038 {
11039 bool exec_sts;
11040 char * cmd;
11041
11042   if (sp > mark) {
11043     if (vfork_called) {           /* this follows a vfork - act Unixish */
11044       vfork_called--;
11045       if (vfork_called < 0) {
11046         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
11047         vfork_called = 0;
11048       }
11049       else return do_aexec(really,mark,sp);
11050     }
11051                                            /* no vfork - act VMSish */
11052     cmd = setup_argstr(aTHX_ really,mark,sp);
11053     exec_sts = vms_do_exec(cmd);
11054     Safefree(cmd);  /* Clean up from setup_argstr() */
11055     return exec_sts;
11056   }
11057
11058   return FALSE;
11059 }  /* end of vms_do_aexec() */
11060 /*}}}*/
11061
11062 /* {{{bool vms_do_exec(char *cmd) */
11063 bool
11064 Perl_vms_do_exec(pTHX_ const char *cmd)
11065 {
11066   struct dsc$descriptor_s *vmscmd;
11067
11068   if (vfork_called) {             /* this follows a vfork - act Unixish */
11069     vfork_called--;
11070     if (vfork_called < 0) {
11071       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
11072       vfork_called = 0;
11073     }
11074     else return do_exec(cmd);
11075   }
11076
11077   {                               /* no vfork - act VMSish */
11078     unsigned long int retsts;
11079
11080     TAINT_ENV();
11081     TAINT_PROPER("exec");
11082     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
11083       retsts = lib$do_command(vmscmd);
11084
11085     switch (retsts) {
11086       case RMS$_FNF: case RMS$_DNF:
11087         set_errno(ENOENT); break;
11088       case RMS$_DIR:
11089         set_errno(ENOTDIR); break;
11090       case RMS$_DEV:
11091         set_errno(ENODEV); break;
11092       case RMS$_PRV:
11093         set_errno(EACCES); break;
11094       case RMS$_SYN:
11095         set_errno(EINVAL); break;
11096       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11097         set_errno(E2BIG); break;
11098       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11099         _ckvmssts_noperl(retsts); /* fall through */
11100       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11101         set_errno(EVMSERR);
11102     }
11103     set_vaxc_errno(retsts);
11104     if (ckWARN(WARN_EXEC)) {
11105       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
11106              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
11107     }
11108     vms_execfree(vmscmd);
11109   }
11110
11111   return FALSE;
11112
11113 }  /* end of vms_do_exec() */
11114 /*}}}*/
11115
11116 int do_spawn2(pTHX_ const char *, int);
11117
11118 int
11119 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
11120 {
11121 unsigned long int sts;
11122 char * cmd;
11123 int flags = 0;
11124
11125   if (sp > mark) {
11126
11127     /* We'll copy the (undocumented?) Win32 behavior and allow a
11128      * numeric first argument.  But the only value we'll support
11129      * through do_aspawn is a value of 1, which means spawn without
11130      * waiting for completion -- other values are ignored.
11131      */
11132     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
11133         ++mark;
11134         flags = SvIVx(*mark);
11135     }
11136
11137     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
11138         flags = CLI$M_NOWAIT;
11139     else
11140         flags = 0;
11141
11142     cmd = setup_argstr(aTHX_ really, mark, sp);
11143     sts = do_spawn2(aTHX_ cmd, flags);
11144     /* pp_sys will clean up cmd */
11145     return sts;
11146   }
11147   return SS$_ABORT;
11148 }  /* end of do_aspawn() */
11149 /*}}}*/
11150
11151
11152 /* {{{int do_spawn(char* cmd) */
11153 int
11154 Perl_do_spawn(pTHX_ char* cmd)
11155 {
11156     PERL_ARGS_ASSERT_DO_SPAWN;
11157
11158     return do_spawn2(aTHX_ cmd, 0);
11159 }
11160 /*}}}*/
11161
11162 /* {{{int do_spawn_nowait(char* cmd) */
11163 int
11164 Perl_do_spawn_nowait(pTHX_ char* cmd)
11165 {
11166     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
11167
11168     return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
11169 }
11170 /*}}}*/
11171
11172 /* {{{int do_spawn2(char *cmd) */
11173 int
11174 do_spawn2(pTHX_ const char *cmd, int flags)
11175 {
11176   unsigned long int sts, substs;
11177
11178   /* The caller of this routine expects to Safefree(PL_Cmd) */
11179   Newx(PL_Cmd,10,char);
11180
11181   TAINT_ENV();
11182   TAINT_PROPER("spawn");
11183   if (!cmd || !*cmd) {
11184     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
11185     if (!(sts & 1)) {
11186       switch (sts) {
11187         case RMS$_FNF:  case RMS$_DNF:
11188           set_errno(ENOENT); break;
11189         case RMS$_DIR:
11190           set_errno(ENOTDIR); break;
11191         case RMS$_DEV:
11192           set_errno(ENODEV); break;
11193         case RMS$_PRV:
11194           set_errno(EACCES); break;
11195         case RMS$_SYN:
11196           set_errno(EINVAL); break;
11197         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11198           set_errno(E2BIG); break;
11199         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11200           _ckvmssts_noperl(sts); /* fall through */
11201         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11202           set_errno(EVMSERR);
11203       }
11204       set_vaxc_errno(sts);
11205       if (ckWARN(WARN_EXEC)) {
11206         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
11207                     Strerror(errno));
11208       }
11209     }
11210     sts = substs;
11211   }
11212   else {
11213     char mode[3];
11214     PerlIO * fp;
11215     if (flags & CLI$M_NOWAIT)
11216         strcpy(mode, "n");
11217     else
11218         strcpy(mode, "nW");
11219
11220     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
11221     if (fp != NULL)
11222       my_pclose(fp);
11223     /* sts will be the pid in the nowait case */
11224   }
11225   return sts;
11226 }  /* end of do_spawn2() */
11227 /*}}}*/
11228
11229
11230 static unsigned int *sockflags, sockflagsize;
11231
11232 /*
11233  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
11234  * routines found in some versions of the CRTL can't deal with sockets.
11235  * We don't shim the other file open routines since a socket isn't
11236  * likely to be opened by a name.
11237  */
11238 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
11239 FILE *my_fdopen(int fd, const char *mode)
11240 {
11241   FILE *fp = fdopen(fd, mode);
11242
11243   if (fp) {
11244     unsigned int fdoff = fd / sizeof(unsigned int);
11245     Stat_t sbuf; /* native stat; we don't need flex_stat */
11246     if (!sockflagsize || fdoff > sockflagsize) {
11247       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
11248       else           Newx  (sockflags,fdoff+2,unsigned int);
11249       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11250       sockflagsize = fdoff + 2;
11251     }
11252     if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
11253       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11254   }
11255   return fp;
11256
11257 }
11258 /*}}}*/
11259
11260
11261 /*
11262  * Clear the corresponding bit when the (possibly) socket stream is closed.
11263  * There still a small hole: we miss an implicit close which might occur
11264  * via freopen().  >> Todo
11265  */
11266 /*{{{ int my_fclose(FILE *fp)*/
11267 int my_fclose(FILE *fp) {
11268   if (fp) {
11269     unsigned int fd = fileno(fp);
11270     unsigned int fdoff = fd / sizeof(unsigned int);
11271
11272     if (sockflagsize && fdoff < sockflagsize)
11273       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11274   }
11275   return fclose(fp);
11276 }
11277 /*}}}*/
11278
11279
11280 /*
11281  * A simple fwrite replacement which outputs itmsz*nitm chars without
11282  * introducing record boundaries every itmsz chars.
11283  * We are using fputs, which depends on a terminating null.  We may
11284  * well be writing binary data, so we need to accommodate not only
11285  * data with nulls sprinkled in the middle but also data with no null
11286  * byte at the end.
11287  */
11288 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
11289 int
11290 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11291 {
11292   register char *cp, *end, *cpd, *data;
11293   register unsigned int fd = fileno(dest);
11294   register unsigned int fdoff = fd / sizeof(unsigned int);
11295   int retval;
11296   int bufsize = itmsz * nitm + 1;
11297
11298   if (fdoff < sockflagsize &&
11299       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11300     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11301     return nitm;
11302   }
11303
11304   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11305   memcpy( data, src, itmsz*nitm );
11306   data[itmsz*nitm] = '\0';
11307
11308   end = data + itmsz * nitm;
11309   retval = (int) nitm; /* on success return # items written */
11310
11311   cpd = data;
11312   while (cpd <= end) {
11313     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11314     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11315     if (cp < end)
11316       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11317     cpd = cp + 1;
11318   }
11319
11320   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11321   return retval;
11322
11323 }  /* end of my_fwrite() */
11324 /*}}}*/
11325
11326 /*{{{ int my_flush(FILE *fp)*/
11327 int
11328 Perl_my_flush(pTHX_ FILE *fp)
11329 {
11330     int res;
11331     if ((res = fflush(fp)) == 0 && fp) {
11332 #ifdef VMS_DO_SOCKETS
11333         Stat_t s;
11334         if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11335 #endif
11336             res = fsync(fileno(fp));
11337     }
11338 /*
11339  * If the flush succeeded but set end-of-file, we need to clear
11340  * the error because our caller may check ferror().  BTW, this
11341  * probably means we just flushed an empty file.
11342  */
11343     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11344
11345     return res;
11346 }
11347 /*}}}*/
11348
11349 /* fgetname() is not returning the correct file specifications when
11350  * decc_filename_unix_report mode is active.  So we have to have it
11351  * aways return filenames in VMS mode and convert it ourselves.
11352  */
11353
11354 /*{{{ char * my_fgetname(FILE *fp, buf)*/
11355 char *
11356 Perl_my_fgetname(FILE *fp, char * buf) {
11357     char * retname;
11358     char * vms_name;
11359
11360     retname = fgetname(fp, buf, 1);
11361
11362     /* If we are in VMS mode, then we are done */
11363     if (!decc_filename_unix_report || (retname == NULL)) {
11364        return retname;
11365     }
11366
11367     /* Convert this to Unix format */
11368     vms_name = PerlMem_malloc(VMS_MAXRSS + 1);
11369     strcpy(vms_name, retname);
11370     retname = int_tounixspec(vms_name, buf, NULL);
11371     PerlMem_free(vms_name);
11372
11373     return retname;
11374 }
11375 /*}}}*/
11376
11377 /*
11378  * Here are replacements for the following Unix routines in the VMS environment:
11379  *      getpwuid    Get information for a particular UIC or UID
11380  *      getpwnam    Get information for a named user
11381  *      getpwent    Get information for each user in the rights database
11382  *      setpwent    Reset search to the start of the rights database
11383  *      endpwent    Finish searching for users in the rights database
11384  *
11385  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11386  * (defined in pwd.h), which contains the following fields:-
11387  *      struct passwd {
11388  *              char        *pw_name;    Username (in lower case)
11389  *              char        *pw_passwd;  Hashed password
11390  *              unsigned int pw_uid;     UIC
11391  *              unsigned int pw_gid;     UIC group  number
11392  *              char        *pw_unixdir; Default device/directory (VMS-style)
11393  *              char        *pw_gecos;   Owner name
11394  *              char        *pw_dir;     Default device/directory (Unix-style)
11395  *              char        *pw_shell;   Default CLI name (eg. DCL)
11396  *      };
11397  * If the specified user does not exist, getpwuid and getpwnam return NULL.
11398  *
11399  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11400  * not the UIC member number (eg. what's returned by getuid()),
11401  * getpwuid() can accept either as input (if uid is specified, the caller's
11402  * UIC group is used), though it won't recognise gid=0.
11403  *
11404  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11405  * information about other users in your group or in other groups, respectively.
11406  * If the required privilege is not available, then these routines fill only
11407  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11408  * string).
11409  *
11410  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11411  */
11412
11413 /* sizes of various UAF record fields */
11414 #define UAI$S_USERNAME 12
11415 #define UAI$S_IDENT    31
11416 #define UAI$S_OWNER    31
11417 #define UAI$S_DEFDEV   31
11418 #define UAI$S_DEFDIR   63
11419 #define UAI$S_DEFCLI   31
11420 #define UAI$S_PWD       8
11421
11422 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
11423                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11424                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
11425
11426 static char __empty[]= "";
11427 static struct passwd __passwd_empty=
11428     {(char *) __empty, (char *) __empty, 0, 0,
11429      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11430 static int contxt= 0;
11431 static struct passwd __pwdcache;
11432 static char __pw_namecache[UAI$S_IDENT+1];
11433
11434 /*
11435  * This routine does most of the work extracting the user information.
11436  */
11437 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11438 {
11439     static struct {
11440         unsigned char length;
11441         char pw_gecos[UAI$S_OWNER+1];
11442     } owner;
11443     static union uicdef uic;
11444     static struct {
11445         unsigned char length;
11446         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11447     } defdev;
11448     static struct {
11449         unsigned char length;
11450         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11451     } defdir;
11452     static struct {
11453         unsigned char length;
11454         char pw_shell[UAI$S_DEFCLI+1];
11455     } defcli;
11456     static char pw_passwd[UAI$S_PWD+1];
11457
11458     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11459     struct dsc$descriptor_s name_desc;
11460     unsigned long int sts;
11461
11462     static struct itmlst_3 itmlst[]= {
11463         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
11464         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
11465         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
11466         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
11467         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
11468         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
11469         {0,                0,           NULL,    NULL}};
11470
11471     name_desc.dsc$w_length=  strlen(name);
11472     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11473     name_desc.dsc$b_class=   DSC$K_CLASS_S;
11474     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11475
11476 /*  Note that sys$getuai returns many fields as counted strings. */
11477     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11478     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11479       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11480     }
11481     else { _ckvmssts(sts); }
11482     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
11483
11484     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
11485     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11486     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11487     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11488     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11489     owner.pw_gecos[lowner]=            '\0';
11490     defdev.pw_dir[ldefdev+ldefdir]= '\0';
11491     defcli.pw_shell[ldefcli]=          '\0';
11492     if (valid_uic(uic)) {
11493         pwd->pw_uid= uic.uic$l_uic;
11494         pwd->pw_gid= uic.uic$v_group;
11495     }
11496     else
11497       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11498     pwd->pw_passwd=  pw_passwd;
11499     pwd->pw_gecos=   owner.pw_gecos;
11500     pwd->pw_dir=     defdev.pw_dir;
11501     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11502     pwd->pw_shell=   defcli.pw_shell;
11503     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11504         int ldir;
11505         ldir= strlen(pwd->pw_unixdir) - 1;
11506         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11507     }
11508     else
11509         strcpy(pwd->pw_unixdir, pwd->pw_dir);
11510     if (!decc_efs_case_preserve)
11511         __mystrtolower(pwd->pw_unixdir);
11512     return 1;
11513 }
11514
11515 /*
11516  * Get information for a named user.
11517 */
11518 /*{{{struct passwd *getpwnam(char *name)*/
11519 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
11520 {
11521     struct dsc$descriptor_s name_desc;
11522     union uicdef uic;
11523     unsigned long int status, sts;
11524
11525     __pwdcache = __passwd_empty;
11526     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11527       /* We still may be able to determine pw_uid and pw_gid */
11528       name_desc.dsc$w_length=  strlen(name);
11529       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11530       name_desc.dsc$b_class=   DSC$K_CLASS_S;
11531       name_desc.dsc$a_pointer= (char *) name;
11532       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11533         __pwdcache.pw_uid= uic.uic$l_uic;
11534         __pwdcache.pw_gid= uic.uic$v_group;
11535       }
11536       else {
11537         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11538           set_vaxc_errno(sts);
11539           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11540           return NULL;
11541         }
11542         else { _ckvmssts(sts); }
11543       }
11544     }
11545     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
11546     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
11547     __pwdcache.pw_name= __pw_namecache;
11548     return &__pwdcache;
11549 }  /* end of my_getpwnam() */
11550 /*}}}*/
11551
11552 /*
11553  * Get information for a particular UIC or UID.
11554  * Called by my_getpwent with uid=-1 to list all users.
11555 */
11556 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11557 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
11558 {
11559     const $DESCRIPTOR(name_desc,__pw_namecache);
11560     unsigned short lname;
11561     union uicdef uic;
11562     unsigned long int status;
11563
11564     if (uid == (unsigned int) -1) {
11565       do {
11566         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11567         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11568           set_vaxc_errno(status);
11569           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11570           my_endpwent();
11571           return NULL;
11572         }
11573         else { _ckvmssts(status); }
11574       } while (!valid_uic (uic));
11575     }
11576     else {
11577       uic.uic$l_uic= uid;
11578       if (!uic.uic$v_group)
11579         uic.uic$v_group= PerlProc_getgid();
11580       if (valid_uic(uic))
11581         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11582       else status = SS$_IVIDENT;
11583       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11584           status == RMS$_PRV) {
11585         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11586         return NULL;
11587       }
11588       else { _ckvmssts(status); }
11589     }
11590     __pw_namecache[lname]= '\0';
11591     __mystrtolower(__pw_namecache);
11592
11593     __pwdcache = __passwd_empty;
11594     __pwdcache.pw_name = __pw_namecache;
11595
11596 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11597     The identifier's value is usually the UIC, but it doesn't have to be,
11598     so if we can, we let fillpasswd update this. */
11599     __pwdcache.pw_uid =  uic.uic$l_uic;
11600     __pwdcache.pw_gid =  uic.uic$v_group;
11601
11602     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11603     return &__pwdcache;
11604
11605 }  /* end of my_getpwuid() */
11606 /*}}}*/
11607
11608 /*
11609  * Get information for next user.
11610 */
11611 /*{{{struct passwd *my_getpwent()*/
11612 struct passwd *Perl_my_getpwent(pTHX)
11613 {
11614     return (my_getpwuid((unsigned int) -1));
11615 }
11616 /*}}}*/
11617
11618 /*
11619  * Finish searching rights database for users.
11620 */
11621 /*{{{void my_endpwent()*/
11622 void Perl_my_endpwent(pTHX)
11623 {
11624     if (contxt) {
11625       _ckvmssts(sys$finish_rdb(&contxt));
11626       contxt= 0;
11627     }
11628 }
11629 /*}}}*/
11630
11631 #ifdef HOMEGROWN_POSIX_SIGNALS
11632   /* Signal handling routines, pulled into the core from POSIX.xs.
11633    *
11634    * We need these for threads, so they've been rolled into the core,
11635    * rather than left in POSIX.xs.
11636    *
11637    * (DRS, Oct 23, 1997)
11638    */
11639
11640   /* sigset_t is atomic under VMS, so these routines are easy */
11641 /*{{{int my_sigemptyset(sigset_t *) */
11642 int my_sigemptyset(sigset_t *set) {
11643     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11644     *set = 0; return 0;
11645 }
11646 /*}}}*/
11647
11648
11649 /*{{{int my_sigfillset(sigset_t *)*/
11650 int my_sigfillset(sigset_t *set) {
11651     int i;
11652     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11653     for (i = 0; i < NSIG; i++) *set |= (1 << i);
11654     return 0;
11655 }
11656 /*}}}*/
11657
11658
11659 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
11660 int my_sigaddset(sigset_t *set, int sig) {
11661     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11662     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11663     *set |= (1 << (sig - 1));
11664     return 0;
11665 }
11666 /*}}}*/
11667
11668
11669 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
11670 int my_sigdelset(sigset_t *set, int sig) {
11671     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11672     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11673     *set &= ~(1 << (sig - 1));
11674     return 0;
11675 }
11676 /*}}}*/
11677
11678
11679 /*{{{int my_sigismember(sigset_t *set, int sig)*/
11680 int my_sigismember(sigset_t *set, int sig) {
11681     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11682     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11683     return *set & (1 << (sig - 1));
11684 }
11685 /*}}}*/
11686
11687
11688 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
11689 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
11690     sigset_t tempmask;
11691
11692     /* If set and oset are both null, then things are badly wrong. Bail out. */
11693     if ((oset == NULL) && (set == NULL)) {
11694       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
11695       return -1;
11696     }
11697
11698     /* If set's null, then we're just handling a fetch. */
11699     if (set == NULL) {
11700         tempmask = sigblock(0);
11701     }
11702     else {
11703       switch (how) {
11704       case SIG_SETMASK:
11705         tempmask = sigsetmask(*set);
11706         break;
11707       case SIG_BLOCK:
11708         tempmask = sigblock(*set);
11709         break;
11710       case SIG_UNBLOCK:
11711         tempmask = sigblock(0);
11712         sigsetmask(*oset & ~tempmask);
11713         break;
11714       default:
11715         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11716         return -1;
11717       }
11718     }
11719
11720     /* Did they pass us an oset? If so, stick our holding mask into it */
11721     if (oset)
11722       *oset = tempmask;
11723
11724     return 0;
11725 }
11726 /*}}}*/
11727 #endif  /* HOMEGROWN_POSIX_SIGNALS */
11728
11729
11730 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11731  * my_utime(), and flex_stat(), all of which operate on UTC unless
11732  * VMSISH_TIMES is true.
11733  */
11734 /* method used to handle UTC conversions:
11735  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
11736  */
11737 static int gmtime_emulation_type;
11738 /* number of secs to add to UTC POSIX-style time to get local time */
11739 static long int utc_offset_secs;
11740
11741 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11742  * in vmsish.h.  #undef them here so we can call the CRTL routines
11743  * directly.
11744  */
11745 #undef gmtime
11746 #undef localtime
11747 #undef time
11748
11749
11750 /*
11751  * DEC C previous to 6.0 corrupts the behavior of the /prefix
11752  * qualifier with the extern prefix pragma.  This provisional
11753  * hack circumvents this prefix pragma problem in previous
11754  * precompilers.
11755  */
11756 #if defined(__VMS_VER) && __VMS_VER >= 70000000
11757 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
11758 #    pragma __extern_prefix save
11759 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
11760 #    define gmtime decc$__utctz_gmtime
11761 #    define localtime decc$__utctz_localtime
11762 #    define time decc$__utc_time
11763 #    pragma __extern_prefix restore
11764
11765      struct tm *gmtime(), *localtime();
11766
11767 #  endif
11768 #endif
11769
11770
11771 static time_t toutc_dst(time_t loc) {
11772   struct tm *rsltmp;
11773
11774   if ((rsltmp = localtime(&loc)) == NULL) return -1;
11775   loc -= utc_offset_secs;
11776   if (rsltmp->tm_isdst) loc -= 3600;
11777   return loc;
11778 }
11779 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11780        ((gmtime_emulation_type || my_time(NULL)), \
11781        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11782        ((secs) - utc_offset_secs))))
11783
11784 static time_t toloc_dst(time_t utc) {
11785   struct tm *rsltmp;
11786
11787   utc += utc_offset_secs;
11788   if ((rsltmp = localtime(&utc)) == NULL) return -1;
11789   if (rsltmp->tm_isdst) utc += 3600;
11790   return utc;
11791 }
11792 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11793        ((gmtime_emulation_type || my_time(NULL)), \
11794        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11795        ((secs) + utc_offset_secs))))
11796
11797 #ifndef RTL_USES_UTC
11798 /*
11799
11800     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
11801         DST starts on 1st sun of april      at 02:00  std time
11802             ends on last sun of october     at 02:00  dst time
11803     see the UCX management command reference, SET CONFIG TIMEZONE
11804     for formatting info.
11805
11806     No, it's not as general as it should be, but then again, NOTHING
11807     will handle UK times in a sensible way.
11808 */
11809
11810
11811 /*
11812     parse the DST start/end info:
11813     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
11814 */
11815
11816 static char *
11817 tz_parse_startend(char *s, struct tm *w, int *past)
11818 {
11819     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
11820     int ly, dozjd, d, m, n, hour, min, sec, j, k;
11821     time_t g;
11822
11823     if (!s)    return 0;
11824     if (!w) return 0;
11825     if (!past) return 0;
11826
11827     ly = 0;
11828     if (w->tm_year % 4        == 0) ly = 1;
11829     if (w->tm_year % 100      == 0) ly = 0;
11830     if (w->tm_year+1900 % 400 == 0) ly = 1;
11831     if (ly) dinm[1]++;
11832
11833     dozjd = isdigit(*s);
11834     if (*s == 'J' || *s == 'j' || dozjd) {
11835         if (!dozjd && !isdigit(*++s)) return 0;
11836         d = *s++ - '0';
11837         if (isdigit(*s)) {
11838             d = d*10 + *s++ - '0';
11839             if (isdigit(*s)) {
11840                 d = d*10 + *s++ - '0';
11841             }
11842         }
11843         if (d == 0) return 0;
11844         if (d > 366) return 0;
11845         d--;
11846         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
11847         g = d * 86400;
11848         dozjd = 1;
11849     } else if (*s == 'M' || *s == 'm') {
11850         if (!isdigit(*++s)) return 0;
11851         m = *s++ - '0';
11852         if (isdigit(*s)) m = 10*m + *s++ - '0';
11853         if (*s != '.') return 0;
11854         if (!isdigit(*++s)) return 0;
11855         n = *s++ - '0';
11856         if (n < 1 || n > 5) return 0;
11857         if (*s != '.') return 0;
11858         if (!isdigit(*++s)) return 0;
11859         d = *s++ - '0';
11860         if (d > 6) return 0;
11861     }
11862
11863     if (*s == '/') {
11864         if (!isdigit(*++s)) return 0;
11865         hour = *s++ - '0';
11866         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
11867         if (*s == ':') {
11868             if (!isdigit(*++s)) return 0;
11869             min = *s++ - '0';
11870             if (isdigit(*s)) min = 10*min + *s++ - '0';
11871             if (*s == ':') {
11872                 if (!isdigit(*++s)) return 0;
11873                 sec = *s++ - '0';
11874                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
11875             }
11876         }
11877     } else {
11878         hour = 2;
11879         min = 0;
11880         sec = 0;
11881     }
11882
11883     if (dozjd) {
11884         if (w->tm_yday < d) goto before;
11885         if (w->tm_yday > d) goto after;
11886     } else {
11887         if (w->tm_mon+1 < m) goto before;
11888         if (w->tm_mon+1 > m) goto after;
11889
11890         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
11891         k = d - j; /* mday of first d */
11892         if (k <= 0) k += 7;
11893         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
11894         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
11895         if (w->tm_mday < k) goto before;
11896         if (w->tm_mday > k) goto after;
11897     }
11898
11899     if (w->tm_hour < hour) goto before;
11900     if (w->tm_hour > hour) goto after;
11901     if (w->tm_min  < min)  goto before;
11902     if (w->tm_min  > min)  goto after;
11903     if (w->tm_sec  < sec)  goto before;
11904     goto after;
11905
11906 before:
11907     *past = 0;
11908     return s;
11909 after:
11910     *past = 1;
11911     return s;
11912 }
11913
11914
11915
11916
11917 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
11918
11919 static char *
11920 tz_parse_offset(char *s, int *offset)
11921 {
11922     int hour = 0, min = 0, sec = 0;
11923     int neg = 0;
11924     if (!s) return 0;
11925     if (!offset) return 0;
11926
11927     if (*s == '-') {neg++; s++;}
11928     if (*s == '+') s++;
11929     if (!isdigit(*s)) return 0;
11930     hour = *s++ - '0';
11931     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
11932     if (hour > 24) return 0;
11933     if (*s == ':') {
11934         if (!isdigit(*++s)) return 0;
11935         min = *s++ - '0';
11936         if (isdigit(*s)) min = min*10 + (*s++ - '0');
11937         if (min > 59) return 0;
11938         if (*s == ':') {
11939             if (!isdigit(*++s)) return 0;
11940             sec = *s++ - '0';
11941             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
11942             if (sec > 59) return 0;
11943         }
11944     }
11945
11946     *offset = (hour*60+min)*60 + sec;
11947     if (neg) *offset = -*offset;
11948     return s;
11949 }
11950
11951 /*
11952     input time is w, whatever type of time the CRTL localtime() uses.
11953     sets dst, the zone, and the gmtoff (seconds)
11954
11955     caches the value of TZ and UCX$TZ env variables; note that
11956     my_setenv looks for these and sets a flag if they're changed
11957     for efficiency.
11958
11959     We have to watch out for the "australian" case (dst starts in
11960     october, ends in april)...flagged by "reverse" and checked by
11961     scanning through the months of the previous year.
11962
11963 */
11964
11965 static int
11966 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
11967 {
11968     time_t when;
11969     struct tm *w2;
11970     char *s,*s2;
11971     char *dstzone, *tz, *s_start, *s_end;
11972     int std_off, dst_off, isdst;
11973     int y, dststart, dstend;
11974     static char envtz[1025];  /* longer than any logical, symbol, ... */
11975     static char ucxtz[1025];
11976     static char reversed = 0;
11977
11978     if (!w) return 0;
11979
11980     if (tz_updated) {
11981         tz_updated = 0;
11982         reversed = -1;  /* flag need to check  */
11983         envtz[0] = ucxtz[0] = '\0';
11984         tz = my_getenv("TZ",0);
11985         if (tz) strcpy(envtz, tz);
11986         tz = my_getenv("UCX$TZ",0);
11987         if (tz) strcpy(ucxtz, tz);
11988         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
11989     }
11990     tz = envtz;
11991     if (!*tz) tz = ucxtz;
11992
11993     s = tz;
11994     while (isalpha(*s)) s++;
11995     s = tz_parse_offset(s, &std_off);
11996     if (!s) return 0;
11997     if (!*s) {                  /* no DST, hurray we're done! */
11998         isdst = 0;
11999         goto done;
12000     }
12001
12002     dstzone = s;
12003     while (isalpha(*s)) s++;
12004     s2 = tz_parse_offset(s, &dst_off);
12005     if (s2) {
12006         s = s2;
12007     } else {
12008         dst_off = std_off - 3600;
12009     }
12010
12011     if (!*s) {      /* default dst start/end?? */
12012         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
12013             s = strchr(ucxtz,',');
12014         }
12015         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
12016     }
12017     if (*s != ',') return 0;
12018
12019     when = *w;
12020     when = _toutc(when);      /* convert to utc */
12021     when = when - std_off;    /* convert to pseudolocal time*/
12022
12023     w2 = localtime(&when);
12024     y = w2->tm_year;
12025     s_start = s+1;
12026     s = tz_parse_startend(s_start,w2,&dststart);
12027     if (!s) return 0;
12028     if (*s != ',') return 0;
12029
12030     when = *w;
12031     when = _toutc(when);      /* convert to utc */
12032     when = when - dst_off;    /* convert to pseudolocal time*/
12033     w2 = localtime(&when);
12034     if (w2->tm_year != y) {   /* spans a year, just check one time */
12035         when += dst_off - std_off;
12036         w2 = localtime(&when);
12037     }
12038     s_end = s+1;
12039     s = tz_parse_startend(s_end,w2,&dstend);
12040     if (!s) return 0;
12041
12042     if (reversed == -1) {  /* need to check if start later than end */
12043         int j, ds, de;
12044
12045         when = *w;
12046         if (when < 2*365*86400) {
12047             when += 2*365*86400;
12048         } else {
12049             when -= 365*86400;
12050         }
12051         w2 =localtime(&when);
12052         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
12053
12054         for (j = 0; j < 12; j++) {
12055             w2 =localtime(&when);
12056             tz_parse_startend(s_start,w2,&ds);
12057             tz_parse_startend(s_end,w2,&de);
12058             if (ds != de) break;
12059             when += 30*86400;
12060         }
12061         reversed = 0;
12062         if (de && !ds) reversed = 1;
12063     }
12064
12065     isdst = dststart && !dstend;
12066     if (reversed) isdst = dststart  || !dstend;
12067
12068 done:
12069     if (dst)    *dst = isdst;
12070     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
12071     if (isdst)  tz = dstzone;
12072     if (zone) {
12073         while(isalpha(*tz))  *zone++ = *tz++;
12074         *zone = '\0';
12075     }
12076     return 1;
12077 }
12078
12079 #endif /* !RTL_USES_UTC */
12080
12081 /* my_time(), my_localtime(), my_gmtime()
12082  * By default traffic in UTC time values, using CRTL gmtime() or
12083  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
12084  * Note: We need to use these functions even when the CRTL has working
12085  * UTC support, since they also handle C<use vmsish qw(times);>
12086  *
12087  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
12088  * Modified by Charles Bailey <bailey@newman.upenn.edu>
12089  */
12090
12091 /*{{{time_t my_time(time_t *timep)*/
12092 time_t Perl_my_time(pTHX_ time_t *timep)
12093 {
12094   time_t when;
12095   struct tm *tm_p;
12096
12097   if (gmtime_emulation_type == 0) {
12098     int dstnow;
12099     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
12100                               /* results of calls to gmtime() and localtime() */
12101                               /* for same &base */
12102
12103     gmtime_emulation_type++;
12104     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
12105       char off[LNM$C_NAMLENGTH+1];;
12106
12107       gmtime_emulation_type++;
12108       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
12109         gmtime_emulation_type++;
12110         utc_offset_secs = 0;
12111         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
12112       }
12113       else { utc_offset_secs = atol(off); }
12114     }
12115     else { /* We've got a working gmtime() */
12116       struct tm gmt, local;
12117
12118       gmt = *tm_p;
12119       tm_p = localtime(&base);
12120       local = *tm_p;
12121       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
12122       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
12123       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
12124       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
12125     }
12126   }
12127
12128   when = time(NULL);
12129 # ifdef VMSISH_TIME
12130 # ifdef RTL_USES_UTC
12131   if (VMSISH_TIME) when = _toloc(when);
12132 # else
12133   if (!VMSISH_TIME) when = _toutc(when);
12134 # endif
12135 # endif
12136   if (timep != NULL) *timep = when;
12137   return when;
12138
12139 }  /* end of my_time() */
12140 /*}}}*/
12141
12142
12143 /*{{{struct tm *my_gmtime(const time_t *timep)*/
12144 struct tm *
12145 Perl_my_gmtime(pTHX_ const time_t *timep)
12146 {
12147   char *p;
12148   time_t when;
12149   struct tm *rsltmp;
12150
12151   if (timep == NULL) {
12152     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12153     return NULL;
12154   }
12155   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
12156
12157   when = *timep;
12158 # ifdef VMSISH_TIME
12159   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
12160 #  endif
12161 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
12162   return gmtime(&when);
12163 # else
12164   /* CRTL localtime() wants local time as input, so does no tz correction */
12165   rsltmp = localtime(&when);
12166   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
12167   return rsltmp;
12168 #endif
12169 }  /* end of my_gmtime() */
12170 /*}}}*/
12171
12172
12173 /*{{{struct tm *my_localtime(const time_t *timep)*/
12174 struct tm *
12175 Perl_my_localtime(pTHX_ const time_t *timep)
12176 {
12177   time_t when, whenutc;
12178   struct tm *rsltmp;
12179   int dst, offset;
12180
12181   if (timep == NULL) {
12182     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12183     return NULL;
12184   }
12185   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
12186   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
12187
12188   when = *timep;
12189 # ifdef RTL_USES_UTC
12190 # ifdef VMSISH_TIME
12191   if (VMSISH_TIME) when = _toutc(when);
12192 # endif
12193   /* CRTL localtime() wants UTC as input, does tz correction itself */
12194   return localtime(&when);
12195
12196 # else /* !RTL_USES_UTC */
12197   whenutc = when;
12198 # ifdef VMSISH_TIME
12199   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
12200   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
12201 # endif
12202   dst = -1;
12203 #ifndef RTL_USES_UTC
12204   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
12205       when = whenutc - offset;                   /* pseudolocal time*/
12206   }
12207 # endif
12208   /* CRTL localtime() wants local time as input, so does no tz correction */
12209   rsltmp = localtime(&when);
12210   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
12211   return rsltmp;
12212 # endif
12213
12214 } /*  end of my_localtime() */
12215 /*}}}*/
12216
12217 /* Reset definitions for later calls */
12218 #define gmtime(t)    my_gmtime(t)
12219 #define localtime(t) my_localtime(t)
12220 #define time(t)      my_time(t)
12221
12222
12223 /* my_utime - update modification/access time of a file
12224  *
12225  * VMS 7.3 and later implementation
12226  * Only the UTC translation is home-grown. The rest is handled by the
12227  * CRTL utime(), which will take into account the relevant feature
12228  * logicals and ODS-5 volume characteristics for true access times.
12229  *
12230  * pre VMS 7.3 implementation:
12231  * The calling sequence is identical to POSIX utime(), but under
12232  * VMS with ODS-2, only the modification time is changed; ODS-2 does
12233  * not maintain access times.  Restrictions differ from the POSIX
12234  * definition in that the time can be changed as long as the
12235  * caller has permission to execute the necessary IO$_MODIFY $QIO;
12236  * no separate checks are made to insure that the caller is the
12237  * owner of the file or has special privs enabled.
12238  * Code here is based on Joe Meadows' FILE utility.
12239  *
12240  */
12241
12242 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
12243  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
12244  * in 100 ns intervals.
12245  */
12246 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
12247
12248 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
12249 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
12250 {
12251 #if __CRTL_VER >= 70300000
12252   struct utimbuf utc_utimes, *utc_utimesp;
12253
12254   if (utimes != NULL) {
12255     utc_utimes.actime = utimes->actime;
12256     utc_utimes.modtime = utimes->modtime;
12257 # ifdef VMSISH_TIME
12258     /* If input was local; convert to UTC for sys svc */
12259     if (VMSISH_TIME) {
12260       utc_utimes.actime = _toutc(utimes->actime);
12261       utc_utimes.modtime = _toutc(utimes->modtime);
12262     }
12263 # endif
12264     utc_utimesp = &utc_utimes;
12265   }
12266   else {
12267     utc_utimesp = NULL;
12268   }
12269
12270   return utime(file, utc_utimesp);
12271
12272 #else /* __CRTL_VER < 70300000 */
12273
12274   register int i;
12275   int sts;
12276   long int bintime[2], len = 2, lowbit, unixtime,
12277            secscale = 10000000; /* seconds --> 100 ns intervals */
12278   unsigned long int chan, iosb[2], retsts;
12279   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
12280   struct FAB myfab = cc$rms_fab;
12281   struct NAM mynam = cc$rms_nam;
12282 #if defined (__DECC) && defined (__VAX)
12283   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
12284    * at least through VMS V6.1, which causes a type-conversion warning.
12285    */
12286 #  pragma message save
12287 #  pragma message disable cvtdiftypes
12288 #endif
12289   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
12290   struct fibdef myfib;
12291 #if defined (__DECC) && defined (__VAX)
12292   /* This should be right after the declaration of myatr, but due
12293    * to a bug in VAX DEC C, this takes effect a statement early.
12294    */
12295 #  pragma message restore
12296 #endif
12297   /* cast ok for read only parameter */
12298   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
12299                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
12300                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
12301
12302   if (file == NULL || *file == '\0') {
12303     SETERRNO(ENOENT, LIB$_INVARG);
12304     return -1;
12305   }
12306
12307   /* Convert to VMS format ensuring that it will fit in 255 characters */
12308   if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
12309       SETERRNO(ENOENT, LIB$_INVARG);
12310       return -1;
12311   }
12312   if (utimes != NULL) {
12313     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
12314      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
12315      * Since time_t is unsigned long int, and lib$emul takes a signed long int
12316      * as input, we force the sign bit to be clear by shifting unixtime right
12317      * one bit, then multiplying by an extra factor of 2 in lib$emul().
12318      */
12319     lowbit = (utimes->modtime & 1) ? secscale : 0;
12320     unixtime = (long int) utimes->modtime;
12321 #   ifdef VMSISH_TIME
12322     /* If input was UTC; convert to local for sys svc */
12323     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
12324 #   endif
12325     unixtime >>= 1;  secscale <<= 1;
12326     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
12327     if (!(retsts & 1)) {
12328       SETERRNO(EVMSERR, retsts);
12329       return -1;
12330     }
12331     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
12332     if (!(retsts & 1)) {
12333       SETERRNO(EVMSERR, retsts);
12334       return -1;
12335     }
12336   }
12337   else {
12338     /* Just get the current time in VMS format directly */
12339     retsts = sys$gettim(bintime);
12340     if (!(retsts & 1)) {
12341       SETERRNO(EVMSERR, retsts);
12342       return -1;
12343     }
12344   }
12345
12346   myfab.fab$l_fna = vmsspec;
12347   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
12348   myfab.fab$l_nam = &mynam;
12349   mynam.nam$l_esa = esa;
12350   mynam.nam$b_ess = (unsigned char) sizeof esa;
12351   mynam.nam$l_rsa = rsa;
12352   mynam.nam$b_rss = (unsigned char) sizeof rsa;
12353   if (decc_efs_case_preserve)
12354       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
12355
12356   /* Look for the file to be affected, letting RMS parse the file
12357    * specification for us as well.  I have set errno using only
12358    * values documented in the utime() man page for VMS POSIX.
12359    */
12360   retsts = sys$parse(&myfab,0,0);
12361   if (!(retsts & 1)) {
12362     set_vaxc_errno(retsts);
12363     if      (retsts == RMS$_PRV) set_errno(EACCES);
12364     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
12365     else                         set_errno(EVMSERR);
12366     return -1;
12367   }
12368   retsts = sys$search(&myfab,0,0);
12369   if (!(retsts & 1)) {
12370     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12371     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12372     set_vaxc_errno(retsts);
12373     if      (retsts == RMS$_PRV) set_errno(EACCES);
12374     else if (retsts == RMS$_FNF) set_errno(ENOENT);
12375     else                         set_errno(EVMSERR);
12376     return -1;
12377   }
12378
12379   devdsc.dsc$w_length = mynam.nam$b_dev;
12380   /* cast ok for read only parameter */
12381   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
12382
12383   retsts = sys$assign(&devdsc,&chan,0,0);
12384   if (!(retsts & 1)) {
12385     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12386     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12387     set_vaxc_errno(retsts);
12388     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
12389     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
12390     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
12391     else                               set_errno(EVMSERR);
12392     return -1;
12393   }
12394
12395   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
12396   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
12397
12398   memset((void *) &myfib, 0, sizeof myfib);
12399 #if defined(__DECC) || defined(__DECCXX)
12400   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
12401   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
12402   /* This prevents the revision time of the file being reset to the current
12403    * time as a result of our IO$_MODIFY $QIO. */
12404   myfib.fib$l_acctl = FIB$M_NORECORD;
12405 #else
12406   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
12407   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
12408   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
12409 #endif
12410   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
12411   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12412   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12413   _ckvmssts(sys$dassgn(chan));
12414   if (retsts & 1) retsts = iosb[0];
12415   if (!(retsts & 1)) {
12416     set_vaxc_errno(retsts);
12417     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12418     else                      set_errno(EVMSERR);
12419     return -1;
12420   }
12421
12422   return 0;
12423
12424 #endif /* #if __CRTL_VER >= 70300000 */
12425
12426 }  /* end of my_utime() */
12427 /*}}}*/
12428
12429 /*
12430  * flex_stat, flex_lstat, flex_fstat
12431  * basic stat, but gets it right when asked to stat
12432  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
12433  */
12434
12435 #ifndef _USE_STD_STAT
12436 /* encode_dev packs a VMS device name string into an integer to allow
12437  * simple comparisons. This can be used, for example, to check whether two
12438  * files are located on the same device, by comparing their encoded device
12439  * names. Even a string comparison would not do, because stat() reuses the
12440  * device name buffer for each call; so without encode_dev, it would be
12441  * necessary to save the buffer and use strcmp (this would mean a number of
12442  * changes to the standard Perl code, to say nothing of what a Perl script
12443  * would have to do.
12444  *
12445  * The device lock id, if it exists, should be unique (unless perhaps compared
12446  * with lock ids transferred from other nodes). We have a lock id if the disk is
12447  * mounted cluster-wide, which is when we tend to get long (host-qualified)
12448  * device names. Thus we use the lock id in preference, and only if that isn't
12449  * available, do we try to pack the device name into an integer (flagged by
12450  * the sign bit (LOCKID_MASK) being set).
12451  *
12452  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
12453  * name and its encoded form, but it seems very unlikely that we will find
12454  * two files on different disks that share the same encoded device names,
12455  * and even more remote that they will share the same file id (if the test
12456  * is to check for the same file).
12457  *
12458  * A better method might be to use sys$device_scan on the first call, and to
12459  * search for the device, returning an index into the cached array.
12460  * The number returned would be more intelligible.
12461  * This is probably not worth it, and anyway would take quite a bit longer
12462  * on the first call.
12463  */
12464 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
12465 static mydev_t encode_dev (pTHX_ const char *dev)
12466 {
12467   int i;
12468   unsigned long int f;
12469   mydev_t enc;
12470   char c;
12471   const char *q;
12472
12473   if (!dev || !dev[0]) return 0;
12474
12475 #if LOCKID_MASK
12476   {
12477     struct dsc$descriptor_s dev_desc;
12478     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
12479
12480     /* For cluster-mounted disks, the disk lock identifier is unique, so we
12481        can try that first. */
12482     dev_desc.dsc$w_length =  strlen (dev);
12483     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
12484     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
12485     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
12486     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
12487     if (!$VMS_STATUS_SUCCESS(status)) {
12488       switch (status) {
12489         case SS$_NOSUCHDEV:
12490           SETERRNO(ENODEV, status);
12491           return 0;
12492         default:
12493           _ckvmssts(status);
12494       }
12495     }
12496     if (lockid) return (lockid & ~LOCKID_MASK);
12497   }
12498 #endif
12499
12500   /* Otherwise we try to encode the device name */
12501   enc = 0;
12502   f = 1;
12503   i = 0;
12504   for (q = dev + strlen(dev); q--; q >= dev) {
12505     if (*q == ':')
12506         break;
12507     if (isdigit (*q))
12508       c= (*q) - '0';
12509     else if (isalpha (toupper (*q)))
12510       c= toupper (*q) - 'A' + (char)10;
12511     else
12512       continue; /* Skip '$'s */
12513     i++;
12514     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
12515     if (i>1) f *= 36;
12516     enc += f * (unsigned long int) c;
12517   }
12518   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
12519
12520 }  /* end of encode_dev() */
12521 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12522         device_no = encode_dev(aTHX_ devname)
12523 #else
12524 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12525         device_no = new_dev_no
12526 #endif
12527
12528 static int
12529 is_null_device(name)
12530     const char *name;
12531 {
12532   if (decc_bug_devnull != 0) {
12533     if (strncmp("/dev/null", name, 9) == 0)
12534       return 1;
12535   }
12536     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
12537        The underscore prefix, controller letter, and unit number are
12538        independently optional; for our purposes, the colon punctuation
12539        is not.  The colon can be trailed by optional directory and/or
12540        filename, but two consecutive colons indicates a nodename rather
12541        than a device.  [pr]  */
12542   if (*name == '_') ++name;
12543   if (tolower(*name++) != 'n') return 0;
12544   if (tolower(*name++) != 'l') return 0;
12545   if (tolower(*name) == 'a') ++name;
12546   if (*name == '0') ++name;
12547   return (*name++ == ':') && (*name != ':');
12548 }
12549
12550 static int
12551 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
12552
12553 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
12554
12555 static I32
12556 Perl_cando_by_name_int
12557    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
12558 {
12559   char usrname[L_cuserid];
12560   struct dsc$descriptor_s usrdsc =
12561          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
12562   char *vmsname = NULL, *fileified = NULL;
12563   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
12564   unsigned short int retlen, trnlnm_iter_count;
12565   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12566   union prvdef curprv;
12567   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
12568          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
12569          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
12570   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
12571          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
12572          {0,0,0,0}};
12573   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
12574          {0,0,0,0}};
12575   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12576   Stat_t st;
12577   static int profile_context = -1;
12578
12579   if (!fname || !*fname) return FALSE;
12580
12581   /* Make sure we expand logical names, since sys$check_access doesn't */
12582   fileified = PerlMem_malloc(VMS_MAXRSS);
12583   if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12584   if (!strpbrk(fname,"/]>:")) {
12585       strcpy(fileified,fname);
12586       trnlnm_iter_count = 0;
12587       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
12588         trnlnm_iter_count++;
12589         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
12590       }
12591       fname = fileified;
12592   }
12593
12594   vmsname = PerlMem_malloc(VMS_MAXRSS);
12595   if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12596   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
12597     /* Don't know if already in VMS format, so make sure */
12598     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
12599       PerlMem_free(fileified);
12600       PerlMem_free(vmsname);
12601       return FALSE;
12602     }
12603   }
12604   else {
12605     strcpy(vmsname,fname);
12606   }
12607
12608   /* sys$check_access needs a file spec, not a directory spec.
12609    * flex_stat now will handle a null thread context during startup.
12610    */
12611
12612   retlen = namdsc.dsc$w_length = strlen(vmsname);
12613   if (vmsname[retlen-1] == ']'
12614       || vmsname[retlen-1] == '>'
12615       || vmsname[retlen-1] == ':'
12616       || (!flex_stat_int(vmsname, &st, 1) &&
12617           S_ISDIR(st.st_mode))) {
12618
12619       if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
12620         PerlMem_free(fileified);
12621         PerlMem_free(vmsname);
12622         return FALSE;
12623       }
12624       fname = fileified;
12625   }
12626   else {
12627       fname = vmsname;
12628   }
12629
12630   retlen = namdsc.dsc$w_length = strlen(fname);
12631   namdsc.dsc$a_pointer = (char *)fname;
12632
12633   switch (bit) {
12634     case S_IXUSR: case S_IXGRP: case S_IXOTH:
12635       access = ARM$M_EXECUTE;
12636       flags = CHP$M_READ;
12637       break;
12638     case S_IRUSR: case S_IRGRP: case S_IROTH:
12639       access = ARM$M_READ;
12640       flags = CHP$M_READ | CHP$M_USEREADALL;
12641       break;
12642     case S_IWUSR: case S_IWGRP: case S_IWOTH:
12643       access = ARM$M_WRITE;
12644       flags = CHP$M_READ | CHP$M_WRITE;
12645       break;
12646     case S_IDUSR: case S_IDGRP: case S_IDOTH:
12647       access = ARM$M_DELETE;
12648       flags = CHP$M_READ | CHP$M_WRITE;
12649       break;
12650     default:
12651       if (fileified != NULL)
12652         PerlMem_free(fileified);
12653       if (vmsname != NULL)
12654         PerlMem_free(vmsname);
12655       return FALSE;
12656   }
12657
12658   /* Before we call $check_access, create a user profile with the current
12659    * process privs since otherwise it just uses the default privs from the
12660    * UAF and might give false positives or negatives.  This only works on
12661    * VMS versions v6.0 and later since that's when sys$create_user_profile
12662    * became available.
12663    */
12664
12665   /* get current process privs and username */
12666   _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
12667   _ckvmssts_noperl(iosb[0]);
12668
12669 #if defined(__VMS_VER) && __VMS_VER >= 60000000
12670
12671   /* find out the space required for the profile */
12672   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
12673                                     &usrprodsc.dsc$w_length,&profile_context));
12674
12675   /* allocate space for the profile and get it filled in */
12676   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
12677   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12678   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
12679                                     &usrprodsc.dsc$w_length,&profile_context));
12680
12681   /* use the profile to check access to the file; free profile & analyze results */
12682   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
12683   PerlMem_free(usrprodsc.dsc$a_pointer);
12684   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
12685
12686 #else
12687
12688   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
12689
12690 #endif
12691
12692   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
12693       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
12694       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
12695     set_vaxc_errno(retsts);
12696     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12697     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12698     else set_errno(ENOENT);
12699     if (fileified != NULL)
12700       PerlMem_free(fileified);
12701     if (vmsname != NULL)
12702       PerlMem_free(vmsname);
12703     return FALSE;
12704   }
12705   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12706     if (fileified != NULL)
12707       PerlMem_free(fileified);
12708     if (vmsname != NULL)
12709       PerlMem_free(vmsname);
12710     return TRUE;
12711   }
12712   _ckvmssts_noperl(retsts);
12713
12714   if (fileified != NULL)
12715     PerlMem_free(fileified);
12716   if (vmsname != NULL)
12717     PerlMem_free(vmsname);
12718   return FALSE;  /* Should never get here */
12719
12720 }
12721
12722 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
12723 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12724  * subset of the applicable information.
12725  */
12726 bool
12727 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12728 {
12729   return cando_by_name_int
12730         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12731 }  /* end of cando() */
12732 /*}}}*/
12733
12734
12735 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12736 I32
12737 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12738 {
12739    return cando_by_name_int(bit, effective, fname, 0);
12740
12741 }  /* end of cando_by_name() */
12742 /*}}}*/
12743
12744
12745 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12746 int
12747 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12748 {
12749   if (!fstat(fd, &statbufp->crtl_stat)) {
12750     char *cptr;
12751     char *vms_filename;
12752     vms_filename = PerlMem_malloc(VMS_MAXRSS);
12753     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12754
12755     /* Save name for cando by name in VMS format */
12756     cptr = getname(fd, vms_filename, 1);
12757
12758     /* This should not happen, but just in case */
12759     if (cptr == NULL) {
12760         statbufp->st_devnam[0] = 0;
12761     }
12762     else {
12763         /* Make sure that the saved name fits in 255 characters */
12764         cptr = int_rmsexpand_vms
12765                        (vms_filename,
12766                         statbufp->st_devnam,
12767                         0);
12768         if (cptr == NULL)
12769             statbufp->st_devnam[0] = 0;
12770     }
12771     PerlMem_free(vms_filename);
12772
12773     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12774     VMS_DEVICE_ENCODE
12775         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12776
12777 #   ifdef RTL_USES_UTC
12778 #   ifdef VMSISH_TIME
12779     if (VMSISH_TIME) {
12780       statbufp->st_mtime = _toloc(statbufp->st_mtime);
12781       statbufp->st_atime = _toloc(statbufp->st_atime);
12782       statbufp->st_ctime = _toloc(statbufp->st_ctime);
12783     }
12784 #   endif
12785 #   else
12786 #   ifdef VMSISH_TIME
12787     if (!VMSISH_TIME) { /* Return UTC instead of local time */
12788 #   else
12789     if (1) {
12790 #   endif
12791       statbufp->st_mtime = _toutc(statbufp->st_mtime);
12792       statbufp->st_atime = _toutc(statbufp->st_atime);
12793       statbufp->st_ctime = _toutc(statbufp->st_ctime);
12794     }
12795 #endif
12796     return 0;
12797   }
12798   return -1;
12799
12800 }  /* end of flex_fstat() */
12801 /*}}}*/
12802
12803 static int
12804 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12805 {
12806     char *fileified;
12807     char *temp_fspec;
12808     const char *save_spec;
12809     char *ret_spec;
12810     int retval = -1;
12811     int efs_hack = 0;
12812     dSAVEDERRNO;
12813
12814     if (!fspec) {
12815         errno = EINVAL;
12816         return retval;
12817     }
12818
12819     if (decc_bug_devnull != 0) {
12820       if (is_null_device(fspec)) { /* Fake a stat() for the null device */
12821         memset(statbufp,0,sizeof *statbufp);
12822         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12823         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12824         statbufp->st_uid = 0x00010001;
12825         statbufp->st_gid = 0x0001;
12826         time((time_t *)&statbufp->st_mtime);
12827         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12828         return 0;
12829       }
12830     }
12831
12832     /* Try for a directory name first.  If fspec contains a filename without
12833      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12834      * and sea:[wine.dark]water. exist, we prefer the directory here.
12835      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12836      * not sea:[wine.dark]., if the latter exists.  If the intended target is
12837      * the file with null type, specify this by calling flex_stat() with
12838      * a '.' at the end of fspec.
12839      *
12840      * If we are in Posix filespec mode, accept the filename as is.
12841      */
12842
12843
12844     fileified = PerlMem_malloc(VMS_MAXRSS);
12845     if (fileified == NULL)
12846         _ckvmssts_noperl(SS$_INSFMEM);
12847
12848     temp_fspec = PerlMem_malloc(VMS_MAXRSS);
12849     if (temp_fspec == NULL)
12850         _ckvmssts_noperl(SS$_INSFMEM);
12851
12852     strcpy(temp_fspec, fspec);
12853
12854     SAVE_ERRNO;
12855
12856 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12857   if (decc_posix_compliant_pathnames == 0) {
12858 #endif
12859
12860     /* We may be able to optimize this, but in order for fileify_dirspec to
12861      * always return a usuable answer, we have to call vmspath first to
12862      * make sure that it is in VMS directory format, as stat/lstat on 8.3
12863      * can not handle directories in unix format that it does not have read
12864      * access to.  Vmspath handles the case where a bare name which could be
12865      * a logical name gets passed.
12866      */
12867     ret_spec = int_tovmspath(fspec, temp_fspec, NULL);
12868     if (ret_spec != NULL) {
12869         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
12870         if (ret_spec != NULL) {
12871             if (lstat_flag == 0)
12872                 retval = stat(fileified, &statbufp->crtl_stat);
12873             else
12874                 retval = lstat(fileified, &statbufp->crtl_stat);
12875             save_spec = fileified;
12876         }
12877     }
12878
12879     if (retval && vms_bug_stat_filename) {
12880
12881         /* We should try again as a vmsified file specification */
12882         /* However Perl traditionally has not done this, which  */
12883         /* causes problems with existing tests */
12884
12885         ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12886         if (ret_spec != NULL) {
12887             if (lstat_flag == 0)
12888                 retval = stat(temp_fspec, &statbufp->crtl_stat);
12889             else
12890                 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12891             save_spec = temp_fspec;
12892         }
12893     }
12894
12895     if (retval) {
12896         /* Last chance - allow multiple dots with out EFS CHARSET */
12897         /* The CRTL stat() falls down hard on multi-dot filenames in unix
12898          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12899          * enable it if it isn't already.
12900          */
12901 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12902         if (!decc_efs_charset && (decc_efs_charset_index > 0))
12903             decc$feature_set_value(decc_efs_charset_index, 1, 1);
12904 #endif
12905         if (lstat_flag == 0)
12906             retval = stat(fspec, &statbufp->crtl_stat);
12907         else
12908             retval = lstat(fspec, &statbufp->crtl_stat);
12909         save_spec = fspec;
12910 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12911         if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
12912             decc$feature_set_value(decc_efs_charset_index, 1, 0);
12913             efs_hack = 1;
12914         }
12915 #endif
12916     }
12917
12918 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12919   } else {
12920     if (lstat_flag == 0)
12921       retval = stat(temp_fspec, &statbufp->crtl_stat);
12922     else
12923       retval = lstat(temp_fspec, &statbufp->crtl_stat);
12924       save_spec = temp_fspec;
12925   }
12926 #endif
12927
12928 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12929   /* As you were... */
12930   if (!decc_efs_charset)
12931     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12932 #endif
12933
12934     if (!retval) {
12935     char * cptr;
12936     int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12937
12938       /* If this is an lstat, do not follow the link */
12939       if (lstat_flag)
12940         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12941
12942 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12943       /* If we used the efs_hack above, we must also use it here for */
12944       /* perl_cando to work */
12945       if (efs_hack && (decc_efs_charset_index > 0)) {
12946           decc$feature_set_value(decc_efs_charset_index, 1, 1);
12947       }
12948 #endif
12949       cptr = int_rmsexpand_tovms(save_spec, statbufp->st_devnam, rmsex_flags);
12950 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12951       if (efs_hack && (decc_efs_charset_index > 0)) {
12952           decc$feature_set_value(decc_efs_charset, 1, 0);
12953       }
12954 #endif
12955
12956       /* Fix me: If this is NULL then stat found a file, and we could */
12957       /* not convert the specification to VMS - Should never happen */
12958       if (cptr == NULL)
12959         statbufp->st_devnam[0] = 0;
12960
12961       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12962       VMS_DEVICE_ENCODE
12963         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12964 #     ifdef RTL_USES_UTC
12965 #     ifdef VMSISH_TIME
12966       if (VMSISH_TIME) {
12967         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12968         statbufp->st_atime = _toloc(statbufp->st_atime);
12969         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12970       }
12971 #     endif
12972 #     else
12973 #     ifdef VMSISH_TIME
12974       if (!VMSISH_TIME) { /* Return UTC instead of local time */
12975 #     else
12976       if (1) {
12977 #     endif
12978         statbufp->st_mtime = _toutc(statbufp->st_mtime);
12979         statbufp->st_atime = _toutc(statbufp->st_atime);
12980         statbufp->st_ctime = _toutc(statbufp->st_ctime);
12981       }
12982 #     endif
12983     }
12984     /* If we were successful, leave errno where we found it */
12985     if (retval == 0) RESTORE_ERRNO;
12986     return retval;
12987
12988 }  /* end of flex_stat_int() */
12989
12990
12991 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12992 int
12993 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12994 {
12995    return flex_stat_int(fspec, statbufp, 0);
12996 }
12997 /*}}}*/
12998
12999 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
13000 int
13001 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
13002 {
13003    return flex_stat_int(fspec, statbufp, 1);
13004 }
13005 /*}}}*/
13006
13007
13008 /*{{{char *my_getlogin()*/
13009 /* VMS cuserid == Unix getlogin, except calling sequence */
13010 char *
13011 my_getlogin(void)
13012 {
13013     static char user[L_cuserid];
13014     return cuserid(user);
13015 }
13016 /*}}}*/
13017
13018
13019 /*  rmscopy - copy a file using VMS RMS routines
13020  *
13021  *  Copies contents and attributes of spec_in to spec_out, except owner
13022  *  and protection information.  Name and type of spec_in are used as
13023  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
13024  *  should try to propagate timestamps from the input file to the output file.
13025  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
13026  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
13027  *  propagated to the output file at creation iff the output file specification
13028  *  did not contain an explicit name or type, and the revision date is always
13029  *  updated at the end of the copy operation.  If it is greater than 0, then
13030  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
13031  *  other than the revision date should be propagated, and bit 1 indicates
13032  *  that the revision date should be propagated.
13033  *
13034  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
13035  *
13036  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
13037  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
13038  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
13039  * as part of the Perl standard distribution under the terms of the
13040  * GNU General Public License or the Perl Artistic License.  Copies
13041  * of each may be found in the Perl standard distribution.
13042  */ /* FIXME */
13043 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
13044 int
13045 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
13046 {
13047     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
13048          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
13049     unsigned long int i, sts, sts2;
13050     int dna_len;
13051     struct FAB fab_in, fab_out;
13052     struct RAB rab_in, rab_out;
13053     rms_setup_nam(nam);
13054     rms_setup_nam(nam_out);
13055     struct XABDAT xabdat;
13056     struct XABFHC xabfhc;
13057     struct XABRDT xabrdt;
13058     struct XABSUM xabsum;
13059
13060     vmsin = PerlMem_malloc(VMS_MAXRSS);
13061     if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13062     vmsout = PerlMem_malloc(VMS_MAXRSS);
13063     if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13064     if (!spec_in  || !*spec_in  || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
13065         !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
13066       PerlMem_free(vmsin);
13067       PerlMem_free(vmsout);
13068       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13069       return 0;
13070     }
13071
13072     esa = PerlMem_malloc(VMS_MAXRSS);
13073     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13074     esal = NULL;
13075 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
13076     esal = PerlMem_malloc(VMS_MAXRSS);
13077     if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13078 #endif
13079     fab_in = cc$rms_fab;
13080     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
13081     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
13082     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
13083     fab_in.fab$l_fop = FAB$M_SQO;
13084     rms_bind_fab_nam(fab_in, nam);
13085     fab_in.fab$l_xab = (void *) &xabdat;
13086
13087     rsa = PerlMem_malloc(VMS_MAXRSS);
13088     if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13089     rsal = NULL;
13090 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
13091     rsal = PerlMem_malloc(VMS_MAXRSS);
13092     if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13093 #endif
13094     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
13095     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
13096     rms_nam_esl(nam) = 0;
13097     rms_nam_rsl(nam) = 0;
13098     rms_nam_esll(nam) = 0;
13099     rms_nam_rsll(nam) = 0;
13100 #ifdef NAM$M_NO_SHORT_UPCASE
13101     if (decc_efs_case_preserve)
13102         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
13103 #endif
13104
13105     xabdat = cc$rms_xabdat;        /* To get creation date */
13106     xabdat.xab$l_nxt = (void *) &xabfhc;
13107
13108     xabfhc = cc$rms_xabfhc;        /* To get record length */
13109     xabfhc.xab$l_nxt = (void *) &xabsum;
13110
13111     xabsum = cc$rms_xabsum;        /* To get key and area information */
13112
13113     if (!((sts = sys$open(&fab_in)) & 1)) {
13114       PerlMem_free(vmsin);
13115       PerlMem_free(vmsout);
13116       PerlMem_free(esa);
13117       if (esal != NULL)
13118         PerlMem_free(esal);
13119       PerlMem_free(rsa);
13120       if (rsal != NULL)
13121         PerlMem_free(rsal);
13122       set_vaxc_errno(sts);
13123       switch (sts) {
13124         case RMS$_FNF: case RMS$_DNF:
13125           set_errno(ENOENT); break;
13126         case RMS$_DIR:
13127           set_errno(ENOTDIR); break;
13128         case RMS$_DEV:
13129           set_errno(ENODEV); break;
13130         case RMS$_SYN:
13131           set_errno(EINVAL); break;
13132         case RMS$_PRV:
13133           set_errno(EACCES); break;
13134         default:
13135           set_errno(EVMSERR);
13136       }
13137       return 0;
13138     }
13139
13140     nam_out = nam;
13141     fab_out = fab_in;
13142     fab_out.fab$w_ifi = 0;
13143     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
13144     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
13145     fab_out.fab$l_fop = FAB$M_SQO;
13146     rms_bind_fab_nam(fab_out, nam_out);
13147     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
13148     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
13149     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
13150     esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
13151     if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13152     rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
13153     if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13154     esal_out = NULL;
13155     rsal_out = NULL;
13156 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
13157     esal_out = PerlMem_malloc(VMS_MAXRSS);
13158     if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13159     rsal_out = PerlMem_malloc(VMS_MAXRSS);
13160     if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13161 #endif
13162     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
13163     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
13164
13165     if (preserve_dates == 0) {  /* Act like DCL COPY */
13166       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
13167       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
13168       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
13169         PerlMem_free(vmsin);
13170         PerlMem_free(vmsout);
13171         PerlMem_free(esa);
13172         if (esal != NULL)
13173             PerlMem_free(esal);
13174         PerlMem_free(rsa);
13175         if (rsal != NULL)
13176             PerlMem_free(rsal);
13177         PerlMem_free(esa_out);
13178         if (esal_out != NULL)
13179             PerlMem_free(esal_out);
13180         PerlMem_free(rsa_out);
13181         if (rsal_out != NULL)
13182             PerlMem_free(rsal_out);
13183         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
13184         set_vaxc_errno(sts);
13185         return 0;
13186       }
13187       fab_out.fab$l_xab = (void *) &xabdat;
13188       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
13189         preserve_dates = 1;
13190     }
13191     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
13192       preserve_dates =0;      /* bitmask from this point forward   */
13193
13194     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
13195     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
13196       PerlMem_free(vmsin);
13197       PerlMem_free(vmsout);
13198       PerlMem_free(esa);
13199       if (esal != NULL)
13200           PerlMem_free(esal);
13201       PerlMem_free(rsa);
13202       if (rsal != NULL)
13203           PerlMem_free(rsal);
13204       PerlMem_free(esa_out);
13205       if (esal_out != NULL)
13206           PerlMem_free(esal_out);
13207       PerlMem_free(rsa_out);
13208       if (rsal_out != NULL)
13209           PerlMem_free(rsal_out);
13210       set_vaxc_errno(sts);
13211       switch (sts) {
13212         case RMS$_DNF:
13213           set_errno(ENOENT); break;
13214         case RMS$_DIR:
13215           set_errno(ENOTDIR); break;
13216         case RMS$_DEV:
13217           set_errno(ENODEV); break;
13218         case RMS$_SYN:
13219           set_errno(EINVAL); break;
13220         case RMS$_PRV:
13221           set_errno(EACCES); break;
13222         default:
13223           set_errno(EVMSERR);
13224       }
13225       return 0;
13226     }
13227     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
13228     if (preserve_dates & 2) {
13229       /* sys$close() will process xabrdt, not xabdat */
13230       xabrdt = cc$rms_xabrdt;
13231 #ifndef __GNUC__
13232       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
13233 #else
13234       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
13235        * is unsigned long[2], while DECC & VAXC use a struct */
13236       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
13237 #endif
13238       fab_out.fab$l_xab = (void *) &xabrdt;
13239     }
13240
13241     ubf = PerlMem_malloc(32256);
13242     if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13243     rab_in = cc$rms_rab;
13244     rab_in.rab$l_fab = &fab_in;
13245     rab_in.rab$l_rop = RAB$M_BIO;
13246     rab_in.rab$l_ubf = ubf;
13247     rab_in.rab$w_usz = 32256;
13248     if (!((sts = sys$connect(&rab_in)) & 1)) {
13249       sys$close(&fab_in); sys$close(&fab_out);
13250       PerlMem_free(vmsin);
13251       PerlMem_free(vmsout);
13252       PerlMem_free(ubf);
13253       PerlMem_free(esa);
13254       if (esal != NULL)
13255           PerlMem_free(esal);
13256       PerlMem_free(rsa);
13257       if (rsal != NULL)
13258           PerlMem_free(rsal);
13259       PerlMem_free(esa_out);
13260       if (esal_out != NULL)
13261           PerlMem_free(esal_out);
13262       PerlMem_free(rsa_out);
13263       if (rsal_out != NULL)
13264           PerlMem_free(rsal_out);
13265       set_errno(EVMSERR); set_vaxc_errno(sts);
13266       return 0;
13267     }
13268
13269     rab_out = cc$rms_rab;
13270     rab_out.rab$l_fab = &fab_out;
13271     rab_out.rab$l_rbf = ubf;
13272     if (!((sts = sys$connect(&rab_out)) & 1)) {
13273       sys$close(&fab_in); sys$close(&fab_out);
13274       PerlMem_free(vmsin);
13275       PerlMem_free(vmsout);
13276       PerlMem_free(ubf);
13277       PerlMem_free(esa);
13278       if (esal != NULL)
13279           PerlMem_free(esal);
13280       PerlMem_free(rsa);
13281       if (rsal != NULL)
13282           PerlMem_free(rsal);
13283       PerlMem_free(esa_out);
13284       if (esal_out != NULL)
13285           PerlMem_free(esal_out);
13286       PerlMem_free(rsa_out);
13287       if (rsal_out != NULL)
13288           PerlMem_free(rsal_out);
13289       set_errno(EVMSERR); set_vaxc_errno(sts);
13290       return 0;
13291     }
13292
13293     while ((sts = sys$read(&rab_in))) {  /* always true  */
13294       if (sts == RMS$_EOF) break;
13295       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
13296       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
13297         sys$close(&fab_in); sys$close(&fab_out);
13298         PerlMem_free(vmsin);
13299         PerlMem_free(vmsout);
13300         PerlMem_free(ubf);
13301         PerlMem_free(esa);
13302         if (esal != NULL)
13303             PerlMem_free(esal);
13304         PerlMem_free(rsa);
13305         if (rsal != NULL)
13306             PerlMem_free(rsal);
13307         PerlMem_free(esa_out);
13308         if (esal_out != NULL)
13309             PerlMem_free(esal_out);
13310         PerlMem_free(rsa_out);
13311         if (rsal_out != NULL)
13312             PerlMem_free(rsal_out);
13313         set_errno(EVMSERR); set_vaxc_errno(sts);
13314         return 0;
13315       }
13316     }
13317
13318
13319     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
13320     sys$close(&fab_in);  sys$close(&fab_out);
13321     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
13322
13323     PerlMem_free(vmsin);
13324     PerlMem_free(vmsout);
13325     PerlMem_free(ubf);
13326     PerlMem_free(esa);
13327     if (esal != NULL)
13328         PerlMem_free(esal);
13329     PerlMem_free(rsa);
13330     if (rsal != NULL)
13331         PerlMem_free(rsal);
13332     PerlMem_free(esa_out);
13333     if (esal_out != NULL)
13334         PerlMem_free(esal_out);
13335     PerlMem_free(rsa_out);
13336     if (rsal_out != NULL)
13337         PerlMem_free(rsal_out);
13338
13339     if (!(sts & 1)) {
13340       set_errno(EVMSERR); set_vaxc_errno(sts);
13341       return 0;
13342     }
13343
13344     return 1;
13345
13346 }  /* end of rmscopy() */
13347 /*}}}*/
13348
13349
13350 /***  The following glue provides 'hooks' to make some of the routines
13351  * from this file available from Perl.  These routines are sufficiently
13352  * basic, and are required sufficiently early in the build process,
13353  * that's it's nice to have them available to miniperl as well as the
13354  * full Perl, so they're set up here instead of in an extension.  The
13355  * Perl code which handles importation of these names into a given
13356  * package lives in [.VMS]Filespec.pm in @INC.
13357  */
13358
13359 void
13360 rmsexpand_fromperl(pTHX_ CV *cv)
13361 {
13362   dXSARGS;
13363   char *fspec, *defspec = NULL, *rslt;
13364   STRLEN n_a;
13365   int fs_utf8, dfs_utf8;
13366
13367   fs_utf8 = 0;
13368   dfs_utf8 = 0;
13369   if (!items || items > 2)
13370     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
13371   fspec = SvPV(ST(0),n_a);
13372   fs_utf8 = SvUTF8(ST(0));
13373   if (!fspec || !*fspec) XSRETURN_UNDEF;
13374   if (items == 2) {
13375     defspec = SvPV(ST(1),n_a);
13376     dfs_utf8 = SvUTF8(ST(1));
13377   }
13378   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
13379   ST(0) = sv_newmortal();
13380   if (rslt != NULL) {
13381     sv_usepvn(ST(0),rslt,strlen(rslt));
13382     if (fs_utf8) {
13383         SvUTF8_on(ST(0));
13384     }
13385   }
13386   XSRETURN(1);
13387 }
13388
13389 void
13390 vmsify_fromperl(pTHX_ CV *cv)
13391 {
13392   dXSARGS;
13393   char *vmsified;
13394   STRLEN n_a;
13395   int utf8_fl;
13396
13397   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
13398   utf8_fl = SvUTF8(ST(0));
13399   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13400   ST(0) = sv_newmortal();
13401   if (vmsified != NULL) {
13402     sv_usepvn(ST(0),vmsified,strlen(vmsified));
13403     if (utf8_fl) {
13404         SvUTF8_on(ST(0));
13405     }
13406   }
13407   XSRETURN(1);
13408 }
13409
13410 void
13411 unixify_fromperl(pTHX_ CV *cv)
13412 {
13413   dXSARGS;
13414   char *unixified;
13415   STRLEN n_a;
13416   int utf8_fl;
13417
13418   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
13419   utf8_fl = SvUTF8(ST(0));
13420   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13421   ST(0) = sv_newmortal();
13422   if (unixified != NULL) {
13423     sv_usepvn(ST(0),unixified,strlen(unixified));
13424     if (utf8_fl) {
13425         SvUTF8_on(ST(0));
13426     }
13427   }
13428   XSRETURN(1);
13429 }
13430
13431 void
13432 fileify_fromperl(pTHX_ CV *cv)
13433 {
13434   dXSARGS;
13435   char *fileified;
13436   STRLEN n_a;
13437   int utf8_fl;
13438
13439   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
13440   utf8_fl = SvUTF8(ST(0));
13441   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13442   ST(0) = sv_newmortal();
13443   if (fileified != NULL) {
13444     sv_usepvn(ST(0),fileified,strlen(fileified));
13445     if (utf8_fl) {
13446         SvUTF8_on(ST(0));
13447     }
13448   }
13449   XSRETURN(1);
13450 }
13451
13452 void
13453 pathify_fromperl(pTHX_ CV *cv)
13454 {
13455   dXSARGS;
13456   char *pathified;
13457   STRLEN n_a;
13458   int utf8_fl;
13459
13460   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
13461   utf8_fl = SvUTF8(ST(0));
13462   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13463   ST(0) = sv_newmortal();
13464   if (pathified != NULL) {
13465     sv_usepvn(ST(0),pathified,strlen(pathified));
13466     if (utf8_fl) {
13467         SvUTF8_on(ST(0));
13468     }
13469   }
13470   XSRETURN(1);
13471 }
13472
13473 void
13474 vmspath_fromperl(pTHX_ CV *cv)
13475 {
13476   dXSARGS;
13477   char *vmspath;
13478   STRLEN n_a;
13479   int utf8_fl;
13480
13481   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
13482   utf8_fl = SvUTF8(ST(0));
13483   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13484   ST(0) = sv_newmortal();
13485   if (vmspath != NULL) {
13486     sv_usepvn(ST(0),vmspath,strlen(vmspath));
13487     if (utf8_fl) {
13488         SvUTF8_on(ST(0));
13489     }
13490   }
13491   XSRETURN(1);
13492 }
13493
13494 void
13495 unixpath_fromperl(pTHX_ CV *cv)
13496 {
13497   dXSARGS;
13498   char *unixpath;
13499   STRLEN n_a;
13500   int utf8_fl;
13501
13502   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
13503   utf8_fl = SvUTF8(ST(0));
13504   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13505   ST(0) = sv_newmortal();
13506   if (unixpath != NULL) {
13507     sv_usepvn(ST(0),unixpath,strlen(unixpath));
13508     if (utf8_fl) {
13509         SvUTF8_on(ST(0));
13510     }
13511   }
13512   XSRETURN(1);
13513 }
13514
13515 void
13516 candelete_fromperl(pTHX_ CV *cv)
13517 {
13518   dXSARGS;
13519   char *fspec, *fsp;
13520   SV *mysv;
13521   IO *io;
13522   STRLEN n_a;
13523
13524   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
13525
13526   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13527   Newx(fspec, VMS_MAXRSS, char);
13528   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
13529   if (SvTYPE(mysv) == SVt_PVGV) {
13530     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
13531       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13532       ST(0) = &PL_sv_no;
13533       Safefree(fspec);
13534       XSRETURN(1);
13535     }
13536     fsp = fspec;
13537   }
13538   else {
13539     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
13540       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13541       ST(0) = &PL_sv_no;
13542       Safefree(fspec);
13543       XSRETURN(1);
13544     }
13545   }
13546
13547   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
13548   Safefree(fspec);
13549   XSRETURN(1);
13550 }
13551
13552 void
13553 rmscopy_fromperl(pTHX_ CV *cv)
13554 {
13555   dXSARGS;
13556   char *inspec, *outspec, *inp, *outp;
13557   int date_flag;
13558   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
13559                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13560   unsigned long int sts;
13561   SV *mysv;
13562   IO *io;
13563   STRLEN n_a;
13564
13565   if (items < 2 || items > 3)
13566     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
13567
13568   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13569   Newx(inspec, VMS_MAXRSS, char);
13570   if (SvTYPE(mysv) == SVt_PVGV) {
13571     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
13572       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13573       ST(0) = &PL_sv_no;
13574       Safefree(inspec);
13575       XSRETURN(1);
13576     }
13577     inp = inspec;
13578   }
13579   else {
13580     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
13581       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13582       ST(0) = &PL_sv_no;
13583       Safefree(inspec);
13584       XSRETURN(1);
13585     }
13586   }
13587   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
13588   Newx(outspec, VMS_MAXRSS, char);
13589   if (SvTYPE(mysv) == SVt_PVGV) {
13590     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
13591       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13592       ST(0) = &PL_sv_no;
13593       Safefree(inspec);
13594       Safefree(outspec);
13595       XSRETURN(1);
13596     }
13597     outp = outspec;
13598   }
13599   else {
13600     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
13601       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13602       ST(0) = &PL_sv_no;
13603       Safefree(inspec);
13604       Safefree(outspec);
13605       XSRETURN(1);
13606     }
13607   }
13608   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
13609
13610   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
13611   Safefree(inspec);
13612   Safefree(outspec);
13613   XSRETURN(1);
13614 }
13615
13616 /* The mod2fname is limited to shorter filenames by design, so it should
13617  * not be modified to support longer EFS pathnames
13618  */
13619 void
13620 mod2fname(pTHX_ CV *cv)
13621 {
13622   dXSARGS;
13623   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
13624        workbuff[NAM$C_MAXRSS*1 + 1];
13625   int total_namelen = 3, counter, num_entries;
13626   /* ODS-5 ups this, but we want to be consistent, so... */
13627   int max_name_len = 39;
13628   AV *in_array = (AV *)SvRV(ST(0));
13629
13630   num_entries = av_len(in_array);
13631
13632   /* All the names start with PL_. */
13633   strcpy(ultimate_name, "PL_");
13634
13635   /* Clean up our working buffer */
13636   Zero(work_name, sizeof(work_name), char);
13637
13638   /* Run through the entries and build up a working name */
13639   for(counter = 0; counter <= num_entries; counter++) {
13640     /* If it's not the first name then tack on a __ */
13641     if (counter) {
13642       strcat(work_name, "__");
13643     }
13644     strcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)));
13645   }
13646
13647   /* Check to see if we actually have to bother...*/
13648   if (strlen(work_name) + 3 <= max_name_len) {
13649     strcat(ultimate_name, work_name);
13650   } else {
13651     /* It's too darned big, so we need to go strip. We use the same */
13652     /* algorithm as xsubpp does. First, strip out doubled __ */
13653     char *source, *dest, last;
13654     dest = workbuff;
13655     last = 0;
13656     for (source = work_name; *source; source++) {
13657       if (last == *source && last == '_') {
13658         continue;
13659       }
13660       *dest++ = *source;
13661       last = *source;
13662     }
13663     /* Go put it back */
13664     strcpy(work_name, workbuff);
13665     /* Is it still too big? */
13666     if (strlen(work_name) + 3 > max_name_len) {
13667       /* Strip duplicate letters */
13668       last = 0;
13669       dest = workbuff;
13670       for (source = work_name; *source; source++) {
13671         if (last == toupper(*source)) {
13672         continue;
13673         }
13674         *dest++ = *source;
13675         last = toupper(*source);
13676       }
13677       strcpy(work_name, workbuff);
13678     }
13679
13680     /* Is it *still* too big? */
13681     if (strlen(work_name) + 3 > max_name_len) {
13682       /* Too bad, we truncate */
13683       work_name[max_name_len - 2] = 0;
13684     }
13685     strcat(ultimate_name, work_name);
13686   }
13687
13688   /* Okay, return it */
13689   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
13690   XSRETURN(1);
13691 }
13692
13693 void
13694 hushexit_fromperl(pTHX_ CV *cv)
13695 {
13696     dXSARGS;
13697
13698     if (items > 0) {
13699         VMSISH_HUSHED = SvTRUE(ST(0));
13700     }
13701     ST(0) = boolSV(VMSISH_HUSHED);
13702     XSRETURN(1);
13703 }
13704
13705
13706 PerlIO *
13707 Perl_vms_start_glob
13708    (pTHX_ SV *tmpglob,
13709     IO *io)
13710 {
13711     PerlIO *fp;
13712     struct vs_str_st *rslt;
13713     char *vmsspec;
13714     char *rstr;
13715     char *begin, *cp;
13716     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13717     PerlIO *tmpfp;
13718     STRLEN i;
13719     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13720     struct dsc$descriptor_vs rsdsc;
13721     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13722     unsigned long hasver = 0, isunix = 0;
13723     unsigned long int lff_flags = 0;
13724     int rms_sts;
13725     int vms_old_glob = 1;
13726
13727     if (!SvOK(tmpglob)) {
13728         SETERRNO(ENOENT,RMS$_FNF);
13729         return NULL;
13730     }
13731
13732     vms_old_glob = !decc_filename_unix_report;
13733
13734 #ifdef VMS_LONGNAME_SUPPORT
13735     lff_flags = LIB$M_FIL_LONG_NAMES;
13736 #endif
13737     /* The Newx macro will not allow me to assign a smaller array
13738      * to the rslt pointer, so we will assign it to the begin char pointer
13739      * and then copy the value into the rslt pointer.
13740      */
13741     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13742     rslt = (struct vs_str_st *)begin;
13743     rslt->length = 0;
13744     rstr = &rslt->str[0];
13745     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13746     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13747     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13748     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13749
13750     Newx(vmsspec, VMS_MAXRSS, char);
13751
13752         /* We could find out if there's an explicit dev/dir or version
13753            by peeking into lib$find_file's internal context at
13754            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13755            but that's unsupported, so I don't want to do it now and
13756            have it bite someone in the future. */
13757         /* Fix-me: vms_split_path() is the only way to do this, the
13758            existing method will fail with many legal EFS or UNIX specifications
13759          */
13760
13761     cp = SvPV(tmpglob,i);
13762
13763     for (; i; i--) {
13764         if (cp[i] == ';') hasver = 1;
13765         if (cp[i] == '.') {
13766             if (sts) hasver = 1;
13767             else sts = 1;
13768         }
13769         if (cp[i] == '/') {
13770             hasdir = isunix = 1;
13771             break;
13772         }
13773         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13774             hasdir = 1;
13775             break;
13776         }
13777     }
13778
13779     /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13780     if ((hasdir == 0) && decc_filename_unix_report) {
13781         isunix = 1;
13782     }
13783
13784     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13785         char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13786         int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13787         int wildstar = 0;
13788         int wildquery = 0;
13789         int found = 0;
13790         Stat_t st;
13791         int stat_sts;
13792         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13793         if (!stat_sts && S_ISDIR(st.st_mode)) {
13794             char * vms_dir;
13795             const char * fname;
13796             STRLEN fname_len;
13797
13798             /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13799             /* path delimiter of ':>]', if so, then the old behavior has */
13800             /* obviously been specificially requested */
13801
13802             fname = SvPVX_const(tmpglob);
13803             fname_len = strlen(fname);
13804             vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13805             if (vms_old_glob || (vms_dir != NULL)) {
13806                 wilddsc.dsc$a_pointer = tovmspath_utf8(
13807                                             SvPVX(tmpglob),vmsspec,NULL);
13808                 ok = (wilddsc.dsc$a_pointer != NULL);
13809                 /* maybe passed 'foo' rather than '[.foo]', thus not
13810                    detected above */
13811                 hasdir = 1;
13812             } else {
13813                 /* Operate just on the directory, the special stat/fstat for */
13814                 /* leaves the fileified  specification in the st_devnam */
13815                 /* member. */
13816                 wilddsc.dsc$a_pointer = st.st_devnam;
13817                 ok = 1;
13818             }
13819         }
13820         else {
13821             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13822             ok = (wilddsc.dsc$a_pointer != NULL);
13823         }
13824         if (ok)
13825             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13826
13827         /* If not extended character set, replace ? with % */
13828         /* With extended character set, ? is a wildcard single character */
13829         for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13830             if (*cp == '?') {
13831                 wildquery = 1;
13832                 if (!decc_efs_case_preserve)
13833                     *cp = '%';
13834             } else if (*cp == '%') {
13835                 wildquery = 1;
13836             } else if (*cp == '*') {
13837                 wildstar = 1;
13838             }
13839         }
13840
13841         if (ok) {
13842             wv_sts = vms_split_path(
13843                 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13844                 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13845                 &wvs_spec, &wvs_len);
13846         } else {
13847             wn_spec = NULL;
13848             wn_len = 0;
13849             we_spec = NULL;
13850             we_len = 0;
13851         }
13852
13853         sts = SS$_NORMAL;
13854         while (ok && $VMS_STATUS_SUCCESS(sts)) {
13855          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13856          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13857          int valid_find;
13858
13859             valid_find = 0;
13860             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13861                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
13862             if (!$VMS_STATUS_SUCCESS(sts))
13863                 break;
13864
13865             /* with varying string, 1st word of buffer contains result length */
13866             rstr[rslt->length] = '\0';
13867
13868              /* Find where all the components are */
13869              v_sts = vms_split_path
13870                        (rstr,
13871                         &v_spec,
13872                         &v_len,
13873                         &r_spec,
13874                         &r_len,
13875                         &d_spec,
13876                         &d_len,
13877                         &n_spec,
13878                         &n_len,
13879                         &e_spec,
13880                         &e_len,
13881                         &vs_spec,
13882                         &vs_len);
13883
13884             /* If no version on input, truncate the version on output */
13885             if (!hasver && (vs_len > 0)) {
13886                 *vs_spec = '\0';
13887                 vs_len = 0;
13888             }
13889
13890             if (isunix) {
13891
13892                 /* In Unix report mode, remove the ".dir;1" from the name */
13893                 /* if it is a real directory */
13894                 if (decc_filename_unix_report || decc_efs_charset) {
13895                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13896                         Stat_t statbuf;
13897                         int ret_sts;
13898
13899                         ret_sts = flex_lstat(rstr, &statbuf);
13900                         if ((ret_sts == 0) &&
13901                             S_ISDIR(statbuf.st_mode)) {
13902                             e_len = 0;
13903                             e_spec[0] = 0;
13904                         }
13905                     }
13906                 }
13907
13908                 /* No version & a null extension on UNIX handling */
13909                 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13910                     e_len = 0;
13911                     *e_spec = '\0';
13912                 }
13913             }
13914
13915             if (!decc_efs_case_preserve) {
13916                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13917             }
13918
13919             /* Find File treats a Null extension as return all extensions */
13920             /* This is contrary to Perl expectations */
13921
13922             if (wildstar || wildquery || vms_old_glob) {
13923                 /* really need to see if the returned file name matched */
13924                 /* but for now will assume that it matches */
13925                 valid_find = 1;
13926             } else {
13927                 /* Exact Match requested */
13928                 /* How are directories handled? - like a file */
13929                 if ((e_len == we_len) && (n_len == wn_len)) {
13930                     int t1;
13931                     t1 = e_len;
13932                     if (t1 > 0)
13933                         t1 = strncmp(e_spec, we_spec, e_len);
13934                     if (t1 == 0) {
13935                        t1 = n_len;
13936                        if (t1 > 0)
13937                            t1 = strncmp(n_spec, we_spec, n_len);
13938                        if (t1 == 0)
13939                            valid_find = 1;
13940                     }
13941                 }
13942             }
13943
13944             if (valid_find) {
13945                 found++;
13946
13947                 if (hasdir) {
13948                     if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13949                     begin = rstr;
13950                 }
13951                 else {
13952                     /* Start with the name */
13953                     begin = n_spec;
13954                 }
13955                 strcat(begin,"\n");
13956                 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13957             }
13958         }
13959         if (cxt) (void)lib$find_file_end(&cxt);
13960
13961         if (!found) {
13962             /* Be POSIXish: return the input pattern when no matches */
13963             strcpy(rstr,SvPVX(tmpglob));
13964             strcat(rstr,"\n");
13965             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13966         }
13967
13968         if (ok && sts != RMS$_NMF &&
13969             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13970         if (!ok) {
13971             if (!(sts & 1)) {
13972                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13973             }
13974             PerlIO_close(tmpfp);
13975             fp = NULL;
13976         }
13977         else {
13978             PerlIO_rewind(tmpfp);
13979             IoTYPE(io) = IoTYPE_RDONLY;
13980             IoIFP(io) = fp = tmpfp;
13981             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
13982         }
13983     }
13984     Safefree(vmsspec);
13985     Safefree(rslt);
13986     return fp;
13987 }
13988
13989
13990 static char *
13991 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13992                    int *utf8_fl);
13993
13994 void
13995 unixrealpath_fromperl(pTHX_ CV *cv)
13996 {
13997     dXSARGS;
13998     char *fspec, *rslt_spec, *rslt;
13999     STRLEN n_a;
14000
14001     if (!items || items != 1)
14002         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
14003
14004     fspec = SvPV(ST(0),n_a);
14005     if (!fspec || !*fspec) XSRETURN_UNDEF;
14006
14007     Newx(rslt_spec, VMS_MAXRSS + 1, char);
14008     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
14009
14010     ST(0) = sv_newmortal();
14011     if (rslt != NULL)
14012         sv_usepvn(ST(0),rslt,strlen(rslt));
14013     else
14014         Safefree(rslt_spec);
14015         XSRETURN(1);
14016 }
14017
14018 static char *
14019 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
14020                    int *utf8_fl);
14021
14022 void
14023 vmsrealpath_fromperl(pTHX_ CV *cv)
14024 {
14025     dXSARGS;
14026     char *fspec, *rslt_spec, *rslt;
14027     STRLEN n_a;
14028
14029     if (!items || items != 1)
14030         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
14031
14032     fspec = SvPV(ST(0),n_a);
14033     if (!fspec || !*fspec) XSRETURN_UNDEF;
14034
14035     Newx(rslt_spec, VMS_MAXRSS + 1, char);
14036     rslt = do_vms_realname(fspec, rslt_spec, NULL);
14037
14038     ST(0) = sv_newmortal();
14039     if (rslt != NULL)
14040         sv_usepvn(ST(0),rslt,strlen(rslt));
14041     else
14042         Safefree(rslt_spec);
14043         XSRETURN(1);
14044 }
14045
14046 #ifdef HAS_SYMLINK
14047 /*
14048  * A thin wrapper around decc$symlink to make sure we follow the
14049  * standard and do not create a symlink with a zero-length name.
14050  *
14051  * Also in ODS-2 mode, existing tests assume that the link target
14052  * will be converted to UNIX format.
14053  */
14054 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
14055 int Perl_my_symlink(pTHX_ const char *contents, const char *link_name) {
14056   if (!link_name || !*link_name) {
14057     SETERRNO(ENOENT, SS$_NOSUCHFILE);
14058     return -1;
14059   }
14060
14061   if (decc_efs_charset) {
14062       return symlink(contents, link_name);
14063   } else {
14064       int sts;
14065       char * utarget;
14066
14067       /* Unless we are in ODS-5 mode, convert the symlink target to UNIX */
14068       /* because in order to work, the symlink target must be in UNIX format */
14069
14070       /* As symbolic links can hold things other than files, we will only do */
14071       /* the conversion in in ODS-2 mode */
14072
14073       utarget = PerlMem_malloc(VMS_MAXRSS + 1);
14074       if (int_tounixspec(contents, utarget, NULL) == NULL) {
14075
14076           /* This should not fail, as an untranslatable filename */
14077           /* should be passed through */
14078           utarget = (char *)contents;
14079       }
14080       sts = symlink(utarget, link_name);
14081       PerlMem_free(utarget);
14082       return sts;
14083   }
14084
14085 }
14086 /*}}}*/
14087
14088 #endif /* HAS_SYMLINK */
14089
14090 int do_vms_case_tolerant(void);
14091
14092 void
14093 case_tolerant_process_fromperl(pTHX_ CV *cv)
14094 {
14095   dXSARGS;
14096   ST(0) = boolSV(do_vms_case_tolerant());
14097   XSRETURN(1);
14098 }
14099
14100 #ifdef USE_ITHREADS
14101
14102 void
14103 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
14104                           struct interp_intern *dst)
14105 {
14106     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
14107
14108     memcpy(dst,src,sizeof(struct interp_intern));
14109 }
14110
14111 #endif
14112
14113 void
14114 Perl_sys_intern_clear(pTHX)
14115 {
14116 }
14117
14118 void
14119 Perl_sys_intern_init(pTHX)
14120 {
14121     unsigned int ix = RAND_MAX;
14122     double x;
14123
14124     VMSISH_HUSHED = 0;
14125
14126     MY_POSIX_EXIT = vms_posix_exit;
14127
14128     x = (float)ix;
14129     MY_INV_RAND_MAX = 1./x;
14130 }
14131
14132 void
14133 init_os_extras(void)
14134 {
14135   dTHX;
14136   char* file = __FILE__;
14137   if (decc_disable_to_vms_logname_translation) {
14138     no_translate_barewords = TRUE;
14139   } else {
14140     no_translate_barewords = FALSE;
14141   }
14142
14143   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
14144   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
14145   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
14146   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
14147   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
14148   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
14149   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
14150   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
14151   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
14152   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
14153   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
14154   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
14155   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
14156   newXSproto("VMS::Filespec::case_tolerant_process",
14157       case_tolerant_process_fromperl,file,"");
14158
14159   store_pipelocs(aTHX);         /* will redo any earlier attempts */
14160
14161   return;
14162 }
14163
14164 #if __CRTL_VER == 80200000
14165 /* This missed getting in to the DECC SDK for 8.2 */
14166 char *realpath(const char *file_name, char * resolved_name, ...);
14167 #endif
14168
14169 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
14170 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
14171  * The perl fallback routine to provide realpath() is not as efficient
14172  * on OpenVMS.
14173  */
14174
14175 /* Hack, use old stat() as fastest way of getting ino_t and device */
14176 int decc$stat(const char *name, void * statbuf);
14177 #if !defined(__VAX) && __CRTL_VER >= 80200000
14178 int decc$lstat(const char *name, void * statbuf);
14179 #else
14180 #define decc$lstat decc$stat
14181 #endif
14182
14183
14184 /* Realpath is fragile.  In 8.3 it does not work if the feature
14185  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
14186  * links are implemented in RMS, not the CRTL. It also can fail if the
14187  * user does not have read/execute access to some of the directories.
14188  * So in order for Do What I Mean mode to work, if realpath() fails,
14189  * fall back to looking up the filename by the device name and FID.
14190  */
14191
14192 int vms_fid_to_name(char * outname, int outlen,
14193                     const char * name, int lstat_flag, mode_t * mode)
14194 {
14195 #pragma message save
14196 #pragma message disable MISALGNDSTRCT
14197 #pragma message disable MISALGNDMEM
14198 #pragma member_alignment save
14199 #pragma nomember_alignment
14200 struct statbuf_t {
14201     char           * st_dev;
14202     unsigned short st_ino[3];
14203     unsigned short old_st_mode;
14204     unsigned long  padl[30];  /* plenty of room */
14205 } statbuf;
14206 #pragma message restore
14207 #pragma member_alignment restore
14208
14209     int sts;
14210     struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
14211     struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
14212     char *fileified;
14213     char *temp_fspec;
14214     char *ret_spec;
14215
14216     /* Need to follow the mostly the same rules as flex_stat_int, or we may get
14217      * unexpected answers
14218      */
14219
14220     fileified = PerlMem_malloc(VMS_MAXRSS);
14221     if (fileified == NULL)
14222         _ckvmssts_noperl(SS$_INSFMEM);
14223
14224     temp_fspec = PerlMem_malloc(VMS_MAXRSS);
14225     if (temp_fspec == NULL)
14226         _ckvmssts_noperl(SS$_INSFMEM);
14227
14228     sts = -1;
14229     /* First need to try as a directory */
14230     ret_spec = int_tovmspath(name, temp_fspec, NULL);
14231     if (ret_spec != NULL) {
14232         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
14233         if (ret_spec != NULL) {
14234             if (lstat_flag == 0)
14235                 sts = decc$stat(fileified, &statbuf);
14236             else
14237                 sts = decc$lstat(fileified, &statbuf);
14238         }
14239     }
14240
14241     /* Then as a VMS file spec */
14242     if (sts != 0) {
14243         ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
14244         if (ret_spec != NULL) {
14245             if (lstat_flag == 0) {
14246                 sts = decc$stat(temp_fspec, &statbuf);
14247             } else {
14248                 sts = decc$lstat(temp_fspec, &statbuf);
14249             }
14250         }
14251     }
14252
14253     if (sts) {
14254         /* Next try - allow multiple dots with out EFS CHARSET */
14255         /* The CRTL stat() falls down hard on multi-dot filenames in unix
14256          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
14257          * enable it if it isn't already.
14258          */
14259 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14260         if (!decc_efs_charset && (decc_efs_charset_index > 0))
14261             decc$feature_set_value(decc_efs_charset_index, 1, 1);
14262 #endif
14263         ret_spec = int_tovmspath(name, temp_fspec, NULL);
14264         if (lstat_flag == 0) {
14265             sts = decc$stat(name, &statbuf);
14266         } else {
14267             sts = decc$lstat(name, &statbuf);
14268         }
14269 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14270         if (!decc_efs_charset && (decc_efs_charset_index > 0))
14271             decc$feature_set_value(decc_efs_charset_index, 1, 0);
14272 #endif
14273     }
14274
14275
14276     /* and then because the Perl Unix to VMS conversion is not perfect */
14277     /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
14278     /* characters from filenames so we need to try it as-is */
14279     if (sts) {
14280         if (lstat_flag == 0) {
14281             sts = decc$stat(name, &statbuf);
14282         } else {
14283             sts = decc$lstat(name, &statbuf);
14284         }
14285     }
14286
14287     if (sts == 0) {
14288         int vms_sts;
14289
14290         dvidsc.dsc$a_pointer=statbuf.st_dev;
14291         dvidsc.dsc$w_length=strlen(statbuf.st_dev);
14292
14293         specdsc.dsc$a_pointer = outname;
14294         specdsc.dsc$w_length = outlen-1;
14295
14296         vms_sts = lib$fid_to_name
14297             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
14298         if ($VMS_STATUS_SUCCESS(vms_sts)) {
14299             outname[specdsc.dsc$w_length] = 0;
14300
14301             /* Return the mode */
14302             if (mode) {
14303                 *mode = statbuf.old_st_mode;
14304             }
14305             return 0;
14306         }
14307     }
14308     return sts;
14309 }
14310
14311
14312
14313 static char *
14314 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
14315                    int *utf8_fl)
14316 {
14317     char * rslt = NULL;
14318
14319 #ifdef HAS_SYMLINK
14320     if (decc_posix_compliant_pathnames > 0 ) {
14321         /* realpath currently only works if posix compliant pathnames are
14322          * enabled.  It may start working when they are not, but in that
14323          * case we still want the fallback behavior for backwards compatibility
14324          */
14325         rslt = realpath(filespec, outbuf);
14326     }
14327 #endif
14328
14329     if (rslt == NULL) {
14330         char * vms_spec;
14331         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
14332         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
14333         int file_len;
14334         mode_t my_mode;
14335
14336         /* Fall back to fid_to_name */
14337
14338         Newx(vms_spec, VMS_MAXRSS + 1, char);
14339
14340         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
14341         if (sts == 0) {
14342
14343
14344             /* Now need to trim the version off */
14345             sts = vms_split_path
14346                   (vms_spec,
14347                    &v_spec,
14348                    &v_len,
14349                    &r_spec,
14350                    &r_len,
14351                    &d_spec,
14352                    &d_len,
14353                    &n_spec,
14354                    &n_len,
14355                    &e_spec,
14356                    &e_len,
14357                    &vs_spec,
14358                    &vs_len);
14359
14360
14361                 if (sts == 0) {
14362                     int haslower = 0;
14363                     const char *cp;
14364
14365                     /* Trim off the version */
14366                     int file_len = v_len + r_len + d_len + n_len + e_len;
14367                     vms_spec[file_len] = 0;
14368
14369                     /* Trim off the .DIR if this is a directory */
14370                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
14371                         if (S_ISDIR(my_mode)) {
14372                             e_len = 0;
14373                             e_spec[0] = 0;
14374                         }
14375                     }
14376
14377                     /* Drop NULL extensions on UNIX file specification */
14378                     if ((e_len == 1) && decc_readdir_dropdotnotype) {
14379                         e_len = 0;
14380                         e_spec[0] = '\0';
14381                     }
14382
14383                     /* The result is expected to be in UNIX format */
14384                     rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
14385
14386                     /* Downcase if input had any lower case letters and
14387                      * case preservation is not in effect.
14388                      */
14389                     if (!decc_efs_case_preserve) {
14390                         for (cp = filespec; *cp; cp++)
14391                             if (islower(*cp)) { haslower = 1; break; }
14392
14393                         if (haslower) __mystrtolower(rslt);
14394                     }
14395                 }
14396         } else {
14397
14398             /* Now for some hacks to deal with backwards and forward */
14399             /* compatibilty */
14400             if (!decc_efs_charset) {
14401
14402                 /* 1. ODS-2 mode wants to do a syntax only translation */
14403                 rslt = int_rmsexpand(filespec, outbuf,
14404                                     NULL, 0, NULL, utf8_fl);
14405
14406             } else {
14407                 if (decc_filename_unix_report) {
14408                     char * dir_name;
14409                     char * vms_dir_name;
14410                     char * file_name;
14411
14412                     /* 2. ODS-5 / UNIX report mode should return a failure */
14413                     /*    if the parent directory also does not exist */
14414                     /*    Otherwise, get the real path for the parent */
14415                     /*    and add the child to it.
14416
14417                     /* basename / dirname only available for VMS 7.0+ */
14418                     /* So we may need to implement them as common routines */
14419
14420                     Newx(dir_name, VMS_MAXRSS + 1, char);
14421                     Newx(vms_dir_name, VMS_MAXRSS + 1, char);
14422                     dir_name[0] = '\0';
14423                     file_name = NULL;
14424
14425                     /* First try a VMS parse */
14426                     sts = vms_split_path
14427                           (filespec,
14428                            &v_spec,
14429                            &v_len,
14430                            &r_spec,
14431                            &r_len,
14432                            &d_spec,
14433                            &d_len,
14434                            &n_spec,
14435                            &n_len,
14436                            &e_spec,
14437                            &e_len,
14438                            &vs_spec,
14439                            &vs_len);
14440
14441                     if (sts == 0) {
14442                         /* This is VMS */
14443
14444                         int dir_len = v_len + r_len + d_len + n_len;
14445                         if (dir_len > 0) {
14446                            strncpy(dir_name, filespec, dir_len);
14447                            dir_name[dir_len] = '\0';
14448                            file_name = (char *)&filespec[dir_len + 1];
14449                         }
14450                     } else {
14451                         /* This must be UNIX */
14452                         char * tchar;
14453
14454                         tchar = strrchr(filespec, '/');
14455
14456                         if (tchar != NULL) {
14457                             int dir_len = tchar - filespec;
14458                             strncpy(dir_name, filespec, dir_len);
14459                             dir_name[dir_len] = '\0';
14460                             file_name = (char *) &filespec[dir_len + 1];
14461                         }
14462                     }
14463
14464                     /* Dir name is defaulted */
14465                     if (dir_name[0] == 0) {
14466                         dir_name[0] = '.';
14467                         dir_name[1] = '\0';
14468                     }
14469
14470                     /* Need realpath for the directory */
14471                     sts = vms_fid_to_name(vms_dir_name,
14472                                           VMS_MAXRSS + 1,
14473                                           dir_name, 0, NULL);
14474
14475                     if (sts == 0) {
14476                         /* Now need to pathify it.
14477                         char *tdir = int_pathify_dirspec(vms_dir_name,
14478                                                          outbuf);
14479
14480                         /* And now add the original filespec to it */
14481                         if (file_name != NULL) {
14482                             strcat(outbuf, file_name);
14483                         }
14484                         return outbuf;
14485                     }
14486                     Safefree(vms_dir_name);
14487                     Safefree(dir_name);
14488                 }
14489             }
14490         }
14491         Safefree(vms_spec);
14492     }
14493     return rslt;
14494 }
14495
14496 static char *
14497 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
14498                    int *utf8_fl)
14499 {
14500     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
14501     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
14502     int file_len;
14503
14504     /* Fall back to fid_to_name */
14505
14506     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
14507     if (sts != 0) {
14508         return NULL;
14509     }
14510     else {
14511
14512
14513         /* Now need to trim the version off */
14514         sts = vms_split_path
14515                   (outbuf,
14516                    &v_spec,
14517                    &v_len,
14518                    &r_spec,
14519                    &r_len,
14520                    &d_spec,
14521                    &d_len,
14522                    &n_spec,
14523                    &n_len,
14524                    &e_spec,
14525                    &e_len,
14526                    &vs_spec,
14527                    &vs_len);
14528
14529
14530         if (sts == 0) {
14531             int haslower = 0;
14532             const char *cp;
14533
14534             /* Trim off the version */
14535             int file_len = v_len + r_len + d_len + n_len + e_len;
14536             outbuf[file_len] = 0;
14537
14538             /* Downcase if input had any lower case letters and
14539              * case preservation is not in effect.
14540              */
14541             if (!decc_efs_case_preserve) {
14542                 for (cp = filespec; *cp; cp++)
14543                     if (islower(*cp)) { haslower = 1; break; }
14544
14545                 if (haslower) __mystrtolower(outbuf);
14546             }
14547         }
14548     }
14549     return outbuf;
14550 }
14551
14552
14553 /*}}}*/
14554 /* External entry points */
14555 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
14556 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
14557
14558 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
14559 { return do_vms_realname(filespec, outbuf, utf8_fl); }
14560
14561 /* case_tolerant */
14562
14563 /*{{{int do_vms_case_tolerant(void)*/
14564 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
14565  * controlled by a process setting.
14566  */
14567 int do_vms_case_tolerant(void)
14568 {
14569     return vms_process_case_tolerant;
14570 }
14571 /*}}}*/
14572 /* External entry points */
14573 #if __CRTL_VER >= 70301000 && !defined(__VAX)
14574 int Perl_vms_case_tolerant(void)
14575 { return do_vms_case_tolerant(); }
14576 #else
14577 int Perl_vms_case_tolerant(void)
14578 { return vms_process_case_tolerant; }
14579 #endif
14580
14581
14582  /* Start of DECC RTL Feature handling */
14583
14584 static int sys_trnlnm
14585    (const char * logname,
14586     char * value,
14587     int value_len)
14588 {
14589     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
14590     const unsigned long attr = LNM$M_CASE_BLIND;
14591     struct dsc$descriptor_s name_dsc;
14592     int status;
14593     unsigned short result;
14594     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
14595                                 {0, 0, 0, 0}};
14596
14597     name_dsc.dsc$w_length = strlen(logname);
14598     name_dsc.dsc$a_pointer = (char *)logname;
14599     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14600     name_dsc.dsc$b_class = DSC$K_CLASS_S;
14601
14602     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
14603
14604     if ($VMS_STATUS_SUCCESS(status)) {
14605
14606          /* Null terminate and return the string */
14607         /*--------------------------------------*/
14608         value[result] = 0;
14609     }
14610
14611     return status;
14612 }
14613
14614 static int sys_crelnm
14615    (const char * logname,
14616     const char * value)
14617 {
14618     int ret_val;
14619     const char * proc_table = "LNM$PROCESS_TABLE";
14620     struct dsc$descriptor_s proc_table_dsc;
14621     struct dsc$descriptor_s logname_dsc;
14622     struct itmlst_3 item_list[2];
14623
14624     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
14625     proc_table_dsc.dsc$w_length = strlen(proc_table);
14626     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14627     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
14628
14629     logname_dsc.dsc$a_pointer = (char *) logname;
14630     logname_dsc.dsc$w_length = strlen(logname);
14631     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14632     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
14633
14634     item_list[0].buflen = strlen(value);
14635     item_list[0].itmcode = LNM$_STRING;
14636     item_list[0].bufadr = (char *)value;
14637     item_list[0].retlen = NULL;
14638
14639     item_list[1].buflen = 0;
14640     item_list[1].itmcode = 0;
14641
14642     ret_val = sys$crelnm
14643                        (NULL,
14644                         (const struct dsc$descriptor_s *)&proc_table_dsc,
14645                         (const struct dsc$descriptor_s *)&logname_dsc,
14646                         NULL,
14647                         (const struct item_list_3 *) item_list);
14648
14649     return ret_val;
14650 }
14651
14652 /* C RTL Feature settings */
14653
14654 static int set_features
14655    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
14656     int (* cli_routine)(void),  /* Not documented */
14657     void *image_info)           /* Not documented */
14658 {
14659     int status;
14660     int s;
14661     char* str;
14662     char val_str[10];
14663 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
14664     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
14665     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
14666     unsigned long case_perm;
14667     unsigned long case_image;
14668 #endif
14669
14670     /* Allow an exception to bring Perl into the VMS debugger */
14671     vms_debug_on_exception = 0;
14672     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
14673     if ($VMS_STATUS_SUCCESS(status)) {
14674        val_str[0] = _toupper(val_str[0]);
14675        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14676          vms_debug_on_exception = 1;
14677        else
14678          vms_debug_on_exception = 0;
14679     }
14680
14681     /* Debug unix/vms file translation routines */
14682     vms_debug_fileify = 0;
14683     status = sys_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
14684     if ($VMS_STATUS_SUCCESS(status)) {
14685         val_str[0] = _toupper(val_str[0]);
14686         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14687             vms_debug_fileify = 1;
14688         else
14689             vms_debug_fileify = 0;
14690     }
14691
14692
14693     /* Historically PERL has been doing vmsify / stat differently than */
14694     /* the CRTL.  In particular, under some conditions the CRTL will   */
14695     /* remove some illegal characters like spaces from filenames       */
14696     /* resulting in some differences.  The stat()/lstat() wrapper has  */
14697     /* been reporting such file names as invalid and fails to stat them */
14698     /* fixing this bug so that stat()/lstat() accept these like the     */
14699     /* CRTL does will result in several tests failing.                  */
14700     /* This should really be fixed, but for now, set up a feature to    */
14701     /* enable it so that the impact can be studied.                     */
14702     vms_bug_stat_filename = 0;
14703     status = sys_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
14704     if ($VMS_STATUS_SUCCESS(status)) {
14705         val_str[0] = _toupper(val_str[0]);
14706         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14707             vms_bug_stat_filename = 1;
14708         else
14709             vms_bug_stat_filename = 0;
14710     }
14711
14712
14713     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
14714     vms_vtf7_filenames = 0;
14715     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
14716     if ($VMS_STATUS_SUCCESS(status)) {
14717        val_str[0] = _toupper(val_str[0]);
14718        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14719          vms_vtf7_filenames = 1;
14720        else
14721          vms_vtf7_filenames = 0;
14722     }
14723
14724     /* unlink all versions on unlink() or rename() */
14725     vms_unlink_all_versions = 0;
14726     status = sys_trnlnm
14727         ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
14728     if ($VMS_STATUS_SUCCESS(status)) {
14729        val_str[0] = _toupper(val_str[0]);
14730        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14731          vms_unlink_all_versions = 1;
14732        else
14733          vms_unlink_all_versions = 0;
14734     }
14735
14736     /* Dectect running under GNV Bash or other UNIX like shell */
14737 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14738     gnv_unix_shell = 0;
14739     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
14740     if ($VMS_STATUS_SUCCESS(status)) {
14741          gnv_unix_shell = 1;
14742          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
14743          set_feature_default("DECC$EFS_CHARSET", 1);
14744          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
14745          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
14746          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
14747          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
14748          vms_unlink_all_versions = 1;
14749          vms_posix_exit = 1;
14750     }
14751 #endif
14752
14753     /* hacks to see if known bugs are still present for testing */
14754
14755     /* PCP mode requires creating /dev/null special device file */
14756     decc_bug_devnull = 0;
14757     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14758     if ($VMS_STATUS_SUCCESS(status)) {
14759        val_str[0] = _toupper(val_str[0]);
14760        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14761           decc_bug_devnull = 1;
14762        else
14763           decc_bug_devnull = 0;
14764     }
14765
14766     /* UNIX directory names with no paths are broken in a lot of places */
14767     decc_dir_barename = 1;
14768     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
14769     if ($VMS_STATUS_SUCCESS(status)) {
14770       val_str[0] = _toupper(val_str[0]);
14771       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14772         decc_dir_barename = 1;
14773       else
14774         decc_dir_barename = 0;
14775     }
14776
14777 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14778     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14779     if (s >= 0) {
14780         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14781         if (decc_disable_to_vms_logname_translation < 0)
14782             decc_disable_to_vms_logname_translation = 0;
14783     }
14784
14785     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14786     if (s >= 0) {
14787         decc_efs_case_preserve = decc$feature_get_value(s, 1);
14788         if (decc_efs_case_preserve < 0)
14789             decc_efs_case_preserve = 0;
14790     }
14791
14792     s = decc$feature_get_index("DECC$EFS_CHARSET");
14793     decc_efs_charset_index = s;
14794     if (s >= 0) {
14795         decc_efs_charset = decc$feature_get_value(s, 1);
14796         if (decc_efs_charset < 0)
14797             decc_efs_charset = 0;
14798     }
14799
14800     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14801     if (s >= 0) {
14802         decc_filename_unix_report = decc$feature_get_value(s, 1);
14803         if (decc_filename_unix_report > 0) {
14804             decc_filename_unix_report = 1;
14805             vms_posix_exit = 1;
14806         }
14807         else
14808             decc_filename_unix_report = 0;
14809     }
14810
14811     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14812     if (s >= 0) {
14813         decc_filename_unix_only = decc$feature_get_value(s, 1);
14814         if (decc_filename_unix_only > 0) {
14815             decc_filename_unix_only = 1;
14816         }
14817         else {
14818             decc_filename_unix_only = 0;
14819         }
14820     }
14821
14822     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14823     if (s >= 0) {
14824         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14825         if (decc_filename_unix_no_version < 0)
14826             decc_filename_unix_no_version = 0;
14827     }
14828
14829     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14830     if (s >= 0) {
14831         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14832         if (decc_readdir_dropdotnotype < 0)
14833             decc_readdir_dropdotnotype = 0;
14834     }
14835
14836 #if __CRTL_VER >= 80200000
14837     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14838     if (s >= 0) {
14839         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14840         if (decc_posix_compliant_pathnames < 0)
14841             decc_posix_compliant_pathnames = 0;
14842         if (decc_posix_compliant_pathnames > 4)
14843             decc_posix_compliant_pathnames = 0;
14844     }
14845
14846 #endif
14847 #else
14848     status = sys_trnlnm
14849         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
14850     if ($VMS_STATUS_SUCCESS(status)) {
14851         val_str[0] = _toupper(val_str[0]);
14852         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14853            decc_disable_to_vms_logname_translation = 1;
14854         }
14855     }
14856
14857 #ifndef __VAX
14858     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
14859     if ($VMS_STATUS_SUCCESS(status)) {
14860         val_str[0] = _toupper(val_str[0]);
14861         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14862            decc_efs_case_preserve = 1;
14863         }
14864     }
14865 #endif
14866
14867     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14868     if ($VMS_STATUS_SUCCESS(status)) {
14869         val_str[0] = _toupper(val_str[0]);
14870         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14871            decc_filename_unix_report = 1;
14872         }
14873     }
14874     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14875     if ($VMS_STATUS_SUCCESS(status)) {
14876         val_str[0] = _toupper(val_str[0]);
14877         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14878            decc_filename_unix_only = 1;
14879            decc_filename_unix_report = 1;
14880         }
14881     }
14882     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14883     if ($VMS_STATUS_SUCCESS(status)) {
14884         val_str[0] = _toupper(val_str[0]);
14885         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14886            decc_filename_unix_no_version = 1;
14887         }
14888     }
14889     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
14890     if ($VMS_STATUS_SUCCESS(status)) {
14891         val_str[0] = _toupper(val_str[0]);
14892         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14893            decc_readdir_dropdotnotype = 1;
14894         }
14895     }
14896 #endif
14897
14898 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
14899
14900      /* Report true case tolerance */
14901     /*----------------------------*/
14902     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14903     if (!$VMS_STATUS_SUCCESS(status))
14904         case_perm = PPROP$K_CASE_BLIND;
14905     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14906     if (!$VMS_STATUS_SUCCESS(status))
14907         case_image = PPROP$K_CASE_BLIND;
14908     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14909         (case_image == PPROP$K_CASE_SENSITIVE))
14910         vms_process_case_tolerant = 0;
14911
14912 #endif
14913
14914     /* USE POSIX/DCL Exit codes - Recommended, but needs to default to  */
14915     /* for strict backward compatibilty */
14916     status = sys_trnlnm
14917         ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14918     if ($VMS_STATUS_SUCCESS(status)) {
14919        val_str[0] = _toupper(val_str[0]);
14920        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14921          vms_posix_exit = 1;
14922        else
14923          vms_posix_exit = 0;
14924     }
14925
14926
14927     /* CRTL can be initialized past this point, but not before. */
14928 /*    DECC$CRTL_INIT(); */
14929
14930     return SS$_NORMAL;
14931 }
14932
14933 #ifdef __DECC
14934 #pragma nostandard
14935 #pragma extern_model save
14936 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
14937         const __align (LONGWORD) int spare[8] = {0};
14938
14939 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
14940 #if __DECC_VER >= 60560002
14941 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
14942 #else
14943 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
14944 #endif
14945 #endif /* __DECC */
14946
14947 const long vms_cc_features = (const long)set_features;
14948
14949 /*
14950 ** Force a reference to LIB$INITIALIZE to ensure it
14951 ** exists in the image.
14952 */
14953 int lib$initialize(void);
14954 #ifdef __DECC
14955 #pragma extern_model strict_refdef
14956 #endif
14957     int lib_init_ref = (int) lib$initialize;
14958
14959 #ifdef __DECC
14960 #pragma extern_model restore
14961 #pragma standard
14962 #endif
14963
14964 /*  End of vms.c */