vms/vms.c

   1 /*    vms.c
   2  *
   3  *    VMS-specific routines for perl5
   4  *
   5  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
   6  *    2002, 2003, 2004, 2005, 2006, 2007 by Charles Bailey and others.
   7  *
   8  *    You may distribute under the terms of either the GNU General Public
   9  *    License or the Artistic License, as specified in the README file.
  10  *
  11  *    Please see Changes*.* or the Perl Repository Browser for revision history.
  12  */
  13
  14 /*
  15  *   Yet small as was their hunted band
  16  *   still fell and fearless was each hand,
  17  *   and strong deeds they wrought yet oft,
  18  *   and loved the woods, whose ways more soft
  19  *   them seemed than thralls of that black throne
  20  *   to live and languish in halls of stone.
  21  *        "The Lay of Leithian", Canto II, lines 135-40
  22  *
  23  *     [p.162 of _The Lays of Beleriand_]
  24  */
  25
  26 #include <acedef.h>
  27 #include <acldef.h>
  28 #include <armdef.h>
  29 #include <atrdef.h>
  30 #include <chpdef.h>
  31 #include <clidef.h>
  32 #include <climsgdef.h>
  33 #include <dcdef.h>
  34 #include <descrip.h>
  35 #include <devdef.h>
  36 #include <dvidef.h>
  37 #include <fibdef.h>
  38 #include <float.h>
  39 #include <fscndef.h>
  40 #include <iodef.h>
  41 #include <jpidef.h>
  42 #include <kgbdef.h>
  43 #include <libclidef.h>
  44 #include <libdef.h>
  45 #include <lib$routines.h>
  46 #include <lnmdef.h>
  47 #include <msgdef.h>
  48 #include <ossdef.h>
  49 #if __CRTL_VER >= 70301000 && !defined(__VAX)
  50 #include <ppropdef.h>
  51 #endif
  52 #include <prvdef.h>
  53 #include <psldef.h>
  54 #include <rms.h>
  55 #include <shrdef.h>
  56 #include <ssdef.h>
  57 #include <starlet.h>
  58 #include <strdef.h>
  59 #include <str$routines.h>
  60 #include <syidef.h>
  61 #include <uaidef.h>
  62 #include <uicdef.h>
  63 #include <stsdef.h>
  64 #include <rmsdef.h>
  65 #include <smgdef.h>
  66 #if __CRTL_VER >= 70000000 /* FIXME to earliest version */
  67 #include <efndef.h>
  68 #define NO_EFN EFN$C_ENF
  69 #else
  70 #define NO_EFN 0;
  71 #endif
  72
  73 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  74 int   decc$feature_get_index(const char *name);
  75 char* decc$feature_get_name(int index);
  76 int   decc$feature_get_value(int index, int mode);
  77 int   decc$feature_set_value(int index, int mode, int value);
  78 #else
  79 #include <unixlib.h>
  80 #endif
  81
  82 #pragma member_alignment save
  83 #pragma nomember_alignment longword
  84 struct item_list_3 {
  85         unsigned short len;
  86         unsigned short code;
  87         void * bufadr;
  88         unsigned short * retadr;
  89 };
  90 #pragma member_alignment restore
  91
  92 /* More specific prototype than in starlet_c.h makes programming errors
  93    more visible.
  94  */
  95 #ifdef sys$getdviw
  96 #undef sys$getdviw
  97 int sys$getdviw
  98        (unsigned long efn,
  99         unsigned short chan,
 100         const struct dsc$descriptor_s * devnam,
 101         const struct item_list_3 * itmlst,
 102         void * iosb,
 103         void * (astadr)(unsigned long),
 104         void * astprm,
 105         void * nullarg);
 106 #endif
 107
 108 #ifdef sys$get_security
 109 #undef sys$get_security
 110 int sys$get_security
 111        (const struct dsc$descriptor_s * clsnam,
 112         const struct dsc$descriptor_s * objnam,
 113         const unsigned int *objhan,
 114         unsigned int flags,
 115         const struct item_list_3 * itmlst,
 116         unsigned int * contxt,
 117         const unsigned int * acmode);
 118 #endif
 119
 120 #ifdef sys$set_security
 121 #undef sys$set_security
 122 int sys$set_security
 123        (const struct dsc$descriptor_s * clsnam,
 124         const struct dsc$descriptor_s * objnam,
 125         const unsigned int *objhan,
 126         unsigned int flags,
 127         const struct item_list_3 * itmlst,
 128         unsigned int * contxt,
 129         const unsigned int * acmode);
 130 #endif
 131
 132 #ifdef lib$find_image_symbol
 133 #undef lib$find_image_symbol
 134 int lib$find_image_symbol
 135        (const struct dsc$descriptor_s * imgname,
 136         const struct dsc$descriptor_s * symname,
 137         void * symval,
 138         const struct dsc$descriptor_s * defspec,
 139         unsigned long flag);
 140 #endif
 141
 142 #ifdef lib$rename_file
 143 #undef lib$rename_file
 144 int lib$rename_file
 145        (const struct dsc$descriptor_s * old_file_dsc,
 146         const struct dsc$descriptor_s * new_file_dsc,
 147         const struct dsc$descriptor_s * default_file_dsc,
 148         const struct dsc$descriptor_s * related_file_dsc,
 149         const unsigned long * flags,
 150         void * (success)(const struct dsc$descriptor_s * old_dsc,
 151                          const struct dsc$descriptor_s * new_dsc,
 152                          const void *),
 153         void * (error)(const struct dsc$descriptor_s * old_dsc,
 154                        const struct dsc$descriptor_s * new_dsc,
 155                        const int * rms_sts,
 156                        const int * rms_stv,
 157                        const int * error_src,
 158                        const void * usr_arg),
 159         int (confirm)(const struct dsc$descriptor_s * old_dsc,
 160                       const struct dsc$descriptor_s * new_dsc,
 161                       const void * old_fab,
 162                       const void * usr_arg),
 163         void * user_arg,
 164         struct dsc$descriptor_s * old_result_name_dsc,
 165         struct dsc$descriptor_s * new_result_name_dsc,
 166         unsigned long * file_scan_context);
 167 #endif
 168
 169 #if __CRTL_VER >= 70300000 && !defined(__VAX)
 170
 171 static int set_feature_default(const char *name, int value)
 172 {
 173     int status;
 174     int index;
 175
 176     index = decc$feature_get_index(name);
 177
 178     status = decc$feature_set_value(index, 1, value);
 179     if (index == -1 || (status == -1)) {
 180       return -1;
 181     }
 182
 183     status = decc$feature_get_value(index, 1);
 184     if (status != value) {
 185       return -1;
 186     }
 187
 188 return 0;
 189 }
 190 #endif
 191
 192 /* Older versions of ssdef.h don't have these */
 193 #ifndef SS$_INVFILFOROP
 194 #  define SS$_INVFILFOROP 3930
 195 #endif
 196 #ifndef SS$_NOSUCHOBJECT
 197 #  define SS$_NOSUCHOBJECT 2696
 198 #endif
 199
 200 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
 201 #define PERLIO_NOT_STDIO 0
 202
 203 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
 204  * code below needs to get to the underlying CRTL routines. */
 205 #define DONT_MASK_RTL_CALLS
 206 #include "EXTERN.h"
 207 #include "perl.h"
 208 #include "XSUB.h"
 209 /* Anticipating future expansion in lexical warnings . . . */
 210 #ifndef WARN_INTERNAL
 211 #  define WARN_INTERNAL WARN_MISC
 212 #endif
 213
 214 #ifdef VMS_LONGNAME_SUPPORT
 215 #include <libfildef.h>
 216 #endif
 217
 218 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
 219 #  define RTL_USES_UTC 1
 220 #endif
 221
 222 /* Routine to create a decterm for use with the Perl debugger */
 223 /* No headers, this information was found in the Programming Concepts Manual */
 224
 225 static int (*decw_term_port)
 226    (const struct dsc$descriptor_s * display,
 227     const struct dsc$descriptor_s * setup_file,
 228     const struct dsc$descriptor_s * customization,
 229     struct dsc$descriptor_s * result_device_name,
 230     unsigned short * result_device_name_length,
 231     void * controller,
 232     void * char_buffer,
 233     void * char_change_buffer) = 0;
 234
 235 /* gcc's header files don't #define direct access macros
 236  * corresponding to VAXC's variant structs */
 237 #ifdef __GNUC__
 238 #  define uic$v_format uic$r_uic_form.uic$v_format
 239 #  define uic$v_group uic$r_uic_form.uic$v_group
 240 #  define uic$v_member uic$r_uic_form.uic$v_member
 241 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 242 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 243 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 244 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 245 #endif
 246
 247 #if defined(NEED_AN_H_ERRNO)
 248 dEXT int h_errno;
 249 #endif
 250
 251 #ifdef __DECC
 252 #pragma message disable pragma
 253 #pragma member_alignment save
 254 #pragma nomember_alignment longword
 255 #pragma message save
 256 #pragma message disable misalgndmem
 257 #endif
 258 struct itmlst_3 {
 259   unsigned short int buflen;
 260   unsigned short int itmcode;
 261   void *bufadr;
 262   unsigned short int *retlen;
 263 };
 264
 265 struct filescan_itmlst_2 {
 266     unsigned short length;
 267     unsigned short itmcode;
 268     char * component;
 269 };
 270
 271 struct vs_str_st {
 272     unsigned short length;
 273     char str[65536];
 274 };
 275
 276 #ifdef __DECC
 277 #pragma message restore
 278 #pragma member_alignment restore
 279 #endif
 280
 281 #define do_fileify_dirspec(a,b,c,d)     mp_do_fileify_dirspec(aTHX_ a,b,c,d)
 282 #define do_pathify_dirspec(a,b,c,d)     mp_do_pathify_dirspec(aTHX_ a,b,c,d)
 283 #define do_tovmsspec(a,b,c,d)           mp_do_tovmsspec(aTHX_ a,b,c,0,d)
 284 #define do_tovmspath(a,b,c,d)           mp_do_tovmspath(aTHX_ a,b,c,d)
 285 #define do_rmsexpand(a,b,c,d,e,f,g)     mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
 286 #define do_vms_realpath(a,b,c)          mp_do_vms_realpath(aTHX_ a,b,c)
 287 #define do_vms_realname(a,b,c)          mp_do_vms_realname(aTHX_ a,b,c)
 288 #define do_tounixspec(a,b,c,d)          mp_do_tounixspec(aTHX_ a,b,c,d)
 289 #define do_tounixpath(a,b,c,d)          mp_do_tounixpath(aTHX_ a,b,c,d)
 290 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 291 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 292 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 293
 294 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
 295 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
 296 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
 297 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
 298
 299 static char *  int_rmsexpand_vms(
 300     const char * filespec, char * outbuf, unsigned opts);
 301 static char * int_rmsexpand_tovms(
 302     const char * filespec, char * outbuf, unsigned opts);
 303 static char *int_tovmsspec
 304    (const char *path, char *buf, int dir_flag, int * utf8_flag);
 305 static char * int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl);
 306 static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl);
 307 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl);
 308
 309 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 310 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 311
 312 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 313  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 314  * the Perl facility.
 315  */
 316 #define PERL_LNM_MAX_ITER 10
 317
 318   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 319 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 320 #define MAX_DCL_SYMBOL          (8192)
 321 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 322 #else
 323 #define MAX_DCL_SYMBOL          (1024)
 324 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 325 #endif
 326
 327 static char *__mystrtolower(char *str)
 328 {
 329   if (str) for (; *str; ++str) *str= tolower(*str);
 330   return str;
 331 }
 332
 333 static struct dsc$descriptor_s fildevdsc =
 334   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 335 static struct dsc$descriptor_s crtlenvdsc =
 336   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 337 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 338 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 339 static struct dsc$descriptor_s **env_tables = defenv;
 340 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 341
 342 /* True if we shouldn't treat barewords as logicals during directory */
 343 /* munching */
 344 static int no_translate_barewords;
 345
 346 #ifndef RTL_USES_UTC
 347 static int tz_updated = 1;
 348 #endif
 349
 350 /* DECC Features that may need to affect how Perl interprets
 351  * displays filename information
 352  */
 353 static int decc_disable_to_vms_logname_translation = 1;
 354 static int decc_disable_posix_root = 1;
 355 int decc_efs_case_preserve = 0;
 356 static int decc_efs_charset = 0;
 357 static int decc_efs_charset_index = -1;
 358 static int decc_filename_unix_no_version = 0;
 359 static int decc_filename_unix_only = 0;
 360 int decc_filename_unix_report = 0;
 361 int decc_posix_compliant_pathnames = 0;
 362 int decc_readdir_dropdotnotype = 0;
 363 static int vms_process_case_tolerant = 1;
 364 int vms_vtf7_filenames = 0;
 365 int gnv_unix_shell = 0;
 366 static int vms_unlink_all_versions = 0;
 367 static int vms_posix_exit = 0;
 368
 369 /* bug workarounds if needed */
 370 int decc_bug_devnull = 1;
 371 int decc_dir_barename = 0;
 372 int vms_bug_stat_filename = 0;
 373
 374 static int vms_debug_on_exception = 0;
 375 static int vms_debug_fileify = 0;
 376
 377 /* Simple logical name translation */
 378 static int simple_trnlnm
 379    (const char * logname,
 380     char * value,
 381     int value_len)
 382 {
 383     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
 384     const unsigned long attr = LNM$M_CASE_BLIND;
 385     struct dsc$descriptor_s name_dsc;
 386     int status;
 387     unsigned short result;
 388     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
 389                                 {0, 0, 0, 0}};
 390
 391     name_dsc.dsc$w_length = strlen(logname);
 392     name_dsc.dsc$a_pointer = (char *)logname;
 393     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
 394     name_dsc.dsc$b_class = DSC$K_CLASS_S;
 395
 396     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
 397
 398     if ($VMS_STATUS_SUCCESS(status)) {
 399
 400          /* Null terminate and return the string */
 401         /*--------------------------------------*/
 402         value[result] = 0;
 403         return result;
 404     }
 405
 406     return 0;
 407 }
 408
 409
 410 /* Is this a UNIX file specification?
 411  *   No longer a simple check with EFS file specs
 412  *   For now, not a full check, but need to
 413  *   handle POSIX ^UP^ specifications
 414  *   Fixing to handle ^/ cases would require
 415  *   changes to many other conversion routines.
 416  */
 417
 418 static int is_unix_filespec(const char *path)
 419 {
 420 int ret_val;
 421 const char * pch1;
 422
 423     ret_val = 0;
 424     if (strncmp(path,"\"^UP^",5) != 0) {
 425         pch1 = strchr(path, '/');
 426         if (pch1 != NULL)
 427             ret_val = 1;
 428         else {
 429
 430             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 431             if (decc_filename_unix_report || decc_filename_unix_only) {
 432             if (strcmp(path,".") == 0)
 433                 ret_val = 1;
 434             }
 435         }
 436     }
 437     return ret_val;
 438 }
 439
 440 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 441  */
 442
 443 static void ucs2_to_vtf7
 444    (char *outspec,
 445     unsigned long ucs2_char,
 446     int * output_cnt)
 447 {
 448 unsigned char * ucs_ptr;
 449 int hex;
 450
 451     ucs_ptr = (unsigned char *)&ucs2_char;
 452
 453     outspec[0] = '^';
 454     outspec[1] = 'U';
 455     hex = (ucs_ptr[1] >> 4) & 0xf;
 456     if (hex < 0xA)
 457         outspec[2] = hex + '0';
 458     else
 459         outspec[2] = (hex - 9) + 'A';
 460     hex = ucs_ptr[1] & 0xF;
 461     if (hex < 0xA)
 462         outspec[3] = hex + '0';
 463     else {
 464         outspec[3] = (hex - 9) + 'A';
 465     }
 466     hex = (ucs_ptr[0] >> 4) & 0xf;
 467     if (hex < 0xA)
 468         outspec[4] = hex + '0';
 469     else
 470         outspec[4] = (hex - 9) + 'A';
 471     hex = ucs_ptr[1] & 0xF;
 472     if (hex < 0xA)
 473         outspec[5] = hex + '0';
 474     else {
 475         outspec[5] = (hex - 9) + 'A';
 476     }
 477     *output_cnt = 6;
 478 }
 479
 480
 481 /* This handles the conversion of a UNIX extended character set to a ^
 482  * escaped VMS character.
 483  * in a UNIX file specification.
 484  *
 485  * The output count variable contains the number of characters added
 486  * to the output string.
 487  *
 488  * The return value is the number of characters read from the input string
 489  */
 490 static int copy_expand_unix_filename_escape
 491   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 492 {
 493 int count;
 494 int scnt;
 495 int utf8_flag;
 496
 497     utf8_flag = 0;
 498     if (utf8_fl)
 499       utf8_flag = *utf8_fl;
 500
 501     count = 0;
 502     *output_cnt = 0;
 503     if (*inspec >= 0x80) {
 504         if (utf8_fl && vms_vtf7_filenames) {
 505         unsigned long ucs_char;
 506
 507             ucs_char = 0;
 508
 509             if ((*inspec & 0xE0) == 0xC0) {
 510                 /* 2 byte Unicode */
 511                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 512                 if (ucs_char >= 0x80) {
 513                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 514                     return 2;
 515                 }
 516             } else if ((*inspec & 0xF0) == 0xE0) {
 517                 /* 3 byte Unicode */
 518                 ucs_char = ((inspec[0] & 0xF) << 12) +
 519                    ((inspec[1] & 0x3f) << 6) +
 520                    (inspec[2] & 0x3f);
 521                 if (ucs_char >= 0x800) {
 522                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 523                     return 3;
 524                 }
 525
 526 #if 0 /* I do not see longer sequences supported by OpenVMS */
 527       /* Maybe some one can fix this later */
 528             } else if ((*inspec & 0xF8) == 0xF0) {
 529                 /* 4 byte Unicode */
 530                 /* UCS-4 to UCS-2 */
 531             } else if ((*inspec & 0xFC) == 0xF8) {
 532                 /* 5 byte Unicode */
 533                 /* UCS-4 to UCS-2 */
 534             } else if ((*inspec & 0xFE) == 0xFC) {
 535                 /* 6 byte Unicode */
 536                 /* UCS-4 to UCS-2 */
 537 #endif
 538             }
 539         }
 540
 541         /* High bit set, but not a Unicode character! */
 542
 543         /* Non printing DECMCS or ISO Latin-1 character? */
 544         if (*inspec <= 0x9F) {
 545         int hex;
 546             outspec[0] = '^';
 547             outspec++;
 548             hex = (*inspec >> 4) & 0xF;
 549             if (hex < 0xA)
 550                 outspec[1] = hex + '0';
 551             else {
 552                 outspec[1] = (hex - 9) + 'A';
 553             }
 554             hex = *inspec & 0xF;
 555             if (hex < 0xA)
 556                 outspec[2] = hex + '0';
 557             else {
 558                 outspec[2] = (hex - 9) + 'A';
 559             }
 560             *output_cnt = 3;
 561             return 1;
 562         } else if (*inspec == 0xA0) {
 563             outspec[0] = '^';
 564             outspec[1] = 'A';
 565             outspec[2] = '0';
 566             *output_cnt = 3;
 567             return 1;
 568         } else if (*inspec == 0xFF) {
 569             outspec[0] = '^';
 570             outspec[1] = 'F';
 571             outspec[2] = 'F';
 572             *output_cnt = 3;
 573             return 1;
 574         }
 575         *outspec = *inspec;
 576         *output_cnt = 1;
 577         return 1;
 578     }
 579
 580     /* Is this a macro that needs to be passed through?
 581      * Macros start with $( and an alpha character, followed
 582      * by a string of alpha numeric characters ending with a )
 583      * If this does not match, then encode it as ODS-5.
 584      */
 585     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 586     int tcnt;
 587
 588         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 589             tcnt = 3;
 590             outspec[0] = inspec[0];
 591             outspec[1] = inspec[1];
 592             outspec[2] = inspec[2];
 593
 594             while(isalnum(inspec[tcnt]) ||
 595                   (inspec[2] == '.') || (inspec[2] == '_')) {
 596                 outspec[tcnt] = inspec[tcnt];
 597                 tcnt++;
 598             }
 599             if (inspec[tcnt] == ')') {
 600                 outspec[tcnt] = inspec[tcnt];
 601                 tcnt++;
 602                 *output_cnt = tcnt;
 603                 return tcnt;
 604             }
 605         }
 606     }
 607
 608     switch (*inspec) {
 609     case 0x7f:
 610         outspec[0] = '^';
 611         outspec[1] = '7';
 612         outspec[2] = 'F';
 613         *output_cnt = 3;
 614         return 1;
 615         break;
 616     case '?':
 617         if (decc_efs_charset == 0)
 618           outspec[0] = '%';
 619         else
 620           outspec[0] = '?';
 621         *output_cnt = 1;
 622         return 1;
 623         break;
 624     case '.':
 625     case '~':
 626     case '!':
 627     case '#':
 628     case '&':
 629     case '\'':
 630     case '`':
 631     case '(':
 632     case ')':
 633     case '+':
 634     case '@':
 635     case '{':
 636     case '}':
 637     case ',':
 638     case ';':
 639     case '[':
 640     case ']':
 641     case '%':
 642     case '^':
 643     case '\\':
 644         /* Don't escape again if following character is
 645          * already something we escape.
 646          */
 647         if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
 648             *outspec = *inspec;
 649             *output_cnt = 1;
 650             return 1;
 651             break;
 652         }
 653         /* But otherwise fall through and escape it. */
 654     case '=':
 655         /* Assume that this is to be escaped */
 656         outspec[0] = '^';
 657         outspec[1] = *inspec;
 658         *output_cnt = 2;
 659         return 1;
 660         break;
 661     case ' ': /* space */
 662         /* Assume that this is to be escaped */
 663         outspec[0] = '^';
 664         outspec[1] = '_';
 665         *output_cnt = 2;
 666         return 1;
 667         break;
 668     default:
 669         *outspec = *inspec;
 670         *output_cnt = 1;
 671         return 1;
 672         break;
 673     }
 674 }
 675
 676
 677 /* This handles the expansion of a '^' prefix to the proper character
 678  * in a UNIX file specification.
 679  *
 680  * The output count variable contains the number of characters added
 681  * to the output string.
 682  *
 683  * The return value is the number of characters read from the input
 684  * string
 685  */
 686 static int copy_expand_vms_filename_escape
 687   (char *outspec, const char *inspec, int *output_cnt)
 688 {
 689 int count;
 690 int scnt;
 691
 692     count = 0;
 693     *output_cnt = 0;
 694     if (*inspec == '^') {
 695         inspec++;
 696         switch (*inspec) {
 697         /* Spaces and non-trailing dots should just be passed through,
 698          * but eat the escape character.
 699          */
 700         case '.':
 701             *outspec = *inspec;
 702             count += 2;
 703             (*output_cnt)++;
 704             break;
 705         case '_': /* space */
 706             *outspec = ' ';
 707             count += 2;
 708             (*output_cnt)++;
 709             break;
 710         case '^':
 711             /* Hmm.  Better leave the escape escaped. */
 712             outspec[0] = '^';
 713             outspec[1] = '^';
 714             count += 2;
 715             (*output_cnt) += 2;
 716             break;
 717         case 'U': /* Unicode - FIX-ME this is wrong. */
 718             inspec++;
 719             count++;
 720             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 721             if (scnt == 4) {
 722                 unsigned int c1, c2;
 723                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 724                 outspec[0] == c1 & 0xff;
 725                 outspec[1] == c2 & 0xff;
 726                 if (scnt > 1) {
 727                     (*output_cnt) += 2;
 728                     count += 4;
 729                 }
 730             }
 731             else {
 732                 /* Error - do best we can to continue */
 733                 *outspec = 'U';
 734                 outspec++;
 735                 (*output_cnt++);
 736                 *outspec = *inspec;
 737                 count++;
 738                 (*output_cnt++);
 739             }
 740             break;
 741         default:
 742             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 743             if (scnt == 2) {
 744                 /* Hex encoded */
 745                 unsigned int c1;
 746                 scnt = sscanf(inspec, "%2x", &c1);
 747                 outspec[0] = c1 & 0xff;
 748                 if (scnt > 0) {
 749                     (*output_cnt++);
 750                     count += 2;
 751                 }
 752             }
 753             else {
 754                 *outspec = *inspec;
 755                 count++;
 756                 (*output_cnt++);
 757             }
 758         }
 759     }
 760     else {
 761         *outspec = *inspec;
 762         count++;
 763         (*output_cnt)++;
 764     }
 765     return count;
 766 }
 767
 768 #ifdef sys$filescan
 769 #undef sys$filescan
 770 int sys$filescan
 771    (const struct dsc$descriptor_s * srcstr,
 772     struct filescan_itmlst_2 * valuelist,
 773     unsigned long * fldflags,
 774     struct dsc$descriptor_s *auxout,
 775     unsigned short * retlen);
 776 #endif
 777
 778 /* vms_split_path - Verify that the input file specification is a
 779  * VMS format file specification, and provide pointers to the components of
 780  * it.  With EFS format filenames, this is virtually the only way to
 781  * parse a VMS path specification into components.
 782  *
 783  * If the sum of the components do not add up to the length of the
 784  * string, then the passed file specification is probably a UNIX style
 785  * path.
 786  */
 787 static int vms_split_path
 788    (const char * path,
 789     char * * volume,
 790     int * vol_len,
 791     char * * root,
 792     int * root_len,
 793     char * * dir,
 794     int * dir_len,
 795     char * * name,
 796     int * name_len,
 797     char * * ext,
 798     int * ext_len,
 799     char * * version,
 800     int * ver_len)
 801 {
 802 struct dsc$descriptor path_desc;
 803 int status;
 804 unsigned long flags;
 805 int ret_stat;
 806 struct filescan_itmlst_2 item_list[9];
 807 const int filespec = 0;
 808 const int nodespec = 1;
 809 const int devspec = 2;
 810 const int rootspec = 3;
 811 const int dirspec = 4;
 812 const int namespec = 5;
 813 const int typespec = 6;
 814 const int verspec = 7;
 815
 816     /* Assume the worst for an easy exit */
 817     ret_stat = -1;
 818     *volume = NULL;
 819     *vol_len = 0;
 820     *root = NULL;
 821     *root_len = 0;
 822     *dir = NULL;
 823     *dir_len;
 824     *name = NULL;
 825     *name_len = 0;
 826     *ext = NULL;
 827     *ext_len = 0;
 828     *version = NULL;
 829     *ver_len = 0;
 830
 831     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 832     path_desc.dsc$w_length = strlen(path);
 833     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 834     path_desc.dsc$b_class = DSC$K_CLASS_S;
 835
 836     /* Get the total length, if it is shorter than the string passed
 837      * then this was probably not a VMS formatted file specification
 838      */
 839     item_list[filespec].itmcode = FSCN$_FILESPEC;
 840     item_list[filespec].length = 0;
 841     item_list[filespec].component = NULL;
 842
 843     /* If the node is present, then it gets considered as part of the
 844      * volume name to hopefully make things simple.
 845      */
 846     item_list[nodespec].itmcode = FSCN$_NODE;
 847     item_list[nodespec].length = 0;
 848     item_list[nodespec].component = NULL;
 849
 850     item_list[devspec].itmcode = FSCN$_DEVICE;
 851     item_list[devspec].length = 0;
 852     item_list[devspec].component = NULL;
 853
 854     /* root is a special case,  adding it to either the directory or
 855      * the device components will probalby complicate things for the
 856      * callers of this routine, so leave it separate.
 857      */
 858     item_list[rootspec].itmcode = FSCN$_ROOT;
 859     item_list[rootspec].length = 0;
 860     item_list[rootspec].component = NULL;
 861
 862     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 863     item_list[dirspec].length = 0;
 864     item_list[dirspec].component = NULL;
 865
 866     item_list[namespec].itmcode = FSCN$_NAME;
 867     item_list[namespec].length = 0;
 868     item_list[namespec].component = NULL;
 869
 870     item_list[typespec].itmcode = FSCN$_TYPE;
 871     item_list[typespec].length = 0;
 872     item_list[typespec].component = NULL;
 873
 874     item_list[verspec].itmcode = FSCN$_VERSION;
 875     item_list[verspec].length = 0;
 876     item_list[verspec].component = NULL;
 877
 878     item_list[8].itmcode = 0;
 879     item_list[8].length = 0;
 880     item_list[8].component = NULL;
 881
 882     status = sys$filescan
 883        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 884         &flags, NULL, NULL);
 885     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 886
 887     /* If we parsed it successfully these two lengths should be the same */
 888     if (path_desc.dsc$w_length != item_list[filespec].length)
 889         return ret_stat;
 890
 891     /* If we got here, then it is a VMS file specification */
 892     ret_stat = 0;
 893
 894     /* set the volume name */
 895     if (item_list[nodespec].length > 0) {
 896         *volume = item_list[nodespec].component;
 897         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 898     }
 899     else {
 900         *volume = item_list[devspec].component;
 901         *vol_len = item_list[devspec].length;
 902     }
 903
 904     *root = item_list[rootspec].component;
 905     *root_len = item_list[rootspec].length;
 906
 907     *dir = item_list[dirspec].component;
 908     *dir_len = item_list[dirspec].length;
 909
 910     /* Now fun with versions and EFS file specifications
 911      * The parser can not tell the difference when a "." is a version
 912      * delimiter or a part of the file specification.
 913      */
 914     if ((decc_efs_charset) &&
 915         (item_list[verspec].length > 0) &&
 916         (item_list[verspec].component[0] == '.')) {
 917         *name = item_list[namespec].component;
 918         *name_len = item_list[namespec].length + item_list[typespec].length;
 919         *ext = item_list[verspec].component;
 920         *ext_len = item_list[verspec].length;
 921         *version = NULL;
 922         *ver_len = 0;
 923     }
 924     else {
 925         *name = item_list[namespec].component;
 926         *name_len = item_list[namespec].length;
 927         *ext = item_list[typespec].component;
 928         *ext_len = item_list[typespec].length;
 929         *version = item_list[verspec].component;
 930         *ver_len = item_list[verspec].length;
 931     }
 932     return ret_stat;
 933 }
 934
 935 /* Routine to determine if the file specification ends with .dir */
 936 static int is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len) {
 937
 938     /* e_len must be 4, and version must be <= 2 characters */
 939     if (e_len != 4 || vs_len > 2)
 940         return 0;
 941
 942     /* If a version number is present, it needs to be one */
 943     if ((vs_len == 2) && (vs_spec[1] != '1'))
 944         return 0;
 945
 946     /* Look for the DIR on the extension */
 947     if (vms_process_case_tolerant) {
 948         if ((toupper(e_spec[1]) == 'D') &&
 949             (toupper(e_spec[2]) == 'I') &&
 950             (toupper(e_spec[3]) == 'R')) {
 951             return 1;
 952         }
 953     } else {
 954         /* Directory extensions are supposed to be in upper case only */
 955         /* I would not be surprised if this rule can not be enforced */
 956         /* if and when someone fully debugs the case sensitive mode */
 957         if ((e_spec[1] == 'D') &&
 958             (e_spec[2] == 'I') &&
 959             (e_spec[3] == 'R')) {
 960             return 1;
 961         }
 962     }
 963     return 0;
 964 }
 965
 966
 967 /* my_maxidx
 968  * Routine to retrieve the maximum equivalence index for an input
 969  * logical name.  Some calls to this routine have no knowledge if
 970  * the variable is a logical or not.  So on error we return a max
 971  * index of zero.
 972  */
 973 /*{{{int my_maxidx(const char *lnm) */
 974 static int
 975 my_maxidx(const char *lnm)
 976 {
 977     int status;
 978     int midx;
 979     int attr = LNM$M_CASE_BLIND;
 980     struct dsc$descriptor lnmdsc;
 981     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 982                                 {0, 0, 0, 0}};
 983
 984     lnmdsc.dsc$w_length = strlen(lnm);
 985     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 986     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 987     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 988
 989     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 990     if ((status & 1) == 0)
 991        midx = 0;
 992
 993     return (midx);
 994 }
 995 /*}}}*/
 996
 997 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 998 int
 999 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
1000   struct dsc$descriptor_s **tabvec, unsigned long int flags)
1001 {
1002     const char *cp1;
1003     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
1004     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
1005     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
1006     int midx;
1007     unsigned char acmode;
1008     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1009                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1010     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
1011                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
1012                                  {0, 0, 0, 0}};
1013     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1014 #if defined(PERL_IMPLICIT_CONTEXT)
1015     pTHX = NULL;
1016     if (PL_curinterp) {
1017       aTHX = PERL_GET_INTERP;
1018     } else {
1019       aTHX = NULL;
1020     }
1021 #endif
1022
1023     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
1024       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
1025     }
1026     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1027       *cp2 = _toupper(*cp1);
1028       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1029         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1030         return 0;
1031       }
1032     }
1033     lnmdsc.dsc$w_length = cp1 - lnm;
1034     lnmdsc.dsc$a_pointer = uplnm;
1035     uplnm[lnmdsc.dsc$w_length] = '\0';
1036     secure = flags & PERL__TRNENV_SECURE;
1037     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
1038     if (!tabvec || !*tabvec) tabvec = env_tables;
1039
1040     for (curtab = 0; tabvec[curtab]; curtab++) {
1041       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1042         if (!ivenv && !secure) {
1043           char *eq, *end;
1044           int i;
1045           if (!environ) {
1046             ivenv = 1;
1047 #if defined(PERL_IMPLICIT_CONTEXT)
1048             if (aTHX == NULL) {
1049                 fprintf(stderr,
1050                     "%%PERL-W-VMS_INIT Can't read CRTL environ\n");
1051             } else
1052 #endif
1053                 Perl_warn(aTHX_ "Can't read CRTL environ\n");
1054             continue;
1055           }
1056           retsts = SS$_NOLOGNAM;
1057           for (i = 0; environ[i]; i++) {
1058             if ((eq = strchr(environ[i],'=')) &&
1059                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
1060                 !strncmp(environ[i],uplnm,eq - environ[i])) {
1061               eq++;
1062               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
1063               if (!eqvlen) continue;
1064               retsts = SS$_NORMAL;
1065               break;
1066             }
1067           }
1068           if (retsts != SS$_NOLOGNAM) break;
1069         }
1070       }
1071       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1072                !str$case_blind_compare(&tmpdsc,&clisym)) {
1073         if (!ivsym && !secure) {
1074           unsigned short int deflen = LNM$C_NAMLENGTH;
1075           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1076           /* dynamic dsc to accomodate possible long value */
1077           _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
1078           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
1079           if (retsts & 1) {
1080             if (eqvlen > MAX_DCL_SYMBOL) {
1081               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
1082               eqvlen = MAX_DCL_SYMBOL;
1083               /* Special hack--we might be called before the interpreter's */
1084               /* fully initialized, in which case either thr or PL_curcop */
1085               /* might be bogus. We have to check, since ckWARN needs them */
1086               /* both to be valid if running threaded */
1087 #if defined(PERL_IMPLICIT_CONTEXT)
1088               if (aTHX == NULL) {
1089                   fprintf(stderr,
1090                      "%Perl-VMS-Init, Value of CLI symbol \"%s\" too long",lnm);
1091               } else
1092 #endif
1093                 if (ckWARN(WARN_MISC)) {
1094                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
1095                 }
1096             }
1097             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
1098           }
1099           _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
1100           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1101           if (retsts == LIB$_NOSUCHSYM) continue;
1102           break;
1103         }
1104       }
1105       else if (!ivlnm) {
1106         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
1107           midx = my_maxidx(lnm);
1108           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1109             lnmlst[1].bufadr = cp2;
1110             eqvlen = 0;
1111             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1112             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1113             if (retsts == SS$_NOLOGNAM) break;
1114             /* PPFs have a prefix */
1115             if (
1116 #if INTSIZE == 4
1117                  *((int *)uplnm) == *((int *)"SYS$")                    &&
1118 #endif
1119                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
1120                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
1121                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
1122                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
1123                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
1124               memmove(eqv,eqv+4,eqvlen-4);
1125               eqvlen -= 4;
1126             }
1127             cp2 += eqvlen;
1128             *cp2 = '\0';
1129           }
1130           if ((retsts == SS$_IVLOGNAM) ||
1131               (retsts == SS$_NOLOGNAM)) { continue; }
1132         }
1133         else {
1134           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1135           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1136           if (retsts == SS$_NOLOGNAM) continue;
1137           eqv[eqvlen] = '\0';
1138         }
1139         eqvlen = strlen(eqv);
1140         break;
1141       }
1142     }
1143     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1144     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1145              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
1146              retsts == SS$_NOLOGNAM) {
1147       set_errno(EINVAL);  set_vaxc_errno(retsts);
1148     }
1149     else _ckvmssts_noperl(retsts);
1150     return 0;
1151 }  /* end of vmstrnenv */
1152 /*}}}*/
1153
1154 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1155 /* Define as a function so we can access statics. */
1156 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1157 {
1158     int flags = 0;
1159
1160 #if defined(PERL_IMPLICIT_CONTEXT)
1161     if (aTHX != NULL)
1162 #endif
1163 #ifdef SECURE_INTERNAL_GETENV
1164         flags = (PL_curinterp ? PL_tainting : will_taint) ?
1165                  PERL__TRNENV_SECURE : 0;
1166 #endif
1167
1168     return vmstrnenv(lnm, eqv, idx, fildev, flags);
1169 }
1170 /*}}}*/
1171
1172 /* my_getenv
1173  * Note: Uses Perl temp to store result so char * can be returned to
1174  * caller; this pointer will be invalidated at next Perl statement
1175  * transition.
1176  * We define this as a function rather than a macro in terms of my_getenv_len()
1177  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1178  * allocate SVs).
1179  */
1180 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1181 char *
1182 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1183 {
1184     const char *cp1;
1185     static char *__my_getenv_eqv = NULL;
1186     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1187     unsigned long int idx = 0;
1188     int trnsuccess, success, secure, saverr, savvmserr;
1189     int midx, flags;
1190     SV *tmpsv;
1191
1192     midx = my_maxidx(lnm) + 1;
1193
1194     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1195       /* Set up a temporary buffer for the return value; Perl will
1196        * clean it up at the next statement transition */
1197       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1198       if (!tmpsv) return NULL;
1199       eqv = SvPVX(tmpsv);
1200     }
1201     else {
1202       /* Assume no interpreter ==> single thread */
1203       if (__my_getenv_eqv != NULL) {
1204         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1205       }
1206       else {
1207         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1208       }
1209       eqv = __my_getenv_eqv;
1210     }
1211
1212     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1213     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1214       int len;
1215       getcwd(eqv,LNM$C_NAMLENGTH);
1216
1217       len = strlen(eqv);
1218
1219       /* Get rid of "000000/ in rooted filespecs */
1220       if (len > 7) {
1221         char * zeros;
1222         zeros = strstr(eqv, "/000000/");
1223         if (zeros != NULL) {
1224           int mlen;
1225           mlen = len - (zeros - eqv) - 7;
1226           memmove(zeros, &zeros[7], mlen);
1227           len = len - 7;
1228           eqv[len] = '\0';
1229         }
1230       }
1231       return eqv;
1232     }
1233     else {
1234       /* Impose security constraints only if tainting */
1235       if (sys) {
1236         /* Impose security constraints only if tainting */
1237         secure = PL_curinterp ? PL_tainting : will_taint;
1238         saverr = errno;  savvmserr = vaxc$errno;
1239       }
1240       else {
1241         secure = 0;
1242       }
1243
1244       flags =
1245 #ifdef SECURE_INTERNAL_GETENV
1246               secure ? PERL__TRNENV_SECURE : 0
1247 #else
1248               0
1249 #endif
1250       ;
1251
1252       /* For the getenv interface we combine all the equivalence names
1253        * of a search list logical into one value to acquire a maximum
1254        * value length of 255*128 (assuming %ENV is using logicals).
1255        */
1256       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1257
1258       /* If the name contains a semicolon-delimited index, parse it
1259        * off and make sure we only retrieve the equivalence name for
1260        * that index.  */
1261       if ((cp2 = strchr(lnm,';')) != NULL) {
1262         strcpy(uplnm,lnm);
1263         uplnm[cp2-lnm] = '\0';
1264         idx = strtoul(cp2+1,NULL,0);
1265         lnm = uplnm;
1266         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1267       }
1268
1269       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1270
1271       /* Discard NOLOGNAM on internal calls since we're often looking
1272        * for an optional name, and this "error" often shows up as the
1273        * (bogus) exit status for a die() call later on.  */
1274       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1275       return success ? eqv : NULL;
1276     }
1277
1278 }  /* end of my_getenv() */
1279 /*}}}*/
1280
1281
1282 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1283 char *
1284 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1285 {
1286     const char *cp1;
1287     char *buf, *cp2;
1288     unsigned long idx = 0;
1289     int midx, flags;
1290     static char *__my_getenv_len_eqv = NULL;
1291     int secure, saverr, savvmserr;
1292     SV *tmpsv;
1293
1294     midx = my_maxidx(lnm) + 1;
1295
1296     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1297       /* Set up a temporary buffer for the return value; Perl will
1298        * clean it up at the next statement transition */
1299       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1300       if (!tmpsv) return NULL;
1301       buf = SvPVX(tmpsv);
1302     }
1303     else {
1304       /* Assume no interpreter ==> single thread */
1305       if (__my_getenv_len_eqv != NULL) {
1306         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1307       }
1308       else {
1309         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1310       }
1311       buf = __my_getenv_len_eqv;
1312     }
1313
1314     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1315     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1316     char * zeros;
1317
1318       getcwd(buf,LNM$C_NAMLENGTH);
1319       *len = strlen(buf);
1320
1321       /* Get rid of "000000/ in rooted filespecs */
1322       if (*len > 7) {
1323       zeros = strstr(buf, "/000000/");
1324       if (zeros != NULL) {
1325         int mlen;
1326         mlen = *len - (zeros - buf) - 7;
1327         memmove(zeros, &zeros[7], mlen);
1328         *len = *len - 7;
1329         buf[*len] = '\0';
1330         }
1331       }
1332       return buf;
1333     }
1334     else {
1335       if (sys) {
1336         /* Impose security constraints only if tainting */
1337         secure = PL_curinterp ? PL_tainting : will_taint;
1338         saverr = errno;  savvmserr = vaxc$errno;
1339       }
1340       else {
1341         secure = 0;
1342       }
1343
1344       flags =
1345 #ifdef SECURE_INTERNAL_GETENV
1346               secure ? PERL__TRNENV_SECURE : 0
1347 #else
1348               0
1349 #endif
1350       ;
1351
1352       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1353
1354       if ((cp2 = strchr(lnm,';')) != NULL) {
1355         strcpy(buf,lnm);
1356         buf[cp2-lnm] = '\0';
1357         idx = strtoul(cp2+1,NULL,0);
1358         lnm = buf;
1359         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1360       }
1361
1362       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1363
1364       /* Get rid of "000000/ in rooted filespecs */
1365       if (*len > 7) {
1366       char * zeros;
1367         zeros = strstr(buf, "/000000/");
1368         if (zeros != NULL) {
1369           int mlen;
1370           mlen = *len - (zeros - buf) - 7;
1371           memmove(zeros, &zeros[7], mlen);
1372           *len = *len - 7;
1373           buf[*len] = '\0';
1374         }
1375       }
1376
1377       /* Discard NOLOGNAM on internal calls since we're often looking
1378        * for an optional name, and this "error" often shows up as the
1379        * (bogus) exit status for a die() call later on.  */
1380       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1381       return *len ? buf : NULL;
1382     }
1383
1384 }  /* end of my_getenv_len() */
1385 /*}}}*/
1386
1387 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
1388
1389 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1390
1391 /*{{{ void prime_env_iter() */
1392 void
1393 prime_env_iter(void)
1394 /* Fill the %ENV associative array with all logical names we can
1395  * find, in preparation for iterating over it.
1396  */
1397 {
1398   static int primed = 0;
1399   HV *seenhv = NULL, *envhv;
1400   SV *sv = NULL;
1401   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1402   unsigned short int chan;
1403 #ifndef CLI$M_TRUSTED
1404 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1405 #endif
1406   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1407   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1408   long int i;
1409   bool have_sym = FALSE, have_lnm = FALSE;
1410   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1411   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1412   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1413   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1414   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1415 #if defined(PERL_IMPLICIT_CONTEXT)
1416   pTHX;
1417 #endif
1418 #if defined(USE_ITHREADS)
1419   static perl_mutex primenv_mutex;
1420   MUTEX_INIT(&primenv_mutex);
1421 #endif
1422
1423 #if defined(PERL_IMPLICIT_CONTEXT)
1424     /* We jump through these hoops because we can be called at */
1425     /* platform-specific initialization time, which is before anything is */
1426     /* set up--we can't even do a plain dTHX since that relies on the */
1427     /* interpreter structure to be initialized */
1428     if (PL_curinterp) {
1429       aTHX = PERL_GET_INTERP;
1430     } else {
1431       /* we never get here because the NULL pointer will cause the */
1432       /* several of the routines called by this routine to access violate */
1433
1434       /* This routine is only called by hv.c/hv_iterinit which has a */
1435       /* context, so the real fix may be to pass it through instead of */
1436       /* the hoops above */
1437       aTHX = NULL;
1438     }
1439 #endif
1440
1441   if (primed || !PL_envgv) return;
1442   MUTEX_LOCK(&primenv_mutex);
1443   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1444   envhv = GvHVn(PL_envgv);
1445   /* Perform a dummy fetch as an lval to insure that the hash table is
1446    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1447   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1448
1449   for (i = 0; env_tables[i]; i++) {
1450      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1451          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1452      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1453   }
1454   if (have_sym || have_lnm) {
1455     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1456     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1457     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1458     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1459   }
1460
1461   for (i--; i >= 0; i--) {
1462     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1463       char *start;
1464       int j;
1465       for (j = 0; environ[j]; j++) {
1466         if (!(start = strchr(environ[j],'='))) {
1467           if (ckWARN(WARN_INTERNAL))
1468             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1469         }
1470         else {
1471           start++;
1472           sv = newSVpv(start,0);
1473           SvTAINTED_on(sv);
1474           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1475         }
1476       }
1477       continue;
1478     }
1479     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1480              !str$case_blind_compare(&tmpdsc,&clisym)) {
1481       strcpy(cmd,"Show Symbol/Global *");
1482       cmddsc.dsc$w_length = 20;
1483       if (env_tables[i]->dsc$w_length == 12 &&
1484           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1485           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1486       flags = defflags | CLI$M_NOLOGNAM;
1487     }
1488     else {
1489       strcpy(cmd,"Show Logical *");
1490       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1491         strcat(cmd," /Table=");
1492         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1493         cmddsc.dsc$w_length = strlen(cmd);
1494       }
1495       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1496       flags = defflags | CLI$M_NOCLISYM;
1497     }
1498
1499     /* Create a new subprocess to execute each command, to exclude the
1500      * remote possibility that someone could subvert a mbx or file used
1501      * to write multiple commands to a single subprocess.
1502      */
1503     do {
1504       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1505                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1506       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1507       defflags &= ~CLI$M_TRUSTED;
1508     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1509     _ckvmssts(retsts);
1510     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1511     if (seenhv) SvREFCNT_dec(seenhv);
1512     seenhv = newHV();
1513     while (1) {
1514       char *cp1, *cp2, *key;
1515       unsigned long int sts, iosb[2], retlen, keylen;
1516       register U32 hash;
1517
1518       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1519       if (sts & 1) sts = iosb[0] & 0xffff;
1520       if (sts == SS$_ENDOFFILE) {
1521         int wakect = 0;
1522         while (substs == 0) { sys$hiber(); wakect++;}
1523         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1524         _ckvmssts(substs);
1525         break;
1526       }
1527       _ckvmssts(sts);
1528       retlen = iosb[0] >> 16;
1529       if (!retlen) continue;  /* blank line */
1530       buf[retlen] = '\0';
1531       if (iosb[1] != subpid) {
1532         if (iosb[1]) {
1533           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1534         }
1535         continue;
1536       }
1537       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1538         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1539
1540       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1541       if (*cp1 == '(' || /* Logical name table name */
1542           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1543       if (*cp1 == '"') cp1++;
1544       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1545       key = cp1;  keylen = cp2 - cp1;
1546       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1547       while (*cp2 && *cp2 != '=') cp2++;
1548       while (*cp2 && *cp2 == '=') cp2++;
1549       while (*cp2 && *cp2 == ' ') cp2++;
1550       if (*cp2 == '"') {  /* String translation; may embed "" */
1551         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1552         cp2++;  cp1--; /* Skip "" surrounding translation */
1553       }
1554       else {  /* Numeric translation */
1555         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1556         cp1--;  /* stop on last non-space char */
1557       }
1558       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1559         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1560         continue;
1561       }
1562       PERL_HASH(hash,key,keylen);
1563
1564       if (cp1 == cp2 && *cp2 == '.') {
1565         /* A single dot usually means an unprintable character, such as a null
1566          * to indicate a zero-length value.  Get the actual value to make sure.
1567          */
1568         char lnm[LNM$C_NAMLENGTH+1];
1569         char eqv[MAX_DCL_SYMBOL+1];
1570         int trnlen;
1571         strncpy(lnm, key, keylen);
1572         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1573         sv = newSVpvn(eqv, strlen(eqv));
1574       }
1575       else {
1576         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1577       }
1578
1579       SvTAINTED_on(sv);
1580       hv_store(envhv,key,keylen,sv,hash);
1581       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1582     }
1583     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1584       /* get the PPFs for this process, not the subprocess */
1585       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1586       char eqv[LNM$C_NAMLENGTH+1];
1587       int trnlen, i;
1588       for (i = 0; ppfs[i]; i++) {
1589         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1590         sv = newSVpv(eqv,trnlen);
1591         SvTAINTED_on(sv);
1592         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1593       }
1594     }
1595   }
1596   primed = 1;
1597   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1598   if (buf) Safefree(buf);
1599   if (seenhv) SvREFCNT_dec(seenhv);
1600   MUTEX_UNLOCK(&primenv_mutex);
1601   return;
1602
1603 }  /* end of prime_env_iter */
1604 /*}}}*/
1605
1606
1607 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1608 /* Define or delete an element in the same "environment" as
1609  * vmstrnenv().  If an element is to be deleted, it's removed from
1610  * the first place it's found.  If it's to be set, it's set in the
1611  * place designated by the first element of the table vector.
1612  * Like setenv() returns 0 for success, non-zero on error.
1613  */
1614 int
1615 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1616 {
1617     const char *cp1;
1618     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1619     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1620     int nseg = 0, j;
1621     unsigned long int retsts, usermode = PSL$C_USER;
1622     struct itmlst_3 *ile, *ilist;
1623     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1624                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1625                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1626     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1627     $DESCRIPTOR(local,"_LOCAL");
1628
1629     if (!lnm) {
1630         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1631         return SS$_IVLOGNAM;
1632     }
1633
1634     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1635       *cp2 = _toupper(*cp1);
1636       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1637         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1638         return SS$_IVLOGNAM;
1639       }
1640     }
1641     lnmdsc.dsc$w_length = cp1 - lnm;
1642     if (!tabvec || !*tabvec) tabvec = env_tables;
1643
1644     if (!eqv) {  /* we're deleting n element */
1645       for (curtab = 0; tabvec[curtab]; curtab++) {
1646         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1647         int i;
1648           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1649             if ((cp1 = strchr(environ[i],'=')) &&
1650                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1651                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1652 #ifdef HAS_SETENV
1653               return setenv(lnm,"",1) ? vaxc$errno : 0;
1654             }
1655           }
1656           ivenv = 1; retsts = SS$_NOLOGNAM;
1657 #else
1658               if (ckWARN(WARN_INTERNAL))
1659                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1660               ivenv = 1; retsts = SS$_NOSUCHPGM;
1661               break;
1662             }
1663           }
1664 #endif
1665         }
1666         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1667                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1668           unsigned int symtype;
1669           if (tabvec[curtab]->dsc$w_length == 12 &&
1670               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1671               !str$case_blind_compare(&tmpdsc,&local))
1672             symtype = LIB$K_CLI_LOCAL_SYM;
1673           else symtype = LIB$K_CLI_GLOBAL_SYM;
1674           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1675           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1676           if (retsts == LIB$_NOSUCHSYM) continue;
1677           break;
1678         }
1679         else if (!ivlnm) {
1680           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1681           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1682           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1683           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1684           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1685         }
1686       }
1687     }
1688     else {  /* we're defining a value */
1689       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1690 #ifdef HAS_SETENV
1691         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1692 #else
1693         if (ckWARN(WARN_INTERNAL))
1694           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1695         retsts = SS$_NOSUCHPGM;
1696 #endif
1697       }
1698       else {
1699         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1700         eqvdsc.dsc$w_length  = strlen(eqv);
1701         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1702             !str$case_blind_compare(&tmpdsc,&clisym)) {
1703           unsigned int symtype;
1704           if (tabvec[0]->dsc$w_length == 12 &&
1705               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1706                !str$case_blind_compare(&tmpdsc,&local))
1707             symtype = LIB$K_CLI_LOCAL_SYM;
1708           else symtype = LIB$K_CLI_GLOBAL_SYM;
1709           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1710         }
1711         else {
1712           if (!*eqv) eqvdsc.dsc$w_length = 1;
1713           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1714
1715             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1716             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1717               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1718                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1719               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1720               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1721             }
1722
1723             Newx(ilist,nseg+1,struct itmlst_3);
1724             ile = ilist;
1725             if (!ile) {
1726               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1727               return SS$_INSFMEM;
1728             }
1729             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1730
1731             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1732               ile->itmcode = LNM$_STRING;
1733               ile->bufadr = c;
1734               if ((j+1) == nseg) {
1735                 ile->buflen = strlen(c);
1736                 /* in case we are truncating one that's too long */
1737                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1738               }
1739               else {
1740                 ile->buflen = LNM$C_NAMLENGTH;
1741               }
1742             }
1743
1744             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1745             Safefree (ilist);
1746           }
1747           else {
1748             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1749           }
1750         }
1751       }
1752     }
1753     if (!(retsts & 1)) {
1754       switch (retsts) {
1755         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1756         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1757           set_errno(EVMSERR); break;
1758         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1759         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1760           set_errno(EINVAL); break;
1761         case SS$_NOPRIV:
1762           set_errno(EACCES); break;
1763         default:
1764           _ckvmssts(retsts);
1765           set_errno(EVMSERR);
1766        }
1767        set_vaxc_errno(retsts);
1768        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1769     }
1770     else {
1771       /* We reset error values on success because Perl does an hv_fetch()
1772        * before each hv_store(), and if the thing we're setting didn't
1773        * previously exist, we've got a leftover error message.  (Of course,
1774        * this fails in the face of
1775        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1776        * in that the error reported in $! isn't spurious,
1777        * but it's right more often than not.)
1778        */
1779       set_errno(0); set_vaxc_errno(retsts);
1780       return 0;
1781     }
1782
1783 }  /* end of vmssetenv() */
1784 /*}}}*/
1785
1786 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1787 /* This has to be a function since there's a prototype for it in proto.h */
1788 void
1789 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1790 {
1791     if (lnm && *lnm) {
1792       int len = strlen(lnm);
1793       if  (len == 7) {
1794         char uplnm[8];
1795         int i;
1796         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1797         if (!strcmp(uplnm,"DEFAULT")) {
1798           if (eqv && *eqv) my_chdir(eqv);
1799           return;
1800         }
1801     }
1802 #ifndef RTL_USES_UTC
1803     if (len == 6 || len == 2) {
1804       char uplnm[7];
1805       int i;
1806       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1807       uplnm[len] = '\0';
1808       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1809       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1810     }
1811 #endif
1812   }
1813   (void) vmssetenv(lnm,eqv,NULL);
1814 }
1815 /*}}}*/
1816
1817 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1818 /*  vmssetuserlnm
1819  *  sets a user-mode logical in the process logical name table
1820  *  used for redirection of sys$error
1821  */
1822 void
1823 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1824 {
1825     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1826     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1827     unsigned long int iss, attr = LNM$M_CONFINE;
1828     unsigned char acmode = PSL$C_USER;
1829     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1830                                  {0, 0, 0, 0}};
1831     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1832     d_name.dsc$w_length = strlen(name);
1833
1834     lnmlst[0].buflen = strlen(eqv);
1835     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1836
1837     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1838     if (!(iss&1)) lib$signal(iss);
1839 }
1840 /*}}}*/
1841
1842
1843 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1844 /* my_crypt - VMS password hashing
1845  * my_crypt() provides an interface compatible with the Unix crypt()
1846  * C library function, and uses sys$hash_password() to perform VMS
1847  * password hashing.  The quadword hashed password value is returned
1848  * as a NUL-terminated 8 character string.  my_crypt() does not change
1849  * the case of its string arguments; in order to match the behavior
1850  * of LOGINOUT et al., alphabetic characters in both arguments must
1851  *  be upcased by the caller.
1852  *
1853  * - fix me to call ACM services when available
1854  */
1855 char *
1856 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1857 {
1858 #   ifndef UAI$C_PREFERRED_ALGORITHM
1859 #     define UAI$C_PREFERRED_ALGORITHM 127
1860 #   endif
1861     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1862     unsigned short int salt = 0;
1863     unsigned long int sts;
1864     struct const_dsc {
1865         unsigned short int dsc$w_length;
1866         unsigned char      dsc$b_type;
1867         unsigned char      dsc$b_class;
1868         const char *       dsc$a_pointer;
1869     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1870        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1871     struct itmlst_3 uailst[3] = {
1872         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1873         { sizeof salt, UAI$_SALT,    &salt, 0},
1874         { 0,           0,            NULL,  NULL}};
1875     static char hash[9];
1876
1877     usrdsc.dsc$w_length = strlen(usrname);
1878     usrdsc.dsc$a_pointer = usrname;
1879     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1880       switch (sts) {
1881         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1882           set_errno(EACCES);
1883           break;
1884         case RMS$_RNF:
1885           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1886           break;
1887         default:
1888           set_errno(EVMSERR);
1889       }
1890       set_vaxc_errno(sts);
1891       if (sts != RMS$_RNF) return NULL;
1892     }
1893
1894     txtdsc.dsc$w_length = strlen(textpasswd);
1895     txtdsc.dsc$a_pointer = textpasswd;
1896     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1897       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1898     }
1899
1900     return (char *) hash;
1901
1902 }  /* end of my_crypt() */
1903 /*}}}*/
1904
1905
1906 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1907 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1908 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1909
1910 /* fixup barenames that are directories for internal use.
1911  * There have been problems with the consistent handling of UNIX
1912  * style directory names when routines are presented with a name that
1913  * has no directory delimitors at all.  So this routine will eventually
1914  * fix the issue.
1915  */
1916 static char * fixup_bare_dirnames(const char * name)
1917 {
1918   if (decc_disable_to_vms_logname_translation) {
1919 /* fix me */
1920   }
1921   return NULL;
1922 }
1923
1924 /* 8.3, remove() is now broken on symbolic links */
1925 static int rms_erase(const char * vmsname);
1926
1927
1928 /* mp_do_kill_file
1929  * A little hack to get around a bug in some implemenation of remove()
1930  * that do not know how to delete a directory
1931  *
1932  * Delete any file to which user has control access, regardless of whether
1933  * delete access is explicitly allowed.
1934  * Limitations: User must have write access to parent directory.
1935  *              Does not block signals or ASTs; if interrupted in midstream
1936  *              may leave file with an altered ACL.
1937  * HANDLE WITH CARE!
1938  */
1939 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1940 static int
1941 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1942 {
1943     char *vmsname;
1944     char *rslt;
1945     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1946     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1947     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1948     struct myacedef {
1949       unsigned char myace$b_length;
1950       unsigned char myace$b_type;
1951       unsigned short int myace$w_flags;
1952       unsigned long int myace$l_access;
1953       unsigned long int myace$l_ident;
1954     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1955                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1956       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1957      struct itmlst_3
1958        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1959                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1960        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1961        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1962        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1963        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1964
1965     /* Expand the input spec using RMS, since the CRTL remove() and
1966      * system services won't do this by themselves, so we may miss
1967      * a file "hiding" behind a logical name or search list. */
1968     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1969     if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1970
1971     rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
1972     if (rslt == NULL) {
1973         PerlMem_free(vmsname);
1974         return -1;
1975       }
1976
1977     /* Erase the file */
1978     rmsts = rms_erase(vmsname);
1979
1980     /* Did it succeed */
1981     if ($VMS_STATUS_SUCCESS(rmsts)) {
1982         PerlMem_free(vmsname);
1983         return 0;
1984       }
1985
1986     /* If not, can changing protections help? */
1987     if (rmsts != RMS$_PRV) {
1988       set_vaxc_errno(rmsts);
1989       PerlMem_free(vmsname);
1990       return -1;
1991     }
1992
1993     /* No, so we get our own UIC to use as a rights identifier,
1994      * and the insert an ACE at the head of the ACL which allows us
1995      * to delete the file.
1996      */
1997     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1998     fildsc.dsc$w_length = strlen(vmsname);
1999     fildsc.dsc$a_pointer = vmsname;
2000     cxt = 0;
2001     newace.myace$l_ident = oldace.myace$l_ident;
2002     rmsts = -1;
2003     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
2004       switch (aclsts) {
2005         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
2006           set_errno(ENOENT); break;
2007         case RMS$_DIR:
2008           set_errno(ENOTDIR); break;
2009         case RMS$_DEV:
2010           set_errno(ENODEV); break;
2011         case RMS$_SYN: case SS$_INVFILFOROP:
2012           set_errno(EINVAL); break;
2013         case RMS$_PRV:
2014           set_errno(EACCES); break;
2015         default:
2016           _ckvmssts_noperl(aclsts);
2017       }
2018       set_vaxc_errno(aclsts);
2019       PerlMem_free(vmsname);
2020       return -1;
2021     }
2022     /* Grab any existing ACEs with this identifier in case we fail */
2023     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
2024     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
2025                     || fndsts == SS$_NOMOREACE ) {
2026       /* Add the new ACE . . . */
2027       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
2028         goto yourroom;
2029
2030       rmsts = rms_erase(vmsname);
2031       if ($VMS_STATUS_SUCCESS(rmsts)) {
2032         rmsts = 0;
2033         }
2034         else {
2035         rmsts = -1;
2036         /* We blew it - dir with files in it, no write priv for
2037          * parent directory, etc.  Put things back the way they were. */
2038         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
2039           goto yourroom;
2040         if (fndsts & 1) {
2041           addlst[0].bufadr = &oldace;
2042           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2043             goto yourroom;
2044         }
2045       }
2046     }
2047
2048     yourroom:
2049     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2050     /* We just deleted it, so of course it's not there.  Some versions of
2051      * VMS seem to return success on the unlock operation anyhow (after all
2052      * the unlock is successful), but others don't.
2053      */
2054     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2055     if (aclsts & 1) aclsts = fndsts;
2056     if (!(aclsts & 1)) {
2057       set_errno(EVMSERR);
2058       set_vaxc_errno(aclsts);
2059     }
2060
2061     PerlMem_free(vmsname);
2062     return rmsts;
2063
2064 }  /* end of kill_file() */
2065 /*}}}*/
2066
2067
2068 /*{{{int do_rmdir(char *name)*/
2069 int
2070 Perl_do_rmdir(pTHX_ const char *name)
2071 {
2072     char * dirfile;
2073     int retval;
2074     Stat_t st;
2075
2076     /* lstat returns a VMS fileified specification of the name */
2077     /* that is looked up, and also lets verifies that this is a directory */
2078
2079     retval = Perl_flex_lstat(NULL, name, &st);
2080     if (retval != 0) {
2081         char * ret_spec;
2082
2083         /* Due to a historical feature, flex_stat/lstat can not see some */
2084         /* Unix format file names that the rest of the CRTL can see */
2085         /* Fixing that feature will cause some perl tests to fail */
2086         /* So try this one more time. */
2087
2088         retval = lstat(name, &st.crtl_stat);
2089         if (retval != 0)
2090             return -1;
2091
2092         /* force it to a file spec for the kill file to work. */
2093         ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
2094         if (ret_spec == NULL) {
2095             errno = EIO;
2096             return -1;
2097         }
2098     }
2099
2100     if (!S_ISDIR(st.st_mode)) {
2101         errno = ENOTDIR;
2102         retval = -1;
2103     }
2104     else {
2105         dirfile = st.st_devnam;
2106
2107         /* It may be possible for flex_stat to find a file and vmsify() to */
2108         /* fail with ODS-2 specifications.  mp_do_kill_file can not deal */
2109         /* with that case, so fail it */
2110         if (dirfile[0] == 0) {
2111             errno = EIO;
2112             return -1;
2113         }
2114
2115         retval = mp_do_kill_file(aTHX_ dirfile, 1);
2116     }
2117
2118     return retval;
2119
2120 }  /* end of do_rmdir */
2121 /*}}}*/
2122
2123 /* kill_file
2124  * Delete any file to which user has control access, regardless of whether
2125  * delete access is explicitly allowed.
2126  * Limitations: User must have write access to parent directory.
2127  *              Does not block signals or ASTs; if interrupted in midstream
2128  *              may leave file with an altered ACL.
2129  * HANDLE WITH CARE!
2130  */
2131 /*{{{int kill_file(char *name)*/
2132 int
2133 Perl_kill_file(pTHX_ const char *name)
2134 {
2135     char * vmsfile;
2136     Stat_t st;
2137     int rmsts;
2138
2139     /* Convert the filename to VMS format and see if it is a directory */
2140     /* flex_lstat returns a vmsified file specification */
2141     rmsts = Perl_flex_lstat(NULL, name, &st);
2142     if (rmsts != 0) {
2143
2144         /* Due to a historical feature, flex_stat/lstat can not see some */
2145         /* Unix format file names that the rest of the CRTL can see when */
2146         /* ODS-2 file specifications are in use. */
2147         /* Fixing that feature will cause some perl tests to fail */
2148         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2149         st.st_mode = 0;
2150         vmsfile = (char *) name; /* cast ok */
2151
2152     } else {
2153         vmsfile = st.st_devnam;
2154         if (vmsfile[0] == 0) {
2155             /* It may be possible for flex_stat to find a file and vmsify() */
2156             /* to fail with ODS-2 specifications.  mp_do_kill_file can not */
2157             /* deal with that case, so fail it */
2158             errno = EIO;
2159             return -1;
2160         }
2161     }
2162
2163     /* Remove() is allowed to delete directories, according to the X/Open
2164      * specifications.
2165      * This may need special handling to work with the ACL hacks.
2166      */
2167     if (S_ISDIR(st.st_mode)) {
2168         rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
2169         return rmsts;
2170     }
2171
2172     rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2173
2174     /* Need to delete all versions ? */
2175     if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
2176         int i = 0;
2177
2178         /* Just use lstat() here as do not need st_dev */
2179         /* and we know that the file is in VMS format or that */
2180         /* because of a historical bug, flex_stat can not see the file */
2181         while (lstat(vmsfile, (stat_t *)&st) == 0) {
2182             rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2183             if (rmsts != 0)
2184                 break;
2185             i++;
2186
2187             /* Make sure that we do not loop forever */
2188             if (i > 32767) {
2189                 errno = EIO;
2190                 rmsts = -1;
2191                 break;
2192             }
2193         }
2194     }
2195
2196     return rmsts;
2197
2198 }  /* end of kill_file() */
2199 /*}}}*/
2200
2201
2202 /*{{{int my_mkdir(char *,Mode_t)*/
2203 int
2204 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2205 {
2206   STRLEN dirlen = strlen(dir);
2207
2208   /* zero length string sometimes gives ACCVIO */
2209   if (dirlen == 0) return -1;
2210
2211   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2212    * null file name/type.  However, it's commonplace under Unix,
2213    * so we'll allow it for a gain in portability.
2214    */
2215   if (dir[dirlen-1] == '/') {
2216     char *newdir = savepvn(dir,dirlen-1);
2217     int ret = mkdir(newdir,mode);
2218     Safefree(newdir);
2219     return ret;
2220   }
2221   else return mkdir(dir,mode);
2222 }  /* end of my_mkdir */
2223 /*}}}*/
2224
2225 /*{{{int my_chdir(char *)*/
2226 int
2227 Perl_my_chdir(pTHX_ const char *dir)
2228 {
2229   STRLEN dirlen = strlen(dir);
2230
2231   /* zero length string sometimes gives ACCVIO */
2232   if (dirlen == 0) return -1;
2233   const char *dir1;
2234
2235   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2236    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2237    * so that existing scripts do not need to be changed.
2238    */
2239   dir1 = dir;
2240   while ((dirlen > 0) && (*dir1 == ' ')) {
2241     dir1++;
2242     dirlen--;
2243   }
2244
2245   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2246    * that implies
2247    * null file name/type.  However, it's commonplace under Unix,
2248    * so we'll allow it for a gain in portability.
2249    *
2250    * - Preview- '/' will be valid soon on VMS
2251    */
2252   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2253     char *newdir = savepvn(dir1,dirlen-1);
2254     int ret = chdir(newdir);
2255     Safefree(newdir);
2256     return ret;
2257   }
2258   else return chdir(dir1);
2259 }  /* end of my_chdir */
2260 /*}}}*/
2261
2262
2263 /*{{{int my_chmod(char *, mode_t)*/
2264 int
2265 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2266 {
2267   STRLEN speclen = strlen(file_spec);
2268
2269   /* zero length string sometimes gives ACCVIO */
2270   if (speclen == 0) return -1;
2271
2272   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2273    * that implies null file name/type.  However, it's commonplace under Unix,
2274    * so we'll allow it for a gain in portability.
2275    *
2276    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2277    * in VMS file.dir notation.
2278    */
2279   if ((speclen > 1) && (file_spec[speclen-1] == '/')) {
2280     char *vms_src, *vms_dir, *rslt;
2281     int ret = -1;
2282     errno = EIO;
2283
2284     /* First convert this to a VMS format specification */
2285     vms_src = PerlMem_malloc(VMS_MAXRSS);
2286     if (vms_src == NULL)
2287         _ckvmssts_noperl(SS$_INSFMEM);
2288
2289     rslt = do_tovmsspec(file_spec, vms_src, 0, NULL);
2290     if (rslt == NULL) {
2291         /* If we fail, then not a file specification */
2292         PerlMem_free(vms_src);
2293         errno = EIO;
2294         return -1;
2295     }
2296
2297     /* Now make it a directory spec so chmod is happy */
2298     vms_dir = PerlMem_malloc(VMS_MAXRSS + 1);
2299     if (vms_dir == NULL)
2300         _ckvmssts_noperl(SS$_INSFMEM);
2301     rslt = do_fileify_dirspec(vms_src, vms_dir, 0, NULL);
2302     PerlMem_free(vms_src);
2303
2304     /* Now do it */
2305     if (rslt != NULL) {
2306         ret = chmod(vms_dir, mode);
2307     } else {
2308         errno = EIO;
2309     }
2310     PerlMem_free(vms_dir);
2311     return ret;
2312   }
2313   else return chmod(file_spec, mode);
2314 }  /* end of my_chmod */
2315 /*}}}*/
2316
2317
2318 /*{{{FILE *my_tmpfile()*/
2319 FILE *
2320 my_tmpfile(void)
2321 {
2322   FILE *fp;
2323   char *cp;
2324
2325   if ((fp = tmpfile())) return fp;
2326
2327   cp = PerlMem_malloc(L_tmpnam+24);
2328   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2329
2330   if (decc_filename_unix_only == 0)
2331     strcpy(cp,"Sys$Scratch:");
2332   else
2333     strcpy(cp,"/tmp/");
2334   tmpnam(cp+strlen(cp));
2335   strcat(cp,".Perltmp");
2336   fp = fopen(cp,"w+","fop=dlt");
2337   PerlMem_free(cp);
2338   return fp;
2339 }
2340 /*}}}*/
2341
2342
2343 #ifndef HOMEGROWN_POSIX_SIGNALS
2344 /*
2345  * The C RTL's sigaction fails to check for invalid signal numbers so we
2346  * help it out a bit.  The docs are correct, but the actual routine doesn't
2347  * do what the docs say it will.
2348  */
2349 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2350 int
2351 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2352                    struct sigaction* oact)
2353 {
2354   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2355         SETERRNO(EINVAL, SS$_INVARG);
2356         return -1;
2357   }
2358   return sigaction(sig, act, oact);
2359 }
2360 /*}}}*/
2361 #endif
2362
2363 #ifdef KILL_BY_SIGPRC
2364 #include <errnodef.h>
2365
2366 /* We implement our own kill() using the undocumented system service
2367    sys$sigprc for one of two reasons:
2368
2369    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2370    target process to do a sys$exit, which usually can't be handled
2371    gracefully...certainly not by Perl and the %SIG{} mechanism.
2372
2373    2.) If the kill() in the CRTL can't be called from a signal
2374    handler without disappearing into the ether, i.e., the signal
2375    it purportedly sends is never trapped. Still true as of VMS 7.3.
2376
2377    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2378    in the target process rather than calling sys$exit.
2379
2380    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2381    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2382    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2383    with condition codes C$_SIG0+nsig*8, catching the exception on the
2384    target process and resignaling with appropriate arguments.
2385
2386    But we don't have that VMS 7.0+ exception handler, so if you
2387    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2388
2389    Also note that SIGTERM is listed in the docs as being "unimplemented",
2390    yet always seems to be signaled with a VMS condition code of 4 (and
2391    correctly handled for that code).  So we hardwire it in.
2392
2393    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2394    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2395    than signalling with an unrecognized (and unhandled by CRTL) code.
2396 */
2397
2398 #define _MY_SIG_MAX 28
2399
2400 static unsigned int
2401 Perl_sig_to_vmscondition_int(int sig)
2402 {
2403     static unsigned int sig_code[_MY_SIG_MAX+1] =
2404     {
2405         0,                  /*  0 ZERO     */
2406         SS$_HANGUP,         /*  1 SIGHUP   */
2407         SS$_CONTROLC,       /*  2 SIGINT   */
2408         SS$_CONTROLY,       /*  3 SIGQUIT  */
2409         SS$_RADRMOD,        /*  4 SIGILL   */
2410         SS$_BREAK,          /*  5 SIGTRAP  */
2411         SS$_OPCCUS,         /*  6 SIGABRT  */
2412         SS$_COMPAT,         /*  7 SIGEMT   */
2413 #ifdef __VAX
2414         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2415 #else
2416         SS$_HPARITH,        /*  8 SIGFPE AXP */
2417 #endif
2418         SS$_ABORT,          /*  9 SIGKILL  */
2419         SS$_ACCVIO,         /* 10 SIGBUS   */
2420         SS$_ACCVIO,         /* 11 SIGSEGV  */
2421         SS$_BADPARAM,       /* 12 SIGSYS   */
2422         SS$_NOMBX,          /* 13 SIGPIPE  */
2423         SS$_ASTFLT,         /* 14 SIGALRM  */
2424         4,                  /* 15 SIGTERM  */
2425         0,                  /* 16 SIGUSR1  */
2426         0,                  /* 17 SIGUSR2  */
2427         0,                  /* 18 */
2428         0,                  /* 19 */
2429         0,                  /* 20 SIGCHLD  */
2430         0,                  /* 21 SIGCONT  */
2431         0,                  /* 22 SIGSTOP  */
2432         0,                  /* 23 SIGTSTP  */
2433         0,                  /* 24 SIGTTIN  */
2434         0,                  /* 25 SIGTTOU  */
2435         0,                  /* 26 */
2436         0,                  /* 27 */
2437         0                   /* 28 SIGWINCH  */
2438     };
2439
2440 #if __VMS_VER >= 60200000
2441     static int initted = 0;
2442     if (!initted) {
2443         initted = 1;
2444         sig_code[16] = C$_SIGUSR1;
2445         sig_code[17] = C$_SIGUSR2;
2446 #if __CRTL_VER >= 70000000
2447         sig_code[20] = C$_SIGCHLD;
2448 #endif
2449 #if __CRTL_VER >= 70300000
2450         sig_code[28] = C$_SIGWINCH;
2451 #endif
2452     }
2453 #endif
2454
2455     if (sig < _SIG_MIN) return 0;
2456     if (sig > _MY_SIG_MAX) return 0;
2457     return sig_code[sig];
2458 }
2459
2460 unsigned int
2461 Perl_sig_to_vmscondition(int sig)
2462 {
2463 #ifdef SS$_DEBUG
2464     if (vms_debug_on_exception != 0)
2465         lib$signal(SS$_DEBUG);
2466 #endif
2467     return Perl_sig_to_vmscondition_int(sig);
2468 }
2469
2470
2471 int
2472 Perl_my_kill(int pid, int sig)
2473 {
2474     dTHX;
2475     int iss;
2476     unsigned int code;
2477     int sys$sigprc(unsigned int *pidadr,
2478                      struct dsc$descriptor_s *prcname,
2479                      unsigned int code);
2480
2481      /* sig 0 means validate the PID */
2482     /*------------------------------*/
2483     if (sig == 0) {
2484         const unsigned long int jpicode = JPI$_PID;
2485         pid_t ret_pid;
2486         int status;
2487         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2488         if ($VMS_STATUS_SUCCESS(status))
2489            return 0;
2490         switch (status) {
2491         case SS$_NOSUCHNODE:
2492         case SS$_UNREACHABLE:
2493         case SS$_NONEXPR:
2494            errno = ESRCH;
2495            break;
2496         case SS$_NOPRIV:
2497            errno = EPERM;
2498            break;
2499         default:
2500            errno = EVMSERR;
2501         }
2502         vaxc$errno=status;
2503         return -1;
2504     }
2505
2506     code = Perl_sig_to_vmscondition_int(sig);
2507
2508     if (!code) {
2509         SETERRNO(EINVAL, SS$_BADPARAM);
2510         return -1;
2511     }
2512
2513     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2514      * signals are to be sent to multiple processes.
2515      *  pid = 0 - all processes in group except ones that the system exempts
2516      *  pid = -1 - all processes except ones that the system exempts
2517      *  pid = -n - all processes in group (abs(n)) except ...
2518      * For now, just report as not supported.
2519      */
2520
2521     if (pid <= 0) {
2522         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2523         return -1;
2524     }
2525
2526     iss = sys$sigprc((unsigned int *)&pid,0,code);
2527     if (iss&1) return 0;
2528
2529     switch (iss) {
2530       case SS$_NOPRIV:
2531         set_errno(EPERM);  break;
2532       case SS$_NONEXPR:
2533       case SS$_NOSUCHNODE:
2534       case SS$_UNREACHABLE:
2535         set_errno(ESRCH);  break;
2536       case SS$_INSFMEM:
2537         set_errno(ENOMEM); break;
2538       default:
2539         _ckvmssts_noperl(iss);
2540         set_errno(EVMSERR);
2541     }
2542     set_vaxc_errno(iss);
2543
2544     return -1;
2545 }
2546 #endif
2547
2548 /* Routine to convert a VMS status code to a UNIX status code.
2549 ** More tricky than it appears because of conflicting conventions with
2550 ** existing code.
2551 **
2552 ** VMS status codes are a bit mask, with the least significant bit set for
2553 ** success.
2554 **
2555 ** Special UNIX status of EVMSERR indicates that no translation is currently
2556 ** available, and programs should check the VMS status code.
2557 **
2558 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2559 ** decoding.
2560 */
2561
2562 #ifndef C_FACILITY_NO
2563 #define C_FACILITY_NO 0x350000
2564 #endif
2565 #ifndef DCL_IVVERB
2566 #define DCL_IVVERB 0x38090
2567 #endif
2568
2569 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2570 {
2571 int facility;
2572 int fac_sp;
2573 int msg_no;
2574 int msg_status;
2575 int unix_status;
2576
2577   /* Assume the best or the worst */
2578   if (vms_status & STS$M_SUCCESS)
2579     unix_status = 0;
2580   else
2581     unix_status = EVMSERR;
2582
2583   msg_status = vms_status & ~STS$M_CONTROL;
2584
2585   facility = vms_status & STS$M_FAC_NO;
2586   fac_sp = vms_status & STS$M_FAC_SP;
2587   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2588
2589   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2590     switch(msg_no) {
2591     case SS$_NORMAL:
2592         unix_status = 0;
2593         break;
2594     case SS$_ACCVIO:
2595         unix_status = EFAULT;
2596         break;
2597     case SS$_DEVOFFLINE:
2598         unix_status = EBUSY;
2599         break;
2600     case SS$_CLEARED:
2601         unix_status = ENOTCONN;
2602         break;
2603     case SS$_IVCHAN:
2604     case SS$_IVLOGNAM:
2605     case SS$_BADPARAM:
2606     case SS$_IVLOGTAB:
2607     case SS$_NOLOGNAM:
2608     case SS$_NOLOGTAB:
2609     case SS$_INVFILFOROP:
2610     case SS$_INVARG:
2611     case SS$_NOSUCHID:
2612     case SS$_IVIDENT:
2613         unix_status = EINVAL;
2614         break;
2615     case SS$_UNSUPPORTED:
2616         unix_status = ENOTSUP;
2617         break;
2618     case SS$_FILACCERR:
2619     case SS$_NOGRPPRV:
2620     case SS$_NOSYSPRV:
2621         unix_status = EACCES;
2622         break;
2623     case SS$_DEVICEFULL:
2624         unix_status = ENOSPC;
2625         break;
2626     case SS$_NOSUCHDEV:
2627         unix_status = ENODEV;
2628         break;
2629     case SS$_NOSUCHFILE:
2630     case SS$_NOSUCHOBJECT:
2631         unix_status = ENOENT;
2632         break;
2633     case SS$_ABORT:                                 /* Fatal case */
2634     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2635     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2636         unix_status = EINTR;
2637         break;
2638     case SS$_BUFFEROVF:
2639         unix_status = E2BIG;
2640         break;
2641     case SS$_INSFMEM:
2642         unix_status = ENOMEM;
2643         break;
2644     case SS$_NOPRIV:
2645         unix_status = EPERM;
2646         break;
2647     case SS$_NOSUCHNODE:
2648     case SS$_UNREACHABLE:
2649         unix_status = ESRCH;
2650         break;
2651     case SS$_NONEXPR:
2652         unix_status = ECHILD;
2653         break;
2654     default:
2655         if ((facility == 0) && (msg_no < 8)) {
2656           /* These are not real VMS status codes so assume that they are
2657           ** already UNIX status codes
2658           */
2659           unix_status = msg_no;
2660           break;
2661         }
2662     }
2663   }
2664   else {
2665     /* Translate a POSIX exit code to a UNIX exit code */
2666     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2667         unix_status = (msg_no & 0x07F8) >> 3;
2668     }
2669     else {
2670
2671          /* Documented traditional behavior for handling VMS child exits */
2672         /*--------------------------------------------------------------*/
2673         if (child_flag != 0) {
2674
2675              /* Success / Informational return 0 */
2676             /*----------------------------------*/
2677             if (msg_no & STS$K_SUCCESS)
2678                 return 0;
2679
2680              /* Warning returns 1 */
2681             /*-------------------*/
2682             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2683                 return 1;
2684
2685              /* Everything else pass through the severity bits */
2686             /*------------------------------------------------*/
2687             return (msg_no & STS$M_SEVERITY);
2688         }
2689
2690          /* Normal VMS status to ERRNO mapping attempt */
2691         /*--------------------------------------------*/
2692         switch(msg_status) {
2693         /* case RMS$_EOF: */ /* End of File */
2694         case RMS$_FNF:  /* File Not Found */
2695         case RMS$_DNF:  /* Dir Not Found */
2696                 unix_status = ENOENT;
2697                 break;
2698         case RMS$_RNF:  /* Record Not Found */
2699                 unix_status = ESRCH;
2700                 break;
2701         case RMS$_DIR:
2702                 unix_status = ENOTDIR;
2703                 break;
2704         case RMS$_DEV:
2705                 unix_status = ENODEV;
2706                 break;
2707         case RMS$_IFI:
2708         case RMS$_FAC:
2709         case RMS$_ISI:
2710                 unix_status = EBADF;
2711                 break;
2712         case RMS$_FEX:
2713                 unix_status = EEXIST;
2714                 break;
2715         case RMS$_SYN:
2716         case RMS$_FNM:
2717         case LIB$_INVSTRDES:
2718         case LIB$_INVARG:
2719         case LIB$_NOSUCHSYM:
2720         case LIB$_INVSYMNAM:
2721         case DCL_IVVERB:
2722                 unix_status = EINVAL;
2723                 break;
2724         case CLI$_BUFOVF:
2725         case RMS$_RTB:
2726         case CLI$_TKNOVF:
2727         case CLI$_RSLOVF:
2728                 unix_status = E2BIG;
2729                 break;
2730         case RMS$_PRV:  /* No privilege */
2731         case RMS$_ACC:  /* ACP file access failed */
2732         case RMS$_WLK:  /* Device write locked */
2733                 unix_status = EACCES;
2734                 break;
2735         case RMS$_MKD:  /* Failed to mark for delete */
2736                 unix_status = EPERM;
2737                 break;
2738         /* case RMS$_NMF: */  /* No more files */
2739         }
2740     }
2741   }
2742
2743   return unix_status;
2744 }
2745
2746 /* Try to guess at what VMS error status should go with a UNIX errno
2747  * value.  This is hard to do as there could be many possible VMS
2748  * error statuses that caused the errno value to be set.
2749  */
2750
2751 int Perl_unix_status_to_vms(int unix_status)
2752 {
2753 int test_unix_status;
2754
2755      /* Trivial cases first */
2756     /*---------------------*/
2757     if (unix_status == EVMSERR)
2758         return vaxc$errno;
2759
2760      /* Is vaxc$errno sane? */
2761     /*---------------------*/
2762     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2763     if (test_unix_status == unix_status)
2764         return vaxc$errno;
2765
2766      /* If way out of range, must be VMS code already */
2767     /*-----------------------------------------------*/
2768     if (unix_status > EVMSERR)
2769         return unix_status;
2770
2771      /* If out of range, punt */
2772     /*-----------------------*/
2773     if (unix_status > __ERRNO_MAX)
2774         return SS$_ABORT;
2775
2776
2777      /* Ok, now we have to do it the hard way. */
2778     /*----------------------------------------*/
2779     switch(unix_status) {
2780     case 0:     return SS$_NORMAL;
2781     case EPERM: return SS$_NOPRIV;
2782     case ENOENT: return SS$_NOSUCHOBJECT;
2783     case ESRCH: return SS$_UNREACHABLE;
2784     case EINTR: return SS$_ABORT;
2785     /* case EIO: */
2786     /* case ENXIO:  */
2787     case E2BIG: return SS$_BUFFEROVF;
2788     /* case ENOEXEC */
2789     case EBADF: return RMS$_IFI;
2790     case ECHILD: return SS$_NONEXPR;
2791     /* case EAGAIN */
2792     case ENOMEM: return SS$_INSFMEM;
2793     case EACCES: return SS$_FILACCERR;
2794     case EFAULT: return SS$_ACCVIO;
2795     /* case ENOTBLK */
2796     case EBUSY: return SS$_DEVOFFLINE;
2797     case EEXIST: return RMS$_FEX;
2798     /* case EXDEV */
2799     case ENODEV: return SS$_NOSUCHDEV;
2800     case ENOTDIR: return RMS$_DIR;
2801     /* case EISDIR */
2802     case EINVAL: return SS$_INVARG;
2803     /* case ENFILE */
2804     /* case EMFILE */
2805     /* case ENOTTY */
2806     /* case ETXTBSY */
2807     /* case EFBIG */
2808     case ENOSPC: return SS$_DEVICEFULL;
2809     case ESPIPE: return LIB$_INVARG;
2810     /* case EROFS: */
2811     /* case EMLINK: */
2812     /* case EPIPE: */
2813     /* case EDOM */
2814     case ERANGE: return LIB$_INVARG;
2815     /* case EWOULDBLOCK */
2816     /* case EINPROGRESS */
2817     /* case EALREADY */
2818     /* case ENOTSOCK */
2819     /* case EDESTADDRREQ */
2820     /* case EMSGSIZE */
2821     /* case EPROTOTYPE */
2822     /* case ENOPROTOOPT */
2823     /* case EPROTONOSUPPORT */
2824     /* case ESOCKTNOSUPPORT */
2825     /* case EOPNOTSUPP */
2826     /* case EPFNOSUPPORT */
2827     /* case EAFNOSUPPORT */
2828     /* case EADDRINUSE */
2829     /* case EADDRNOTAVAIL */
2830     /* case ENETDOWN */
2831     /* case ENETUNREACH */
2832     /* case ENETRESET */
2833     /* case ECONNABORTED */
2834     /* case ECONNRESET */
2835     /* case ENOBUFS */
2836     /* case EISCONN */
2837     case ENOTCONN: return SS$_CLEARED;
2838     /* case ESHUTDOWN */
2839     /* case ETOOMANYREFS */
2840     /* case ETIMEDOUT */
2841     /* case ECONNREFUSED */
2842     /* case ELOOP */
2843     /* case ENAMETOOLONG */
2844     /* case EHOSTDOWN */
2845     /* case EHOSTUNREACH */
2846     /* case ENOTEMPTY */
2847     /* case EPROCLIM */
2848     /* case EUSERS  */
2849     /* case EDQUOT  */
2850     /* case ENOMSG  */
2851     /* case EIDRM */
2852     /* case EALIGN */
2853     /* case ESTALE */
2854     /* case EREMOTE */
2855     /* case ENOLCK */
2856     /* case ENOSYS */
2857     /* case EFTYPE */
2858     /* case ECANCELED */
2859     /* case EFAIL */
2860     /* case EINPROG */
2861     case ENOTSUP:
2862         return SS$_UNSUPPORTED;
2863     /* case EDEADLK */
2864     /* case ENWAIT */
2865     /* case EILSEQ */
2866     /* case EBADCAT */
2867     /* case EBADMSG */
2868     /* case EABANDONED */
2869     default:
2870         return SS$_ABORT; /* punt */
2871     }
2872
2873   return SS$_ABORT; /* Should not get here */
2874 }
2875
2876
2877 /* default piping mailbox size */
2878 #define PERL_BUFSIZ        512
2879
2880
2881 static void
2882 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2883 {
2884   unsigned long int mbxbufsiz;
2885   static unsigned long int syssize = 0;
2886   unsigned long int dviitm = DVI$_DEVNAM;
2887   char csize[LNM$C_NAMLENGTH+1];
2888   int sts;
2889
2890   if (!syssize) {
2891     unsigned long syiitm = SYI$_MAXBUF;
2892     /*
2893      * Get the SYSGEN parameter MAXBUF
2894      *
2895      * If the logical 'PERL_MBX_SIZE' is defined
2896      * use the value of the logical instead of PERL_BUFSIZ, but
2897      * keep the size between 128 and MAXBUF.
2898      *
2899      */
2900     _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2901   }
2902
2903   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2904       mbxbufsiz = atoi(csize);
2905   } else {
2906       mbxbufsiz = PERL_BUFSIZ;
2907   }
2908   if (mbxbufsiz < 128) mbxbufsiz = 128;
2909   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2910
2911   _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2912
2913   sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2914   _ckvmssts_noperl(sts);
2915   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2916
2917 }  /* end of create_mbx() */
2918
2919
2920 /*{{{  my_popen and my_pclose*/
2921
2922 typedef struct _iosb           IOSB;
2923 typedef struct _iosb*         pIOSB;
2924 typedef struct _pipe           Pipe;
2925 typedef struct _pipe*         pPipe;
2926 typedef struct pipe_details    Info;
2927 typedef struct pipe_details*  pInfo;
2928 typedef struct _srqp            RQE;
2929 typedef struct _srqp*          pRQE;
2930 typedef struct _tochildbuf      CBuf;
2931 typedef struct _tochildbuf*    pCBuf;
2932
2933 struct _iosb {
2934     unsigned short status;
2935     unsigned short count;
2936     unsigned long  dvispec;
2937 };
2938
2939 #pragma member_alignment save
2940 #pragma nomember_alignment quadword
2941 struct _srqp {          /* VMS self-relative queue entry */
2942     unsigned long qptr[2];
2943 };
2944 #pragma member_alignment restore
2945 static RQE  RQE_ZERO = {0,0};
2946
2947 struct _tochildbuf {
2948     RQE             q;
2949     int             eof;
2950     unsigned short  size;
2951     char            *buf;
2952 };
2953
2954 struct _pipe {
2955     RQE            free;
2956     RQE            wait;
2957     int            fd_out;
2958     unsigned short chan_in;
2959     unsigned short chan_out;
2960     char          *buf;
2961     unsigned int   bufsize;
2962     IOSB           iosb;
2963     IOSB           iosb2;
2964     int           *pipe_done;
2965     int            retry;
2966     int            type;
2967     int            shut_on_empty;
2968     int            need_wake;
2969     pPipe         *home;
2970     pInfo          info;
2971     pCBuf          curr;
2972     pCBuf          curr2;
2973 #if defined(PERL_IMPLICIT_CONTEXT)
2974     void            *thx;           /* Either a thread or an interpreter */
2975                                     /* pointer, depending on how we're built */
2976 #endif
2977 };
2978
2979
2980 struct pipe_details
2981 {
2982     pInfo           next;
2983     PerlIO *fp;  /* file pointer to pipe mailbox */
2984     int useFILE; /* using stdio, not perlio */
2985     int pid;   /* PID of subprocess */
2986     int mode;  /* == 'r' if pipe open for reading */
2987     int done;  /* subprocess has completed */
2988     int waiting; /* waiting for completion/closure */
2989     int             closing;        /* my_pclose is closing this pipe */
2990     unsigned long   completion;     /* termination status of subprocess */
2991     pPipe           in;             /* pipe in to sub */
2992     pPipe           out;            /* pipe out of sub */
2993     pPipe           err;            /* pipe of sub's sys$error */
2994     int             in_done;        /* true when in pipe finished */
2995     int             out_done;
2996     int             err_done;
2997     unsigned short  xchan;          /* channel to debug xterm */
2998     unsigned short  xchan_valid;    /* channel is assigned */
2999 };
3000
3001 struct exit_control_block
3002 {
3003     struct exit_control_block *flink;
3004     unsigned long int   (*exit_routine)();
3005     unsigned long int arg_count;
3006     unsigned long int *status_address;
3007     unsigned long int exit_status;
3008 };
3009
3010 typedef struct _closed_pipes    Xpipe;
3011 typedef struct _closed_pipes*  pXpipe;
3012
3013 struct _closed_pipes {
3014     int             pid;            /* PID of subprocess */
3015     unsigned long   completion;     /* termination status of subprocess */
3016 };
3017 #define NKEEPCLOSED 50
3018 static Xpipe closed_list[NKEEPCLOSED];
3019 static int   closed_index = 0;
3020 static int   closed_num = 0;
3021
3022 #define RETRY_DELAY     "0 ::0.20"
3023 #define MAX_RETRY              50
3024
3025 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
3026 static unsigned long mypid;
3027 static unsigned long delaytime[2];
3028
3029 static pInfo open_pipes = NULL;
3030 static $DESCRIPTOR(nl_desc, "NL:");
3031
3032 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
3033
3034
3035
3036 static unsigned long int
3037 pipe_exit_routine()
3038 {
3039     pInfo info;
3040     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
3041     int sts, did_stuff, need_eof, j;
3042
3043    /*
3044     * Flush any pending i/o, but since we are in process run-down, be
3045     * careful about referencing PerlIO structures that may already have
3046     * been deallocated.  We may not even have an interpreter anymore.
3047     */
3048     info = open_pipes;
3049     while (info) {
3050         if (info->fp) {
3051 #if defined(PERL_IMPLICIT_CONTEXT)
3052            /* We need to use the Perl context of the thread that created */
3053            /* the pipe. */
3054            pTHX;
3055            if (info->err)
3056                aTHX = info->err->thx;
3057            else if (info->out)
3058                aTHX = info->out->thx;
3059            else if (info->in)
3060                aTHX = info->in->thx;
3061 #endif
3062            if (!info->useFILE
3063 #if defined(USE_ITHREADS)
3064              && my_perl
3065 #endif
3066              && PL_perlio_fd_refcnt)
3067                PerlIO_flush(info->fp);
3068            else
3069                fflush((FILE *)info->fp);
3070         }
3071         info = info->next;
3072     }
3073
3074     /*
3075      next we try sending an EOF...ignore if doesn't work, make sure we
3076      don't hang
3077     */
3078     did_stuff = 0;
3079     info = open_pipes;
3080
3081     while (info) {
3082       int need_eof;
3083       _ckvmssts_noperl(sys$setast(0));
3084       if (info->in && !info->in->shut_on_empty) {
3085         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3086                                  0, 0, 0, 0, 0, 0));
3087         info->waiting = 1;
3088         did_stuff = 1;
3089       }
3090       _ckvmssts_noperl(sys$setast(1));
3091       info = info->next;
3092     }
3093
3094     /* wait for EOF to have effect, up to ~ 30 sec [default] */
3095
3096     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3097         int nwait = 0;
3098
3099         info = open_pipes;
3100         while (info) {
3101           _ckvmssts_noperl(sys$setast(0));
3102           if (info->waiting && info->done)
3103                 info->waiting = 0;
3104           nwait += info->waiting;
3105           _ckvmssts_noperl(sys$setast(1));
3106           info = info->next;
3107         }
3108         if (!nwait) break;
3109         sleep(1);
3110     }
3111
3112     did_stuff = 0;
3113     info = open_pipes;
3114     while (info) {
3115       _ckvmssts_noperl(sys$setast(0));
3116       if (!info->done) { /* Tap them gently on the shoulder . . .*/
3117         sts = sys$forcex(&info->pid,0,&abort);
3118         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3119         did_stuff = 1;
3120       }
3121       _ckvmssts_noperl(sys$setast(1));
3122       info = info->next;
3123     }
3124
3125     /* again, wait for effect */
3126
3127     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3128         int nwait = 0;
3129
3130         info = open_pipes;
3131         while (info) {
3132           _ckvmssts_noperl(sys$setast(0));
3133           if (info->waiting && info->done)
3134                 info->waiting = 0;
3135           nwait += info->waiting;
3136           _ckvmssts_noperl(sys$setast(1));
3137           info = info->next;
3138         }
3139         if (!nwait) break;
3140         sleep(1);
3141     }
3142
3143     info = open_pipes;
3144     while (info) {
3145       _ckvmssts_noperl(sys$setast(0));
3146       if (!info->done) {  /* We tried to be nice . . . */
3147         sts = sys$delprc(&info->pid,0);
3148         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3149         info->done = 1;  /* sys$delprc is as done as we're going to get. */
3150       }
3151       _ckvmssts_noperl(sys$setast(1));
3152       info = info->next;
3153     }
3154
3155     while(open_pipes) {
3156
3157 #if defined(PERL_IMPLICIT_CONTEXT)
3158       /* We need to use the Perl context of the thread that created */
3159       /* the pipe. */
3160       pTHX;
3161       if (open_pipes->err)
3162           aTHX = open_pipes->err->thx;
3163       else if (open_pipes->out)
3164           aTHX = open_pipes->out->thx;
3165       else if (open_pipes->in)
3166           aTHX = open_pipes->in->thx;
3167 #endif
3168       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3169       else if (!(sts & 1)) retsts = sts;
3170     }
3171     return retsts;
3172 }
3173
3174 static struct exit_control_block pipe_exitblock =
3175        {(struct exit_control_block *) 0,
3176         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3177
3178 static void pipe_mbxtofd_ast(pPipe p);
3179 static void pipe_tochild1_ast(pPipe p);
3180 static void pipe_tochild2_ast(pPipe p);
3181
3182 static void
3183 popen_completion_ast(pInfo info)
3184 {
3185   pInfo i = open_pipes;
3186   int iss;
3187   int sts;
3188   pXpipe x;
3189
3190   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3191   closed_list[closed_index].pid = info->pid;
3192   closed_list[closed_index].completion = info->completion;
3193   closed_index++;
3194   if (closed_index == NKEEPCLOSED)
3195     closed_index = 0;
3196   closed_num++;
3197
3198   while (i) {
3199     if (i == info) break;
3200     i = i->next;
3201   }
3202   if (!i) return;       /* unlinked, probably freed too */
3203
3204   info->done = TRUE;
3205
3206 /*
3207     Writing to subprocess ...
3208             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3209
3210             chan_out may be waiting for "done" flag, or hung waiting
3211             for i/o completion to child...cancel the i/o.  This will
3212             put it into "snarf mode" (done but no EOF yet) that discards
3213             input.
3214
3215     Output from subprocess (stdout, stderr) needs to be flushed and
3216     shut down.   We try sending an EOF, but if the mbx is full the pipe
3217     routine should still catch the "shut_on_empty" flag, telling it to
3218     use immediate-style reads so that "mbx empty" -> EOF.
3219
3220
3221 */
3222   if (info->in && !info->in_done) {               /* only for mode=w */
3223         if (info->in->shut_on_empty && info->in->need_wake) {
3224             info->in->need_wake = FALSE;
3225             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3226         } else {
3227             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3228         }
3229   }
3230
3231   if (info->out && !info->out_done) {             /* were we also piping output? */
3232       info->out->shut_on_empty = TRUE;
3233       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3234       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3235       _ckvmssts_noperl(iss);
3236   }
3237
3238   if (info->err && !info->err_done) {        /* we were piping stderr */
3239         info->err->shut_on_empty = TRUE;
3240         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3241         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3242         _ckvmssts_noperl(iss);
3243   }
3244   _ckvmssts_noperl(sys$setef(pipe_ef));
3245
3246 }
3247
3248 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3249 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3250
3251 /*
3252     we actually differ from vmstrnenv since we use this to
3253     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3254     are pointing to the same thing
3255 */
3256
3257 static unsigned short
3258 popen_translate(pTHX_ char *logical, char *result)
3259 {
3260     int iss;
3261     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3262     $DESCRIPTOR(d_log,"");
3263     struct _il3 {
3264         unsigned short length;
3265         unsigned short code;
3266         char *         buffer_addr;
3267         unsigned short *retlenaddr;
3268     } itmlst[2];
3269     unsigned short l, ifi;
3270
3271     d_log.dsc$a_pointer = logical;
3272     d_log.dsc$w_length  = strlen(logical);
3273
3274     itmlst[0].code = LNM$_STRING;
3275     itmlst[0].length = 255;
3276     itmlst[0].buffer_addr = result;
3277     itmlst[0].retlenaddr = &l;
3278
3279     itmlst[1].code = 0;
3280     itmlst[1].length = 0;
3281     itmlst[1].buffer_addr = 0;
3282     itmlst[1].retlenaddr = 0;
3283
3284     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3285     if (iss == SS$_NOLOGNAM) {
3286         iss = SS$_NORMAL;
3287         l = 0;
3288     }
3289     if (!(iss&1)) lib$signal(iss);
3290     result[l] = '\0';
3291 /*
3292     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
3293     strip it off and return the ifi, if any
3294 */
3295     ifi  = 0;
3296     if (result[0] == 0x1b && result[1] == 0x00) {
3297         memmove(&ifi,result+2,2);
3298         strcpy(result,result+4);
3299     }
3300     return ifi;     /* this is the RMS internal file id */
3301 }
3302
3303 static void pipe_infromchild_ast(pPipe p);
3304
3305 /*
3306     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3307     inside an AST routine without worrying about reentrancy and which Perl
3308     memory allocator is being used.
3309
3310     We read data and queue up the buffers, then spit them out one at a
3311     time to the output mailbox when the output mailbox is ready for one.
3312
3313 */
3314 #define INITIAL_TOCHILDQUEUE  2
3315
3316 static pPipe
3317 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3318 {
3319     pPipe p;
3320     pCBuf b;
3321     char mbx1[64], mbx2[64];
3322     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3323                                       DSC$K_CLASS_S, mbx1},
3324                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3325                                       DSC$K_CLASS_S, mbx2};
3326     unsigned int dviitm = DVI$_DEVBUFSIZ;
3327     int j, n;
3328
3329     n = sizeof(Pipe);
3330     _ckvmssts_noperl(lib$get_vm(&n, &p));
3331
3332     create_mbx(&p->chan_in , &d_mbx1);
3333     create_mbx(&p->chan_out, &d_mbx2);
3334     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3335
3336     p->buf           = 0;
3337     p->shut_on_empty = FALSE;
3338     p->need_wake     = FALSE;
3339     p->type          = 0;
3340     p->retry         = 0;
3341     p->iosb.status   = SS$_NORMAL;
3342     p->iosb2.status  = SS$_NORMAL;
3343     p->free          = RQE_ZERO;
3344     p->wait          = RQE_ZERO;
3345     p->curr          = 0;
3346     p->curr2         = 0;
3347     p->info          = 0;
3348 #ifdef PERL_IMPLICIT_CONTEXT
3349     p->thx           = aTHX;
3350 #endif
3351
3352     n = sizeof(CBuf) + p->bufsize;
3353
3354     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3355         _ckvmssts_noperl(lib$get_vm(&n, &b));
3356         b->buf = (char *) b + sizeof(CBuf);
3357         _ckvmssts_noperl(lib$insqhi(b, &p->free));
3358     }
3359
3360     pipe_tochild2_ast(p);
3361     pipe_tochild1_ast(p);
3362     strcpy(wmbx, mbx1);
3363     strcpy(rmbx, mbx2);
3364     return p;
3365 }
3366
3367 /*  reads the MBX Perl is writing, and queues */
3368
3369 static void
3370 pipe_tochild1_ast(pPipe p)
3371 {
3372     pCBuf b = p->curr;
3373     int iss = p->iosb.status;
3374     int eof = (iss == SS$_ENDOFFILE);
3375     int sts;
3376 #ifdef PERL_IMPLICIT_CONTEXT
3377     pTHX = p->thx;
3378 #endif
3379
3380     if (p->retry) {
3381         if (eof) {
3382             p->shut_on_empty = TRUE;
3383             b->eof     = TRUE;
3384             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3385         } else  {
3386             _ckvmssts_noperl(iss);
3387         }
3388
3389         b->eof  = eof;
3390         b->size = p->iosb.count;
3391         _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3392         if (p->need_wake) {
3393             p->need_wake = FALSE;
3394             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3395         }
3396     } else {
3397         p->retry = 1;   /* initial call */
3398     }
3399
3400     if (eof) {                  /* flush the free queue, return when done */
3401         int n = sizeof(CBuf) + p->bufsize;
3402         while (1) {
3403             iss = lib$remqti(&p->free, &b);
3404             if (iss == LIB$_QUEWASEMP) return;
3405             _ckvmssts_noperl(iss);
3406             _ckvmssts_noperl(lib$free_vm(&n, &b));
3407         }
3408     }
3409
3410     iss = lib$remqti(&p->free, &b);
3411     if (iss == LIB$_QUEWASEMP) {
3412         int n = sizeof(CBuf) + p->bufsize;
3413         _ckvmssts_noperl(lib$get_vm(&n, &b));
3414         b->buf = (char *) b + sizeof(CBuf);
3415     } else {
3416        _ckvmssts_noperl(iss);
3417     }
3418
3419     p->curr = b;
3420     iss = sys$qio(0,p->chan_in,
3421              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3422              &p->iosb,
3423              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3424     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3425     _ckvmssts_noperl(iss);
3426 }
3427
3428
3429 /* writes queued buffers to output, waits for each to complete before
3430    doing the next */
3431
3432 static void
3433 pipe_tochild2_ast(pPipe p)
3434 {
3435     pCBuf b = p->curr2;
3436     int iss = p->iosb2.status;
3437     int n = sizeof(CBuf) + p->bufsize;
3438     int done = (p->info && p->info->done) ||
3439               iss == SS$_CANCEL || iss == SS$_ABORT;
3440 #if defined(PERL_IMPLICIT_CONTEXT)
3441     pTHX = p->thx;
3442 #endif
3443
3444     do {
3445         if (p->type) {         /* type=1 has old buffer, dispose */
3446             if (p->shut_on_empty) {
3447                 _ckvmssts_noperl(lib$free_vm(&n, &b));
3448             } else {
3449                 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3450             }
3451             p->type = 0;
3452         }
3453
3454         iss = lib$remqti(&p->wait, &b);
3455         if (iss == LIB$_QUEWASEMP) {
3456             if (p->shut_on_empty) {
3457                 if (done) {
3458                     _ckvmssts_noperl(sys$dassgn(p->chan_out));
3459                     *p->pipe_done = TRUE;
3460                     _ckvmssts_noperl(sys$setef(pipe_ef));
3461                 } else {
3462                     _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3463                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3464                 }
3465                 return;
3466             }
3467             p->need_wake = TRUE;
3468             return;
3469         }
3470         _ckvmssts_noperl(iss);
3471         p->type = 1;
3472     } while (done);
3473
3474
3475     p->curr2 = b;
3476     if (b->eof) {
3477         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3478             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3479     } else {
3480         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3481             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3482     }
3483
3484     return;
3485
3486 }
3487
3488
3489 static pPipe
3490 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3491 {
3492     pPipe p;
3493     char mbx1[64], mbx2[64];
3494     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3495                                       DSC$K_CLASS_S, mbx1},
3496                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3497                                       DSC$K_CLASS_S, mbx2};
3498     unsigned int dviitm = DVI$_DEVBUFSIZ;
3499
3500     int n = sizeof(Pipe);
3501     _ckvmssts_noperl(lib$get_vm(&n, &p));
3502     create_mbx(&p->chan_in , &d_mbx1);
3503     create_mbx(&p->chan_out, &d_mbx2);
3504
3505     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3506     n = p->bufsize * sizeof(char);
3507     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3508     p->shut_on_empty = FALSE;
3509     p->info   = 0;
3510     p->type   = 0;
3511     p->iosb.status = SS$_NORMAL;
3512 #if defined(PERL_IMPLICIT_CONTEXT)
3513     p->thx = aTHX;
3514 #endif
3515     pipe_infromchild_ast(p);
3516
3517     strcpy(wmbx, mbx1);
3518     strcpy(rmbx, mbx2);
3519     return p;
3520 }
3521
3522 static void
3523 pipe_infromchild_ast(pPipe p)
3524 {
3525     int iss = p->iosb.status;
3526     int eof = (iss == SS$_ENDOFFILE);
3527     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3528     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3529 #if defined(PERL_IMPLICIT_CONTEXT)
3530     pTHX = p->thx;
3531 #endif
3532
3533     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3534         _ckvmssts_noperl(sys$dassgn(p->chan_out));
3535         p->chan_out = 0;
3536     }
3537
3538     /* read completed:
3539             input shutdown if EOF from self (done or shut_on_empty)
3540             output shutdown if closing flag set (my_pclose)
3541             send data/eof from child or eof from self
3542             otherwise, re-read (snarf of data from child)
3543     */
3544
3545     if (p->type == 1) {
3546         p->type = 0;
3547         if (myeof && p->chan_in) {                  /* input shutdown */
3548             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3549             p->chan_in = 0;
3550         }
3551
3552         if (p->chan_out) {
3553             if (myeof || kideof) {      /* pass EOF to parent */
3554                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3555                                          pipe_infromchild_ast, p,
3556                                          0, 0, 0, 0, 0, 0));
3557                 return;
3558             } else if (eof) {       /* eat EOF --- fall through to read*/
3559
3560             } else {                /* transmit data */
3561                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3562                                          pipe_infromchild_ast,p,
3563                                          p->buf, p->iosb.count, 0, 0, 0, 0));
3564                 return;
3565             }
3566         }
3567     }
3568
3569     /*  everything shut? flag as done */
3570
3571     if (!p->chan_in && !p->chan_out) {
3572         *p->pipe_done = TRUE;
3573         _ckvmssts_noperl(sys$setef(pipe_ef));
3574         return;
3575     }
3576
3577     /* write completed (or read, if snarfing from child)
3578             if still have input active,
3579                queue read...immediate mode if shut_on_empty so we get EOF if empty
3580             otherwise,
3581                check if Perl reading, generate EOFs as needed
3582     */
3583
3584     if (p->type == 0) {
3585         p->type = 1;
3586         if (p->chan_in) {
3587             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3588                           pipe_infromchild_ast,p,
3589                           p->buf, p->bufsize, 0, 0, 0, 0);
3590             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3591             _ckvmssts_noperl(iss);
3592         } else {           /* send EOFs for extra reads */
3593             p->iosb.status = SS$_ENDOFFILE;
3594             p->iosb.dvispec = 0;
3595             _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3596                                      0, 0, 0,
3597                                      pipe_infromchild_ast, p, 0, 0, 0, 0));
3598         }
3599     }
3600 }
3601
3602 static pPipe
3603 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3604 {
3605     pPipe p;
3606     char mbx[64];
3607     unsigned long dviitm = DVI$_DEVBUFSIZ;
3608     struct stat s;
3609     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3610                                       DSC$K_CLASS_S, mbx};
3611     int n = sizeof(Pipe);
3612
3613     /* things like terminals and mbx's don't need this filter */
3614     if (fd && fstat(fd,&s) == 0) {
3615         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3616         char device[65];
3617         unsigned short dev_len;
3618         struct dsc$descriptor_s d_dev;
3619         char * cptr;
3620         struct item_list_3 items[3];
3621         int status;
3622         unsigned short dvi_iosb[4];
3623
3624         cptr = getname(fd, out, 1);
3625         if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3626         d_dev.dsc$a_pointer = out;
3627         d_dev.dsc$w_length = strlen(out);
3628         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3629         d_dev.dsc$b_class = DSC$K_CLASS_S;
3630
3631         items[0].len = 4;
3632         items[0].code = DVI$_DEVCHAR;
3633         items[0].bufadr = &devchar;
3634         items[0].retadr = NULL;
3635         items[1].len = 64;
3636         items[1].code = DVI$_FULLDEVNAM;
3637         items[1].bufadr = device;
3638         items[1].retadr = &dev_len;
3639         items[2].len = 0;
3640         items[2].code = 0;
3641
3642         status = sys$getdviw
3643                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3644         _ckvmssts_noperl(status);
3645         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3646             device[dev_len] = 0;
3647
3648             if (!(devchar & DEV$M_DIR)) {
3649                 strcpy(out, device);
3650                 return 0;
3651             }
3652         }
3653     }
3654
3655     _ckvmssts_noperl(lib$get_vm(&n, &p));
3656     p->fd_out = dup(fd);
3657     create_mbx(&p->chan_in, &d_mbx);
3658     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3659     n = (p->bufsize+1) * sizeof(char);
3660     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3661     p->shut_on_empty = FALSE;
3662     p->retry = 0;
3663     p->info  = 0;
3664     strcpy(out, mbx);
3665
3666     _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3667                              pipe_mbxtofd_ast, p,
3668                              p->buf, p->bufsize, 0, 0, 0, 0));
3669
3670     return p;
3671 }
3672
3673 static void
3674 pipe_mbxtofd_ast(pPipe p)
3675 {
3676     int iss = p->iosb.status;
3677     int done = p->info->done;
3678     int iss2;
3679     int eof = (iss == SS$_ENDOFFILE);
3680     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3681     int err = !(iss&1) && !eof;
3682 #if defined(PERL_IMPLICIT_CONTEXT)
3683     pTHX = p->thx;
3684 #endif
3685
3686     if (done && myeof) {               /* end piping */
3687         close(p->fd_out);
3688         sys$dassgn(p->chan_in);
3689         *p->pipe_done = TRUE;
3690         _ckvmssts_noperl(sys$setef(pipe_ef));
3691         return;
3692     }
3693
3694     if (!err && !eof) {             /* good data to send to file */
3695         p->buf[p->iosb.count] = '\n';
3696         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3697         if (iss2 < 0) {
3698             p->retry++;
3699             if (p->retry < MAX_RETRY) {
3700                 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3701                 return;
3702             }
3703         }
3704         p->retry = 0;
3705     } else if (err) {
3706         _ckvmssts_noperl(iss);
3707     }
3708
3709
3710     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3711           pipe_mbxtofd_ast, p,
3712           p->buf, p->bufsize, 0, 0, 0, 0);
3713     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3714     _ckvmssts_noperl(iss);
3715 }
3716
3717
3718 typedef struct _pipeloc     PLOC;
3719 typedef struct _pipeloc*   pPLOC;
3720
3721 struct _pipeloc {
3722     pPLOC   next;
3723     char    dir[NAM$C_MAXRSS+1];
3724 };
3725 static pPLOC  head_PLOC = 0;
3726
3727 void
3728 free_pipelocs(pTHX_ void *head)
3729 {
3730     pPLOC p, pnext;
3731     pPLOC *pHead = (pPLOC *)head;
3732
3733     p = *pHead;
3734     while (p) {
3735         pnext = p->next;
3736         PerlMem_free(p);
3737         p = pnext;
3738     }
3739     *pHead = 0;
3740 }
3741
3742 static void
3743 store_pipelocs(pTHX)
3744 {
3745     int    i;
3746     pPLOC  p;
3747     AV    *av = 0;
3748     SV    *dirsv;
3749     GV    *gv;
3750     char  *dir, *x;
3751     char  *unixdir;
3752     char  temp[NAM$C_MAXRSS+1];
3753     STRLEN n_a;
3754
3755     if (head_PLOC)
3756         free_pipelocs(aTHX_ &head_PLOC);
3757
3758 /*  the . directory from @INC comes last */
3759
3760     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3761     if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3762     p->next = head_PLOC;
3763     head_PLOC = p;
3764     strcpy(p->dir,"./");
3765
3766 /*  get the directory from $^X */
3767
3768     unixdir = PerlMem_malloc(VMS_MAXRSS);
3769     if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3770
3771 #ifdef PERL_IMPLICIT_CONTEXT
3772     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3773 #else
3774     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3775 #endif
3776         strcpy(temp, PL_origargv[0]);
3777         x = strrchr(temp,']');
3778         if (x == NULL) {
3779         x = strrchr(temp,'>');
3780           if (x == NULL) {
3781             /* It could be a UNIX path */
3782             x = strrchr(temp,'/');
3783           }
3784         }
3785         if (x)
3786           x[1] = '\0';
3787         else {
3788           /* Got a bare name, so use default directory */
3789           temp[0] = '.';
3790           temp[1] = '\0';
3791         }
3792
3793         if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3794             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3795             if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3796             p->next = head_PLOC;
3797             head_PLOC = p;
3798             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3799             p->dir[NAM$C_MAXRSS] = '\0';
3800         }
3801     }
3802
3803 /*  reverse order of @INC entries, skip "." since entered above */
3804
3805 #ifdef PERL_IMPLICIT_CONTEXT
3806     if (aTHX)
3807 #endif
3808     if (PL_incgv) av = GvAVn(PL_incgv);
3809
3810     for (i = 0; av && i <= AvFILL(av); i++) {
3811         dirsv = *av_fetch(av,i,TRUE);
3812
3813         if (SvROK(dirsv)) continue;
3814         dir = SvPVx(dirsv,n_a);
3815         if (strcmp(dir,".") == 0) continue;
3816         if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3817             continue;
3818
3819         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3820         p->next = head_PLOC;
3821         head_PLOC = p;
3822         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3823         p->dir[NAM$C_MAXRSS] = '\0';
3824     }
3825
3826 /* most likely spot (ARCHLIB) put first in the list */
3827
3828 #ifdef ARCHLIB_EXP
3829     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3830         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3831         if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3832         p->next = head_PLOC;
3833         head_PLOC = p;
3834         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3835         p->dir[NAM$C_MAXRSS] = '\0';
3836     }
3837 #endif
3838     PerlMem_free(unixdir);
3839 }
3840
3841 static I32
3842 Perl_cando_by_name_int
3843    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3844 #if !defined(PERL_IMPLICIT_CONTEXT)
3845 #define cando_by_name_int               Perl_cando_by_name_int
3846 #else
3847 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3848 #endif
3849
3850 static char *
3851 find_vmspipe(pTHX)
3852 {
3853     static int   vmspipe_file_status = 0;
3854     static char  vmspipe_file[NAM$C_MAXRSS+1];
3855
3856     /* already found? Check and use ... need read+execute permission */
3857
3858     if (vmspipe_file_status == 1) {
3859         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3860          && cando_by_name_int
3861            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3862             return vmspipe_file;
3863         }
3864         vmspipe_file_status = 0;
3865     }
3866
3867     /* scan through stored @INC, $^X */
3868
3869     if (vmspipe_file_status == 0) {
3870         char file[NAM$C_MAXRSS+1];
3871         pPLOC  p = head_PLOC;
3872
3873         while (p) {
3874             char * exp_res;
3875             int dirlen;
3876             strcpy(file, p->dir);
3877             dirlen = strlen(file);
3878             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3879             file[NAM$C_MAXRSS] = '\0';
3880             p = p->next;
3881
3882             exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3883             if (!exp_res) continue;
3884
3885             if (cando_by_name_int
3886                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3887              && cando_by_name_int
3888                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3889                 vmspipe_file_status = 1;
3890                 return vmspipe_file;
3891             }
3892         }
3893         vmspipe_file_status = -1;   /* failed, use tempfiles */
3894     }
3895
3896     return 0;
3897 }
3898
3899 static FILE *
3900 vmspipe_tempfile(pTHX)
3901 {
3902     char file[NAM$C_MAXRSS+1];
3903     FILE *fp;
3904     static int index = 0;
3905     Stat_t s0, s1;
3906     int cmp_result;
3907
3908     /* create a tempfile */
3909
3910     /* we can't go from   W, shr=get to  R, shr=get without
3911        an intermediate vulnerable state, so don't bother trying...
3912
3913        and lib$spawn doesn't shr=put, so have to close the write
3914
3915        So... match up the creation date/time and the FID to
3916        make sure we're dealing with the same file
3917
3918     */
3919
3920     index++;
3921     if (!decc_filename_unix_only) {
3922       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3923       fp = fopen(file,"w");
3924       if (!fp) {
3925         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3926         fp = fopen(file,"w");
3927         if (!fp) {
3928             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3929             fp = fopen(file,"w");
3930         }
3931       }
3932      }
3933      else {
3934       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3935       fp = fopen(file,"w");
3936       if (!fp) {
3937         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3938         fp = fopen(file,"w");
3939         if (!fp) {
3940           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3941           fp = fopen(file,"w");
3942         }
3943       }
3944     }
3945     if (!fp) return 0;  /* we're hosed */
3946
3947     fprintf(fp,"$! 'f$verify(0)'\n");
3948     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3949     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3950     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3951     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3952     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3953     fprintf(fp,"$ perl_del    = \"delete\"\n");
3954     fprintf(fp,"$ pif         = \"if\"\n");
3955     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3956     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3957     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3958     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3959     fprintf(fp,"$!  --- build command line to get max possible length\n");
3960     fprintf(fp,"$c=perl_popen_cmd0\n");
3961     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3962     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3963     fprintf(fp,"$x=perl_popen_cmd3\n");
3964     fprintf(fp,"$c=c+x\n");
3965     fprintf(fp,"$ perl_on\n");
3966     fprintf(fp,"$ 'c'\n");
3967     fprintf(fp,"$ perl_status = $STATUS\n");
3968     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3969     fprintf(fp,"$ perl_exit 'perl_status'\n");
3970     fsync(fileno(fp));
3971
3972     fgetname(fp, file, 1);
3973     fstat(fileno(fp), &s0.crtl_stat);
3974     fclose(fp);
3975
3976     if (decc_filename_unix_only)
3977         int_tounixspec(file, file, NULL);
3978     fp = fopen(file,"r","shr=get");
3979     if (!fp) return 0;
3980     fstat(fileno(fp), &s1.crtl_stat);
3981
3982     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3983     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3984         fclose(fp);
3985         return 0;
3986     }
3987
3988     return fp;
3989 }
3990
3991
3992 static int vms_is_syscommand_xterm(void)
3993 {
3994     const static struct dsc$descriptor_s syscommand_dsc =
3995       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3996
3997     const static struct dsc$descriptor_s decwdisplay_dsc =
3998       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3999
4000     struct item_list_3 items[2];
4001     unsigned short dvi_iosb[4];
4002     unsigned long devchar;
4003     unsigned long devclass;
4004     int status;
4005
4006     /* Very simple check to guess if sys$command is a decterm? */
4007     /* First see if the DECW$DISPLAY: device exists */
4008     items[0].len = 4;
4009     items[0].code = DVI$_DEVCHAR;
4010     items[0].bufadr = &devchar;
4011     items[0].retadr = NULL;
4012     items[1].len = 0;
4013     items[1].code = 0;
4014
4015     status = sys$getdviw
4016         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
4017
4018     if ($VMS_STATUS_SUCCESS(status)) {
4019         status = dvi_iosb[0];
4020     }
4021
4022     if (!$VMS_STATUS_SUCCESS(status)) {
4023         SETERRNO(EVMSERR, status);
4024         return -1;
4025     }
4026
4027     /* If it does, then for now assume that we are on a workstation */
4028     /* Now verify that SYS$COMMAND is a terminal */
4029     /* for creating the debugger DECTerm */
4030
4031     items[0].len = 4;
4032     items[0].code = DVI$_DEVCLASS;
4033     items[0].bufadr = &devclass;
4034     items[0].retadr = NULL;
4035     items[1].len = 0;
4036     items[1].code = 0;
4037
4038     status = sys$getdviw
4039         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
4040
4041     if ($VMS_STATUS_SUCCESS(status)) {
4042         status = dvi_iosb[0];
4043     }
4044
4045     if (!$VMS_STATUS_SUCCESS(status)) {
4046         SETERRNO(EVMSERR, status);
4047         return -1;
4048     }
4049     else {
4050         if (devclass == DC$_TERM) {
4051             return 0;
4052         }
4053     }
4054     return -1;
4055 }
4056
4057 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
4058 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
4059 {
4060     int status;
4061     int ret_stat;
4062     char * ret_char;
4063     char device_name[65];
4064     unsigned short device_name_len;
4065     struct dsc$descriptor_s customization_dsc;
4066     struct dsc$descriptor_s device_name_dsc;
4067     const char * cptr;
4068     char * tptr;
4069     char customization[200];
4070     char title[40];
4071     pInfo info = NULL;
4072     char mbx1[64];
4073     unsigned short p_chan;
4074     int n;
4075     unsigned short iosb[4];
4076     struct item_list_3 items[2];
4077     const char * cust_str =
4078         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
4079     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
4080                                           DSC$K_CLASS_S, mbx1};
4081
4082      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
4083     /*---------------------------------------*/
4084     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
4085
4086
4087     /* Make sure that this is from the Perl debugger */
4088     ret_char = strstr(cmd," xterm ");
4089     if (ret_char == NULL)
4090         return NULL;
4091     cptr = ret_char + 7;
4092     ret_char = strstr(cmd,"tty");
4093     if (ret_char == NULL)
4094         return NULL;
4095     ret_char = strstr(cmd,"sleep");
4096     if (ret_char == NULL)
4097         return NULL;
4098
4099     if (decw_term_port == 0) {
4100         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
4101         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
4102         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
4103
4104        status = lib$find_image_symbol
4105                                (&filename1_dsc,
4106                                 &decw_term_port_dsc,
4107                                 (void *)&decw_term_port,
4108                                 NULL,
4109                                 0);
4110
4111         /* Try again with the other image name */
4112         if (!$VMS_STATUS_SUCCESS(status)) {
4113
4114            status = lib$find_image_symbol
4115                                (&filename2_dsc,
4116                                 &decw_term_port_dsc,
4117                                 (void *)&decw_term_port,
4118                                 NULL,
4119                                 0);
4120
4121         }
4122
4123     }
4124
4125
4126     /* No decw$term_port, give it up */
4127     if (!$VMS_STATUS_SUCCESS(status))
4128         return NULL;
4129
4130     /* Are we on a workstation? */
4131     /* to do: capture the rows / columns and pass their properties */
4132     ret_stat = vms_is_syscommand_xterm();
4133     if (ret_stat < 0)
4134         return NULL;
4135
4136     /* Make the title: */
4137     ret_char = strstr(cptr,"-title");
4138     if (ret_char != NULL) {
4139         while ((*cptr != 0) && (*cptr != '\"')) {
4140             cptr++;
4141         }
4142         if (*cptr == '\"')
4143             cptr++;
4144         n = 0;
4145         while ((*cptr != 0) && (*cptr != '\"')) {
4146             title[n] = *cptr;
4147             n++;
4148             if (n == 39) {
4149                 title[39] == 0;
4150                 break;
4151             }
4152             cptr++;
4153         }
4154         title[n] = 0;
4155     }
4156     else {
4157             /* Default title */
4158             strcpy(title,"Perl Debug DECTerm");
4159     }
4160     sprintf(customization, cust_str, title);
4161
4162     customization_dsc.dsc$a_pointer = customization;
4163     customization_dsc.dsc$w_length = strlen(customization);
4164     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4165     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
4166
4167     device_name_dsc.dsc$a_pointer = device_name;
4168     device_name_dsc.dsc$w_length = sizeof device_name -1;
4169     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4170     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
4171
4172     device_name_len = 0;
4173
4174     /* Try to create the window */
4175      status = (*decw_term_port)
4176        (NULL,
4177         NULL,
4178         &customization_dsc,
4179         &device_name_dsc,
4180         &device_name_len,
4181         NULL,
4182         NULL,
4183         NULL);
4184     if (!$VMS_STATUS_SUCCESS(status)) {
4185         SETERRNO(EVMSERR, status);
4186         return NULL;
4187     }
4188
4189     device_name[device_name_len] = '\0';
4190
4191     /* Need to set this up to look like a pipe for cleanup */
4192     n = sizeof(Info);
4193     status = lib$get_vm(&n, &info);
4194     if (!$VMS_STATUS_SUCCESS(status)) {
4195         SETERRNO(ENOMEM, status);
4196         return NULL;
4197     }
4198
4199     info->mode = *mode;
4200     info->done = FALSE;
4201     info->completion = 0;
4202     info->closing    = FALSE;
4203     info->in         = 0;
4204     info->out        = 0;
4205     info->err        = 0;
4206     info->fp         = NULL;
4207     info->useFILE    = 0;
4208     info->waiting    = 0;
4209     info->in_done    = TRUE;
4210     info->out_done   = TRUE;
4211     info->err_done   = TRUE;
4212
4213     /* Assign a channel on this so that it will persist, and not login */
4214     /* We stash this channel in the info structure for reference. */
4215     /* The created xterm self destructs when the last channel is removed */
4216     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4217     /* So leave this assigned. */
4218     device_name_dsc.dsc$w_length = device_name_len;
4219     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4220     if (!$VMS_STATUS_SUCCESS(status)) {
4221         SETERRNO(EVMSERR, status);
4222         return NULL;
4223     }
4224     info->xchan_valid = 1;
4225
4226     /* Now create a mailbox to be read by the application */
4227
4228     create_mbx(&p_chan, &d_mbx1);
4229
4230     /* write the name of the created terminal to the mailbox */
4231     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4232             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4233
4234     if (!$VMS_STATUS_SUCCESS(status)) {
4235         SETERRNO(EVMSERR, status);
4236         return NULL;
4237     }
4238
4239     info->fp  = PerlIO_open(mbx1, mode);
4240
4241     /* Done with this channel */
4242     sys$dassgn(p_chan);
4243
4244     /* If any errors, then clean up */
4245     if (!info->fp) {
4246         n = sizeof(Info);
4247         _ckvmssts_noperl(lib$free_vm(&n, &info));
4248         return NULL;
4249         }
4250
4251     /* All done */
4252     return info->fp;
4253 }
4254
4255 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4256
4257 static PerlIO *
4258 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4259 {
4260     static int handler_set_up = FALSE;
4261     PerlIO * ret_fp;
4262     unsigned long int sts, flags = CLI$M_NOWAIT;
4263     /* The use of a GLOBAL table (as was done previously) rendered
4264      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4265      * environment.  Hence we've switched to LOCAL symbol table.
4266      */
4267     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4268     int j, wait = 0, n;
4269     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4270     char *in, *out, *err, mbx[512];
4271     FILE *tpipe = 0;
4272     char tfilebuf[NAM$C_MAXRSS+1];
4273     pInfo info = NULL;
4274     char cmd_sym_name[20];
4275     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4276                                       DSC$K_CLASS_S, symbol};
4277     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4278                                       DSC$K_CLASS_S, 0};
4279     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4280                                       DSC$K_CLASS_S, cmd_sym_name};
4281     struct dsc$descriptor_s *vmscmd;
4282     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4283     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4284     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4285
4286     /* Check here for Xterm create request.  This means looking for
4287      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4288      *  is possible to create an xterm.
4289      */
4290     if (*in_mode == 'r') {
4291         PerlIO * xterm_fd;
4292
4293         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4294         if (xterm_fd != NULL)
4295             return xterm_fd;
4296     }
4297
4298     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4299
4300     /* once-per-program initialization...
4301        note that the SETAST calls and the dual test of pipe_ef
4302        makes sure that only the FIRST thread through here does
4303        the initialization...all other threads wait until it's
4304        done.
4305
4306        Yeah, uglier than a pthread call, it's got all the stuff inline
4307        rather than in a separate routine.
4308     */
4309
4310     if (!pipe_ef) {
4311         _ckvmssts_noperl(sys$setast(0));
4312         if (!pipe_ef) {
4313             unsigned long int pidcode = JPI$_PID;
4314             $DESCRIPTOR(d_delay, RETRY_DELAY);
4315             _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4316             _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4317             _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4318         }
4319         if (!handler_set_up) {
4320           _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4321           handler_set_up = TRUE;
4322         }
4323         _ckvmssts_noperl(sys$setast(1));
4324     }
4325
4326     /* see if we can find a VMSPIPE.COM */
4327
4328     tfilebuf[0] = '@';
4329     vmspipe = find_vmspipe(aTHX);
4330     if (vmspipe) {
4331         strcpy(tfilebuf+1,vmspipe);
4332     } else {        /* uh, oh...we're in tempfile hell */
4333         tpipe = vmspipe_tempfile(aTHX);
4334         if (!tpipe) {       /* a fish popular in Boston */
4335             if (ckWARN(WARN_PIPE)) {
4336                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4337             }
4338         return NULL;
4339         }
4340         fgetname(tpipe,tfilebuf+1,1);
4341     }
4342     vmspipedsc.dsc$a_pointer = tfilebuf;
4343     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4344
4345     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4346     if (!(sts & 1)) {
4347       switch (sts) {
4348         case RMS$_FNF:  case RMS$_DNF:
4349           set_errno(ENOENT); break;
4350         case RMS$_DIR:
4351           set_errno(ENOTDIR); break;
4352         case RMS$_DEV:
4353           set_errno(ENODEV); break;
4354         case RMS$_PRV:
4355           set_errno(EACCES); break;
4356         case RMS$_SYN:
4357           set_errno(EINVAL); break;
4358         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4359           set_errno(E2BIG); break;
4360         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4361           _ckvmssts_noperl(sts); /* fall through */
4362         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4363           set_errno(EVMSERR);
4364       }
4365       set_vaxc_errno(sts);
4366       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4367         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4368       }
4369       *psts = sts;
4370       return NULL;
4371     }
4372     n = sizeof(Info);
4373     _ckvmssts_noperl(lib$get_vm(&n, &info));
4374
4375     strcpy(mode,in_mode);
4376     info->mode = *mode;
4377     info->done = FALSE;
4378     info->completion = 0;
4379     info->closing    = FALSE;
4380     info->in         = 0;
4381     info->out        = 0;
4382     info->err        = 0;
4383     info->fp         = NULL;
4384     info->useFILE    = 0;
4385     info->waiting    = 0;
4386     info->in_done    = TRUE;
4387     info->out_done   = TRUE;
4388     info->err_done   = TRUE;
4389     info->xchan      = 0;
4390     info->xchan_valid = 0;
4391
4392     in = PerlMem_malloc(VMS_MAXRSS);
4393     if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4394     out = PerlMem_malloc(VMS_MAXRSS);
4395     if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4396     err = PerlMem_malloc(VMS_MAXRSS);
4397     if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4398
4399     in[0] = out[0] = err[0] = '\0';
4400
4401     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4402         info->useFILE = 1;
4403         strcpy(p,p+1);
4404     }
4405     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4406         wait = 1;
4407         strcpy(p,p+1);
4408     }
4409
4410     if (*mode == 'r') {             /* piping from subroutine */
4411
4412         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4413         if (info->out) {
4414             info->out->pipe_done = &info->out_done;
4415             info->out_done = FALSE;
4416             info->out->info = info;
4417         }
4418         if (!info->useFILE) {
4419             info->fp  = PerlIO_open(mbx, mode);
4420         } else {
4421             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4422             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4423         }
4424
4425         if (!info->fp && info->out) {
4426             sys$cancel(info->out->chan_out);
4427
4428             while (!info->out_done) {
4429                 int done;
4430                 _ckvmssts_noperl(sys$setast(0));
4431                 done = info->out_done;
4432                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4433                 _ckvmssts_noperl(sys$setast(1));
4434                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4435             }
4436
4437             if (info->out->buf) {
4438                 n = info->out->bufsize * sizeof(char);
4439                 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4440             }
4441             n = sizeof(Pipe);
4442             _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4443             n = sizeof(Info);
4444             _ckvmssts_noperl(lib$free_vm(&n, &info));
4445             *psts = RMS$_FNF;
4446             return NULL;
4447         }
4448
4449         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4450         if (info->err) {
4451             info->err->pipe_done = &info->err_done;
4452             info->err_done = FALSE;
4453             info->err->info = info;
4454         }
4455
4456     } else if (*mode == 'w') {      /* piping to subroutine */
4457
4458         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4459         if (info->out) {
4460             info->out->pipe_done = &info->out_done;
4461             info->out_done = FALSE;
4462             info->out->info = info;
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         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4473         if (!info->useFILE) {
4474             info->fp  = PerlIO_open(mbx, mode);
4475         } else {
4476             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4477             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4478         }
4479
4480         if (info->in) {
4481             info->in->pipe_done = &info->in_done;
4482             info->in_done = FALSE;
4483             info->in->info = info;
4484         }
4485
4486         /* error cleanup */
4487         if (!info->fp && info->in) {
4488             info->done = TRUE;
4489             _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4490                                       0, 0, 0, 0, 0, 0, 0, 0));
4491
4492             while (!info->in_done) {
4493                 int done;
4494                 _ckvmssts_noperl(sys$setast(0));
4495                 done = info->in_done;
4496                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4497                 _ckvmssts_noperl(sys$setast(1));
4498                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4499             }
4500
4501             if (info->in->buf) {
4502                 n = info->in->bufsize * sizeof(char);
4503                 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4504             }
4505             n = sizeof(Pipe);
4506             _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4507             n = sizeof(Info);
4508             _ckvmssts_noperl(lib$free_vm(&n, &info));
4509             *psts = RMS$_FNF;
4510             return NULL;
4511         }
4512
4513
4514     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4515         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4516         if (info->out) {
4517             info->out->pipe_done = &info->out_done;
4518             info->out_done = FALSE;
4519             info->out->info = info;
4520         }
4521
4522         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4523         if (info->err) {
4524             info->err->pipe_done = &info->err_done;
4525             info->err_done = FALSE;
4526             info->err->info = info;
4527         }
4528     }
4529
4530     symbol[MAX_DCL_SYMBOL] = '\0';
4531
4532     strncpy(symbol, in, MAX_DCL_SYMBOL);
4533     d_symbol.dsc$w_length = strlen(symbol);
4534     _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4535
4536     strncpy(symbol, err, MAX_DCL_SYMBOL);
4537     d_symbol.dsc$w_length = strlen(symbol);
4538     _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4539
4540     strncpy(symbol, out, MAX_DCL_SYMBOL);
4541     d_symbol.dsc$w_length = strlen(symbol);
4542     _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4543
4544     /* Done with the names for the pipes */
4545     PerlMem_free(err);
4546     PerlMem_free(out);
4547     PerlMem_free(in);
4548
4549     p = vmscmd->dsc$a_pointer;
4550     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4551     if (*p == '$') p++;                         /* remove leading $ */
4552     while (*p == ' ' || *p == '\t') p++;
4553
4554     for (j = 0; j < 4; j++) {
4555         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4556         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4557
4558     strncpy(symbol, p, MAX_DCL_SYMBOL);
4559     d_symbol.dsc$w_length = strlen(symbol);
4560     _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4561
4562         if (strlen(p) > MAX_DCL_SYMBOL) {
4563             p += MAX_DCL_SYMBOL;
4564         } else {
4565             p += strlen(p);
4566         }
4567     }
4568     _ckvmssts_noperl(sys$setast(0));
4569     info->next=open_pipes;  /* prepend to list */
4570     open_pipes=info;
4571     _ckvmssts_noperl(sys$setast(1));
4572     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4573      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4574      * have SYS$COMMAND if we need it.
4575      */
4576     _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4577                       0, &info->pid, &info->completion,
4578                       0, popen_completion_ast,info,0,0,0));
4579
4580     /* if we were using a tempfile, close it now */
4581
4582     if (tpipe) fclose(tpipe);
4583
4584     /* once the subprocess is spawned, it has copied the symbols and
4585        we can get rid of ours */
4586
4587     for (j = 0; j < 4; j++) {
4588         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4589         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4590     _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4591     }
4592     _ckvmssts_noperl(lib$delete_symbol(&d_sym_in,  &table));
4593     _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4594     _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4595     vms_execfree(vmscmd);
4596
4597 #ifdef PERL_IMPLICIT_CONTEXT
4598     if (aTHX)
4599 #endif
4600     PL_forkprocess = info->pid;
4601
4602     ret_fp = info->fp;
4603     if (wait) {
4604          dSAVEDERRNO;
4605          int done = 0;
4606          while (!done) {
4607              _ckvmssts_noperl(sys$setast(0));
4608              done = info->done;
4609              if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4610              _ckvmssts_noperl(sys$setast(1));
4611              if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4612          }
4613         *psts = info->completion;
4614 /* Caller thinks it is open and tries to close it. */
4615 /* This causes some problems, as it changes the error status */
4616 /*        my_pclose(info->fp); */
4617
4618          /* If we did not have a file pointer open, then we have to */
4619          /* clean up here or eventually we will run out of something */
4620          SAVE_ERRNO;
4621          if (info->fp == NULL) {
4622              my_pclose_pinfo(aTHX_ info);
4623          }
4624          RESTORE_ERRNO;
4625
4626     } else {
4627         *psts = info->pid;
4628     }
4629     return ret_fp;
4630 }  /* end of safe_popen */
4631
4632
4633 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4634 PerlIO *
4635 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4636 {
4637     int sts;
4638     TAINT_ENV();
4639     TAINT_PROPER("popen");
4640     PERL_FLUSHALL_FOR_CHILD;
4641     return safe_popen(aTHX_ cmd,mode,&sts);
4642 }
4643
4644 /*}}}*/
4645
4646
4647 /* Routine to close and cleanup a pipe info structure */
4648
4649 static I32 my_pclose_pinfo(pTHX_ pInfo info) {
4650
4651     unsigned long int retsts;
4652     int done, iss, n;
4653     int status;
4654     pInfo next, last;
4655
4656     /* If we were writing to a subprocess, insure that someone reading from
4657      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4658      * produce an EOF record in the mailbox.
4659      *
4660      *  well, at least sometimes it *does*, so we have to watch out for
4661      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4662      */
4663      if (info->fp) {
4664         if (!info->useFILE
4665 #if defined(USE_ITHREADS)
4666           && my_perl
4667 #endif
4668           && PL_perlio_fd_refcnt)
4669             PerlIO_flush(info->fp);
4670         else
4671             fflush((FILE *)info->fp);
4672     }
4673
4674     _ckvmssts(sys$setast(0));
4675      info->closing = TRUE;
4676      done = info->done && info->in_done && info->out_done && info->err_done;
4677      /* hanging on write to Perl's input? cancel it */
4678      if (info->mode == 'r' && info->out && !info->out_done) {
4679         if (info->out->chan_out) {
4680             _ckvmssts(sys$cancel(info->out->chan_out));
4681             if (!info->out->chan_in) {   /* EOF generation, need AST */
4682                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4683             }
4684         }
4685      }
4686      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4687          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4688                            0, 0, 0, 0, 0, 0));
4689     _ckvmssts(sys$setast(1));
4690     if (info->fp) {
4691      if (!info->useFILE
4692 #if defined(USE_ITHREADS)
4693          && my_perl
4694 #endif
4695          && PL_perlio_fd_refcnt)
4696         PerlIO_close(info->fp);
4697      else
4698         fclose((FILE *)info->fp);
4699     }
4700      /*
4701         we have to wait until subprocess completes, but ALSO wait until all
4702         the i/o completes...otherwise we'll be freeing the "info" structure
4703         that the i/o ASTs could still be using...
4704      */
4705
4706      while (!done) {
4707          _ckvmssts(sys$setast(0));
4708          done = info->done && info->in_done && info->out_done && info->err_done;
4709          if (!done) _ckvmssts(sys$clref(pipe_ef));
4710          _ckvmssts(sys$setast(1));
4711          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4712      }
4713      retsts = info->completion;
4714
4715     /* remove from list of open pipes */
4716     _ckvmssts(sys$setast(0));
4717     last = NULL;
4718     for (next = open_pipes; next != NULL; last = next, next = next->next) {
4719         if (next == info)
4720             break;
4721     }
4722
4723     if (last)
4724         last->next = info->next;
4725     else
4726         open_pipes = info->next;
4727     _ckvmssts(sys$setast(1));
4728
4729     /* free buffers and structures */
4730
4731     if (info->in) {
4732         if (info->in->buf) {
4733             n = info->in->bufsize * sizeof(char);
4734             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4735         }
4736         n = sizeof(Pipe);
4737         _ckvmssts(lib$free_vm(&n, &info->in));
4738     }
4739     if (info->out) {
4740         if (info->out->buf) {
4741             n = info->out->bufsize * sizeof(char);
4742             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4743         }
4744         n = sizeof(Pipe);
4745         _ckvmssts(lib$free_vm(&n, &info->out));
4746     }
4747     if (info->err) {
4748         if (info->err->buf) {
4749             n = info->err->bufsize * sizeof(char);
4750             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4751         }
4752         n = sizeof(Pipe);
4753         _ckvmssts(lib$free_vm(&n, &info->err));
4754     }
4755     n = sizeof(Info);
4756     _ckvmssts(lib$free_vm(&n, &info));
4757
4758     return retsts;
4759 }
4760
4761
4762 /*{{{  I32 my_pclose(PerlIO *fp)*/
4763 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4764 {
4765     pInfo info, last = NULL;
4766     I32 ret_status;
4767
4768     /* Fixme - need ast and mutex protection here */
4769     for (info = open_pipes; info != NULL; last = info, info = info->next)
4770         if (info->fp == fp) break;
4771
4772     if (info == NULL) {  /* no such pipe open */
4773       set_errno(ECHILD); /* quoth POSIX */
4774       set_vaxc_errno(SS$_NONEXPR);
4775       return -1;
4776     }
4777
4778     ret_status = my_pclose_pinfo(aTHX_ info);
4779
4780     return ret_status;
4781
4782 }  /* end of my_pclose() */
4783
4784 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4785   /* Roll our own prototype because we want this regardless of whether
4786    * _VMS_WAIT is defined.
4787    */
4788   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4789 #endif
4790 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4791    created with popen(); otherwise partially emulate waitpid() unless
4792    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4793    Also check processes not considered by the CRTL waitpid().
4794  */
4795 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4796 Pid_t
4797 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4798 {
4799     pInfo info;
4800     int done;
4801     int sts;
4802     int j;
4803
4804     if (statusp) *statusp = 0;
4805
4806     for (info = open_pipes; info != NULL; info = info->next)
4807         if (info->pid == pid) break;
4808
4809     if (info != NULL) {  /* we know about this child */
4810       while (!info->done) {
4811           _ckvmssts(sys$setast(0));
4812           done = info->done;
4813           if (!done) _ckvmssts(sys$clref(pipe_ef));
4814           _ckvmssts(sys$setast(1));
4815           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4816       }
4817
4818       if (statusp) *statusp = info->completion;
4819       return pid;
4820     }
4821
4822     /* child that already terminated? */
4823
4824     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4825         if (closed_list[j].pid == pid) {
4826             if (statusp) *statusp = closed_list[j].completion;
4827             return pid;
4828         }
4829     }
4830
4831     /* fall through if this child is not one of our own pipe children */
4832
4833 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4834
4835       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4836        * in 7.2 did we get a version that fills in the VMS completion
4837        * status as Perl has always tried to do.
4838        */
4839
4840       sts = __vms_waitpid( pid, statusp, flags );
4841
4842       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4843          return sts;
4844
4845       /* If the real waitpid tells us the child does not exist, we
4846        * fall through here to implement waiting for a child that
4847        * was created by some means other than exec() (say, spawned
4848        * from DCL) or to wait for a process that is not a subprocess
4849        * of the current process.
4850        */
4851
4852 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4853
4854     {
4855       $DESCRIPTOR(intdsc,"0 00:00:01");
4856       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4857       unsigned long int pidcode = JPI$_PID, mypid;
4858       unsigned long int interval[2];
4859       unsigned int jpi_iosb[2];
4860       struct itmlst_3 jpilist[2] = {
4861           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4862           {                      0,         0,                 0, 0}
4863       };
4864
4865       if (pid <= 0) {
4866         /* Sorry folks, we don't presently implement rooting around for
4867            the first child we can find, and we definitely don't want to
4868            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4869          */
4870         set_errno(ENOTSUP);
4871         return -1;
4872       }
4873
4874       /* Get the owner of the child so I can warn if it's not mine. If the
4875        * process doesn't exist or I don't have the privs to look at it,
4876        * I can go home early.
4877        */
4878       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4879       if (sts & 1) sts = jpi_iosb[0];
4880       if (!(sts & 1)) {
4881         switch (sts) {
4882             case SS$_NONEXPR:
4883                 set_errno(ECHILD);
4884                 break;
4885             case SS$_NOPRIV:
4886                 set_errno(EACCES);
4887                 break;
4888             default:
4889                 _ckvmssts(sts);
4890         }
4891         set_vaxc_errno(sts);
4892         return -1;
4893       }
4894
4895       if (ckWARN(WARN_EXEC)) {
4896         /* remind folks they are asking for non-standard waitpid behavior */
4897         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4898         if (ownerpid != mypid)
4899           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4900                       "waitpid: process %x is not a child of process %x",
4901                       pid,mypid);
4902       }
4903
4904       /* simply check on it once a second until it's not there anymore. */
4905
4906       _ckvmssts(sys$bintim(&intdsc,interval));
4907       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4908             _ckvmssts(sys$schdwk(0,0,interval,0));
4909             _ckvmssts(sys$hiber());
4910       }
4911       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4912
4913       _ckvmssts(sts);
4914       return pid;
4915     }
4916 }  /* end of waitpid() */
4917 /*}}}*/
4918 /*}}}*/
4919 /*}}}*/
4920
4921 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4922 char *
4923 my_gconvert(double val, int ndig, int trail, char *buf)
4924 {
4925   static char __gcvtbuf[DBL_DIG+1];
4926   char *loc;
4927
4928   loc = buf ? buf : __gcvtbuf;
4929
4930 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4931   if (val < 1) {
4932     sprintf(loc,"%.*g",ndig,val);
4933     return loc;
4934   }
4935 #endif
4936
4937   if (val) {
4938     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4939     return gcvt(val,ndig,loc);
4940   }
4941   else {
4942     loc[0] = '0'; loc[1] = '\0';
4943     return loc;
4944   }
4945
4946 }
4947 /*}}}*/
4948
4949 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4950 static int rms_free_search_context(struct FAB * fab)
4951 {
4952 struct NAM * nam;
4953
4954     nam = fab->fab$l_nam;
4955     nam->nam$b_nop |= NAM$M_SYNCHK;
4956     nam->nam$l_rlf = NULL;
4957     fab->fab$b_dns = 0;
4958     return sys$parse(fab, NULL, NULL);
4959 }
4960
4961 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4962 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4963 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4964 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4965 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4966 #define rms_nam_esll(nam) nam.nam$b_esl
4967 #define rms_nam_esl(nam) nam.nam$b_esl
4968 #define rms_nam_name(nam) nam.nam$l_name
4969 #define rms_nam_namel(nam) nam.nam$l_name
4970 #define rms_nam_type(nam) nam.nam$l_type
4971 #define rms_nam_typel(nam) nam.nam$l_type
4972 #define rms_nam_ver(nam) nam.nam$l_ver
4973 #define rms_nam_verl(nam) nam.nam$l_ver
4974 #define rms_nam_rsll(nam) nam.nam$b_rsl
4975 #define rms_nam_rsl(nam) nam.nam$b_rsl
4976 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4977 #define rms_set_fna(fab, nam, name, size) \
4978         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4979 #define rms_get_fna(fab, nam) fab.fab$l_fna
4980 #define rms_set_dna(fab, nam, name, size) \
4981         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4982 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4983 #define rms_set_esa(nam, name, size) \
4984         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4985 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4986         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4987 #define rms_set_rsa(nam, name, size) \
4988         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4989 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4990         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4991 #define rms_nam_name_type_l_size(nam) \
4992         (nam.nam$b_name + nam.nam$b_type)
4993 #else
4994 static int rms_free_search_context(struct FAB * fab)
4995 {
4996 struct NAML * nam;
4997
4998     nam = fab->fab$l_naml;
4999     nam->naml$b_nop |= NAM$M_SYNCHK;
5000     nam->naml$l_rlf = NULL;
5001     nam->naml$l_long_defname_size = 0;
5002
5003     fab->fab$b_dns = 0;
5004     return sys$parse(fab, NULL, NULL);
5005 }
5006
5007 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
5008 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
5009 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
5010 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
5011 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
5012 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
5013 #define rms_nam_esl(nam) nam.naml$b_esl
5014 #define rms_nam_name(nam) nam.naml$l_name
5015 #define rms_nam_namel(nam) nam.naml$l_long_name
5016 #define rms_nam_type(nam) nam.naml$l_type
5017 #define rms_nam_typel(nam) nam.naml$l_long_type
5018 #define rms_nam_ver(nam) nam.naml$l_ver
5019 #define rms_nam_verl(nam) nam.naml$l_long_ver
5020 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
5021 #define rms_nam_rsl(nam) nam.naml$b_rsl
5022 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
5023 #define rms_set_fna(fab, nam, name, size) \
5024         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
5025         nam.naml$l_long_filename_size = size; \
5026         nam.naml$l_long_filename = name;}
5027 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
5028 #define rms_set_dna(fab, nam, name, size) \
5029         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
5030         nam.naml$l_long_defname_size = size; \
5031         nam.naml$l_long_defname = name; }
5032 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
5033 #define rms_set_esa(nam, name, size) \
5034         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
5035         nam.naml$l_long_expand_alloc = size; \
5036         nam.naml$l_long_expand = name; }
5037 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
5038         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
5039         nam.naml$l_long_expand = l_name; \
5040         nam.naml$l_long_expand_alloc = l_size; }
5041 #define rms_set_rsa(nam, name, size) \
5042         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
5043         nam.naml$l_long_result = name; \
5044         nam.naml$l_long_result_alloc = size; }
5045 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
5046         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
5047         nam.naml$l_long_result = l_name; \
5048         nam.naml$l_long_result_alloc = l_size; }
5049 #define rms_nam_name_type_l_size(nam) \
5050         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
5051 #endif
5052
5053
5054 /* rms_erase
5055  * The CRTL for 8.3 and later can create symbolic links in any mode,
5056  * however in 8.3 the unlink/remove/delete routines will only properly handle
5057  * them if one of the PCP modes is active.
5058  */
5059 static int rms_erase(const char * vmsname)
5060 {
5061   int status;
5062   struct FAB myfab = cc$rms_fab;
5063   rms_setup_nam(mynam);
5064
5065   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
5066   rms_bind_fab_nam(myfab, mynam);
5067
5068   /* Are we removing all versions? */
5069   if (vms_unlink_all_versions == 1) {
5070     const char * defspec = ";*";
5071     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
5072   }
5073
5074 #ifdef NAML$M_OPEN_SPECIAL
5075   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5076 #endif
5077
5078   status = sys$erase(&myfab, 0, 0);
5079
5080   return status;
5081 }
5082
5083
5084 static int
5085 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
5086                     const struct dsc$descriptor_s * vms_dst_dsc,
5087                     unsigned long flags)
5088 {
5089     /*  VMS and UNIX handle file permissions differently and the
5090      * the same ACL trick may be needed for renaming files,
5091      * especially if they are directories.
5092      */
5093
5094    /* todo: get kill_file and rename to share common code */
5095    /* I can not find online documentation for $change_acl
5096     * it appears to be replaced by $set_security some time ago */
5097
5098 const unsigned int access_mode = 0;
5099 $DESCRIPTOR(obj_file_dsc,"FILE");
5100 char *vmsname;
5101 char *rslt;
5102 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
5103 int aclsts, fndsts, rnsts = -1;
5104 unsigned int ctx = 0;
5105 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5106 struct dsc$descriptor_s * clean_dsc;
5107
5108 struct myacedef {
5109     unsigned char myace$b_length;
5110     unsigned char myace$b_type;
5111     unsigned short int myace$w_flags;
5112     unsigned long int myace$l_access;
5113     unsigned long int myace$l_ident;
5114 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
5115              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
5116              0},
5117              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
5118
5119 struct item_list_3
5120         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
5121                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
5122                       {0,0,0,0}},
5123         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
5124         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
5125                      {0,0,0,0}};
5126
5127
5128     /* Expand the input spec using RMS, since we do not want to put
5129      * ACLs on the target of a symbolic link */
5130     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
5131     if (vmsname == NULL)
5132         return SS$_INSFMEM;
5133
5134     rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
5135                         vmsname,
5136                         PERL_RMSEXPAND_M_SYMLINK);
5137     if (rslt == NULL) {
5138         PerlMem_free(vmsname);
5139         return SS$_INSFMEM;
5140     }
5141
5142     /* So we get our own UIC to use as a rights identifier,
5143      * and the insert an ACE at the head of the ACL which allows us
5144      * to delete the file.
5145      */
5146     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
5147
5148     fildsc.dsc$w_length = strlen(vmsname);
5149     fildsc.dsc$a_pointer = vmsname;
5150     ctx = 0;
5151     newace.myace$l_ident = oldace.myace$l_ident;
5152     rnsts = SS$_ABORT;
5153
5154     /* Grab any existing ACEs with this identifier in case we fail */
5155     clean_dsc = &fildsc;
5156     aclsts = fndsts = sys$get_security(&obj_file_dsc,
5157                                &fildsc,
5158                                NULL,
5159                                OSS$M_WLOCK,
5160                                findlst,
5161                                &ctx,
5162                                &access_mode);
5163
5164     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
5165         /* Add the new ACE . . . */
5166
5167         /* if the sys$get_security succeeded, then ctx is valid, and the
5168          * object/file descriptors will be ignored.  But otherwise they
5169          * are needed
5170          */
5171         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
5172                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
5173         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5174             set_errno(EVMSERR);
5175             set_vaxc_errno(aclsts);
5176             PerlMem_free(vmsname);
5177             return aclsts;
5178         }
5179
5180         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5181                                 NULL, NULL,
5182                                 &flags,
5183                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5184
5185         if ($VMS_STATUS_SUCCESS(rnsts)) {
5186             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5187         }
5188
5189         /* Put things back the way they were. */
5190         ctx = 0;
5191         aclsts = sys$get_security(&obj_file_dsc,
5192                                   clean_dsc,
5193                                   NULL,
5194                                   OSS$M_WLOCK,
5195                                   findlst,
5196                                   &ctx,
5197                                   &access_mode);
5198
5199         if ($VMS_STATUS_SUCCESS(aclsts)) {
5200         int sec_flags;
5201
5202             sec_flags = 0;
5203             if (!$VMS_STATUS_SUCCESS(fndsts))
5204                 sec_flags = OSS$M_RELCTX;
5205
5206             /* Get rid of the new ACE */
5207             aclsts = sys$set_security(NULL, NULL, NULL,
5208                                   sec_flags, dellst, &ctx, &access_mode);
5209
5210             /* If there was an old ACE, put it back */
5211             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5212                 addlst[0].bufadr = &oldace;
5213                 aclsts = sys$set_security(NULL, NULL, NULL,
5214                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
5215                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5216                     set_errno(EVMSERR);
5217                     set_vaxc_errno(aclsts);
5218                     rnsts = aclsts;
5219                 }
5220             } else {
5221             int aclsts2;
5222
5223                 /* Try to clear the lock on the ACL list */
5224                 aclsts2 = sys$set_security(NULL, NULL, NULL,
5225                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
5226
5227                 /* Rename errors are most important */
5228                 if (!$VMS_STATUS_SUCCESS(rnsts))
5229                     aclsts = rnsts;
5230                 set_errno(EVMSERR);
5231                 set_vaxc_errno(aclsts);
5232                 rnsts = aclsts;
5233             }
5234         }
5235         else {
5236             if (aclsts != SS$_ACLEMPTY)
5237                 rnsts = aclsts;
5238         }
5239     }
5240     else
5241         rnsts = fndsts;
5242
5243     PerlMem_free(vmsname);
5244     return rnsts;
5245 }
5246
5247
5248 /*{{{int rename(const char *, const char * */
5249 /* Not exactly what X/Open says to do, but doing it absolutely right
5250  * and efficiently would require a lot more work.  This should be close
5251  * enough to pass all but the most strict X/Open compliance test.
5252  */
5253 int
5254 Perl_rename(pTHX_ const char *src, const char * dst)
5255 {
5256 int retval;
5257 int pre_delete = 0;
5258 int src_sts;
5259 int dst_sts;
5260 Stat_t src_st;
5261 Stat_t dst_st;
5262
5263     /* Validate the source file */
5264     src_sts = Perl_flex_lstat(NULL, src, &src_st);
5265     if (src_sts != 0) {
5266
5267         /* No source file or other problem */
5268         return src_sts;
5269     }
5270     if (src_st.st_devnam[0] == 0)  {
5271         /* This may be possible so fail if it is seen. */
5272         errno = EIO;
5273         return -1;
5274     }
5275
5276     dst_sts = Perl_flex_lstat(NULL, dst, &dst_st);
5277     if (dst_sts == 0) {
5278
5279         if (dst_st.st_dev != src_st.st_dev) {
5280             /* Must be on the same device */
5281             errno = EXDEV;
5282             return -1;
5283         }
5284
5285         /* VMS_INO_T_COMPARE is true if the inodes are different
5286          * to match the output of memcmp
5287          */
5288
5289         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5290             /* That was easy, the files are the same! */
5291             return 0;
5292         }
5293
5294         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5295             /* If source is a directory, so must be dest */
5296                 errno = EISDIR;
5297                 return -1;
5298         }
5299
5300     }
5301
5302
5303     if ((dst_sts == 0) &&
5304         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5305
5306         /* We have issues here if vms_unlink_all_versions is set
5307          * If the destination exists, and is not a directory, then
5308          * we must delete in advance.
5309          *
5310          * If the src is a directory, then we must always pre-delete
5311          * the destination.
5312          *
5313          * If we successfully delete the dst in advance, and the rename fails
5314          * X/Open requires that errno be EIO.
5315          *
5316          */
5317
5318         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5319             int d_sts;
5320             d_sts = mp_do_kill_file(NULL, dst_st.st_devnam,
5321                                      S_ISDIR(dst_st.st_mode));
5322
5323            /* Need to delete all versions ? */
5324            if ((d_sts == 0) && (vms_unlink_all_versions == 1)) {
5325                 int i = 0;
5326
5327                 while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) {
5328                     d_sts = mp_do_kill_file(NULL, dst_st.st_devnam, 0);
5329                     if (d_sts != 0)
5330                         break;
5331                     i++;
5332
5333                     /* Make sure that we do not loop forever */
5334                     if (i > 32767) {
5335                         errno = EIO;
5336                         d_sts = -1;
5337                         break;
5338                     }
5339                 }
5340            }
5341
5342             if (d_sts != 0)
5343                 return d_sts;
5344
5345             /* We killed the destination, so only errno now is EIO */
5346             pre_delete = 1;
5347         }
5348     }
5349
5350     /* Originally the idea was to call the CRTL rename() and only
5351      * try the lib$rename_file if it failed.
5352      * It turns out that there are too many variants in what the
5353      * the CRTL rename might do, so only use lib$rename_file
5354      */
5355     retval = -1;
5356
5357     {
5358         /* Is the source and dest both in VMS format */
5359         /* if the source is a directory, then need to fileify */
5360         /*  and dest must be a directory or non-existant. */
5361
5362         char * vms_dst;
5363         int sts;
5364         char * ret_str;
5365         unsigned long flags;
5366         struct dsc$descriptor_s old_file_dsc;
5367         struct dsc$descriptor_s new_file_dsc;
5368
5369         /* We need to modify the src and dst depending
5370          * on if one or more of them are directories.
5371          */
5372
5373         vms_dst = PerlMem_malloc(VMS_MAXRSS);
5374         if (vms_dst == NULL)
5375             _ckvmssts_noperl(SS$_INSFMEM);
5376
5377         if (S_ISDIR(src_st.st_mode)) {
5378         char * ret_str;
5379         char * vms_dir_file;
5380
5381             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5382             if (vms_dir_file == NULL)
5383                 _ckvmssts_noperl(SS$_INSFMEM);
5384
5385             /* If the dest is a directory, we must remove it
5386             if (dst_sts == 0) {
5387                 int d_sts;
5388                 d_sts = mp_do_kill_file(NULL dst_st.st_devnam, 1);
5389                 if (d_sts != 0) {
5390                     PerlMem_free(vms_dst);
5391                     errno = EIO;
5392                     return sts;
5393                 }
5394
5395                 pre_delete = 1;
5396             }
5397
5398            /* The dest must be a VMS file specification */
5399            ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5400            if (ret_str == NULL) {
5401                 PerlMem_free(vms_dst);
5402                 errno = EIO;
5403                 return -1;
5404            }
5405
5406             /* The source must be a file specification */
5407             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5408             if (vms_dir_file == NULL)
5409                 _ckvmssts_noperl(SS$_INSFMEM);
5410
5411             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5412             if (ret_str == NULL) {
5413                 PerlMem_free(vms_dst);
5414                 PerlMem_free(vms_dir_file);
5415                 errno = EIO;
5416                 return -1;
5417             }
5418             PerlMem_free(vms_dst);
5419             vms_dst = vms_dir_file;
5420
5421         } else {
5422             /* File to file or file to new dir */
5423
5424             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5425                 /* VMS pathify a dir target */
5426                 ret_str = int_tovmspath(dst, vms_dst, NULL);
5427                 if (ret_str == NULL) {
5428                     PerlMem_free(vms_dst);
5429                     errno = EIO;
5430                     return -1;
5431                 }
5432             } else {
5433                 char * v_spec, * r_spec, * d_spec, * n_spec;
5434                 char * e_spec, * vs_spec;
5435                 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5436
5437                 /* fileify a target VMS file specification */
5438                 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5439                 if (ret_str == NULL) {
5440                     PerlMem_free(vms_dst);
5441                     errno = EIO;
5442                     return -1;
5443                 }
5444
5445                 sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len,
5446                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5447                              &e_len, &vs_spec, &vs_len);
5448                 if (sts == 0) {
5449                      if (e_len == 0) {
5450                          /* Get rid of the version */
5451                          if (vs_len != 0) {
5452                              *vs_spec = '\0';
5453                          }
5454                          /* Need to specify a '.' so that the extension */
5455                          /* is not inherited */
5456                          strcat(vms_dst,".");
5457                      }
5458                 }
5459             }
5460         }
5461
5462         old_file_dsc.dsc$a_pointer = src_st.st_devnam;
5463         old_file_dsc.dsc$w_length = strlen(src_st.st_devnam);
5464         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5465         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5466
5467         new_file_dsc.dsc$a_pointer = vms_dst;
5468         new_file_dsc.dsc$w_length = strlen(vms_dst);
5469         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5470         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5471
5472         flags = 0;
5473 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5474         flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5475 #endif
5476
5477         sts = lib$rename_file(&old_file_dsc,
5478                               &new_file_dsc,
5479                               NULL, NULL,
5480                               &flags,
5481                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5482         if (!$VMS_STATUS_SUCCESS(sts)) {
5483
5484            /* We could have failed because VMS style permissions do not
5485             * permit renames that UNIX will allow.  Just like the hack
5486             * in for kill_file.
5487             */
5488            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5489         }
5490
5491         PerlMem_free(vms_dst);
5492         if (!$VMS_STATUS_SUCCESS(sts)) {
5493             errno = EIO;
5494             return -1;
5495         }
5496         retval = 0;
5497     }
5498
5499     if (vms_unlink_all_versions) {
5500         /* Now get rid of any previous versions of the source file that
5501          * might still exist
5502          */
5503         int i = 0;
5504         dSAVEDERRNO;
5505         SAVE_ERRNO;
5506         src_sts = mp_do_kill_file(NULL, src_st.st_devnam,
5507                                    S_ISDIR(src_st.st_mode));
5508         while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) {
5509              src_sts = mp_do_kill_file(NULL, src_st.st_devnam,
5510                                        S_ISDIR(src_st.st_mode));
5511              if (src_sts != 0)
5512                  break;
5513              i++;
5514
5515              /* Make sure that we do not loop forever */
5516              if (i > 32767) {
5517                  src_sts = -1;
5518                  break;
5519              }
5520         }
5521         RESTORE_ERRNO;
5522     }
5523
5524     /* We deleted the destination, so must force the error to be EIO */
5525     if ((retval != 0) && (pre_delete != 0))
5526         errno = EIO;
5527
5528     return retval;
5529 }
5530 /*}}}*/
5531
5532
5533 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5534 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5535  * to expand file specification.  Allows for a single default file
5536  * specification and a simple mask of options.  If outbuf is non-NULL,
5537  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5538  * the resultant file specification is placed.  If outbuf is NULL, the
5539  * resultant file specification is placed into a static buffer.
5540  * The third argument, if non-NULL, is taken to be a default file
5541  * specification string.  The fourth argument is unused at present.
5542  * rmesexpand() returns the address of the resultant string if
5543  * successful, and NULL on error.
5544  *
5545  * New functionality for previously unused opts value:
5546  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5547  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5548  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5549  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5550  */
5551 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5552
5553 static char *
5554 int_rmsexpand
5555    (const char *filespec,
5556     char *outbuf,
5557     const char *defspec,
5558     unsigned opts,
5559     int * fs_utf8,
5560     int * dfs_utf8)
5561 {
5562   char * ret_spec;
5563   const char * in_spec;
5564   char * spec_buf;
5565   const char * def_spec;
5566   char * vmsfspec, *vmsdefspec;
5567   char * esa;
5568   char * esal = NULL;
5569   char * outbufl;
5570   struct FAB myfab = cc$rms_fab;
5571   rms_setup_nam(mynam);
5572   STRLEN speclen;
5573   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5574   int sts;
5575
5576   /* temp hack until UTF8 is actually implemented */
5577   if (fs_utf8 != NULL)
5578     *fs_utf8 = 0;
5579
5580   if (!filespec || !*filespec) {
5581     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5582     return NULL;
5583   }
5584
5585   vmsfspec = NULL;
5586   vmsdefspec = NULL;
5587   outbufl = NULL;
5588
5589   in_spec = filespec;
5590   isunix = 0;
5591   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5592       char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5593       int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5594
5595       /* If this is a UNIX file spec, convert it to VMS */
5596       sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5597                            &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5598                            &e_len, &vs_spec, &vs_len);
5599       if (sts != 0) {
5600           isunix = 1;
5601           char * ret_spec;
5602
5603           vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5604           if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5605           ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5606           if (ret_spec == NULL) {
5607               PerlMem_free(vmsfspec);
5608               return NULL;
5609           }
5610           in_spec = (const char *)vmsfspec;
5611
5612           /* Unless we are forcing to VMS format, a UNIX input means
5613            * UNIX output, and that requires long names to be used
5614            */
5615           if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5616 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5617               opts |= PERL_RMSEXPAND_M_LONG;
5618 #endif
5619           else
5620               isunix = 0;
5621       }
5622
5623   }
5624
5625   rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
5626   rms_bind_fab_nam(myfab, mynam);
5627
5628   /* Process the default file specification if present */
5629   def_spec = defspec;
5630   if (defspec && *defspec) {
5631     int t_isunix;
5632     t_isunix = is_unix_filespec(defspec);
5633     if (t_isunix) {
5634       vmsdefspec = PerlMem_malloc(VMS_MAXRSS);
5635       if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5636       ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5637
5638       if (ret_spec == NULL) {
5639           /* Clean up and bail */
5640           PerlMem_free(vmsdefspec);
5641           if (vmsfspec != NULL)
5642               PerlMem_free(vmsfspec);
5643               return NULL;
5644           }
5645           def_spec = (const char *)vmsdefspec;
5646       }
5647       rms_set_dna(myfab, mynam,
5648                   (char *)def_spec, strlen(def_spec)); /* cast ok */
5649   }
5650
5651   /* Now we need the expansion buffers */
5652   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5653   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5654 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5655   esal = PerlMem_malloc(VMS_MAXRSS);
5656   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5657 #endif
5658   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5659
5660   /* If a NAML block is used RMS always writes to the long and short
5661    * addresses unless you suppress the short name.
5662    */
5663 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5664   outbufl = PerlMem_malloc(VMS_MAXRSS);
5665   if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5666 #endif
5667    rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5668
5669 #ifdef NAM$M_NO_SHORT_UPCASE
5670   if (decc_efs_case_preserve)
5671     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5672 #endif
5673
5674    /* We may not want to follow symbolic links */
5675 #ifdef NAML$M_OPEN_SPECIAL
5676   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5677     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5678 #endif
5679
5680   /* First attempt to parse as an existing file */
5681   retsts = sys$parse(&myfab,0,0);
5682   if (!(retsts & STS$K_SUCCESS)) {
5683
5684     /* Could not find the file, try as syntax only if error is not fatal */
5685     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5686     if (retsts == RMS$_DNF ||
5687         retsts == RMS$_DIR ||
5688         retsts == RMS$_DEV ||
5689         retsts == RMS$_PRV) {
5690       retsts = sys$parse(&myfab,0,0);
5691       if (retsts & STS$K_SUCCESS) goto int_expanded;
5692     }
5693
5694      /* Still could not parse the file specification */
5695     /*----------------------------------------------*/
5696     sts = rms_free_search_context(&myfab); /* Free search context */
5697     if (vmsdefspec != NULL)
5698         PerlMem_free(vmsdefspec);
5699     if (vmsfspec != NULL)
5700         PerlMem_free(vmsfspec);
5701     if (outbufl != NULL)
5702         PerlMem_free(outbufl);
5703     PerlMem_free(esa);
5704     if (esal != NULL)
5705         PerlMem_free(esal);
5706     set_vaxc_errno(retsts);
5707     if      (retsts == RMS$_PRV) set_errno(EACCES);
5708     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5709     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5710     else                         set_errno(EVMSERR);
5711     return NULL;
5712   }
5713   retsts = sys$search(&myfab,0,0);
5714   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5715     sts = rms_free_search_context(&myfab); /* Free search context */
5716     if (vmsdefspec != NULL)
5717         PerlMem_free(vmsdefspec);
5718     if (vmsfspec != NULL)
5719         PerlMem_free(vmsfspec);
5720     if (outbufl != NULL)
5721         PerlMem_free(outbufl);
5722     PerlMem_free(esa);
5723     if (esal != NULL)
5724         PerlMem_free(esal);
5725     set_vaxc_errno(retsts);
5726     if      (retsts == RMS$_PRV) set_errno(EACCES);
5727     else                         set_errno(EVMSERR);
5728     return NULL;
5729   }
5730
5731   /* If the input filespec contained any lowercase characters,
5732    * downcase the result for compatibility with Unix-minded code. */
5733 int_expanded:
5734   if (!decc_efs_case_preserve) {
5735     char * tbuf;
5736     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5737       if (islower(*tbuf)) { haslower = 1; break; }
5738   }
5739
5740    /* Is a long or a short name expected */
5741   /*------------------------------------*/
5742   spec_buf = NULL;
5743   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5744     if (rms_nam_rsll(mynam)) {
5745         spec_buf = outbufl;
5746         speclen = rms_nam_rsll(mynam);
5747     }
5748     else {
5749         spec_buf = esal; /* Not esa */
5750         speclen = rms_nam_esll(mynam);
5751     }
5752   }
5753   else {
5754     if (rms_nam_rsl(mynam)) {
5755         spec_buf = outbuf;
5756         speclen = rms_nam_rsl(mynam);
5757     }
5758     else {
5759         spec_buf = esa; /* Not esal */
5760         speclen = rms_nam_esl(mynam);
5761     }
5762   }
5763   spec_buf[speclen] = '\0';
5764
5765   /* Trim off null fields added by $PARSE
5766    * If type > 1 char, must have been specified in original or default spec
5767    * (not true for version; $SEARCH may have added version of existing file).
5768    */
5769   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5770   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5771     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5772              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5773   }
5774   else {
5775     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5776              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5777   }
5778   if (trimver || trimtype) {
5779     if (defspec && *defspec) {
5780       char *defesal = NULL;
5781       char *defesa = NULL;
5782       defesa = PerlMem_malloc(VMS_MAXRSS + 1);
5783       if (defesa != NULL) {
5784         struct FAB deffab = cc$rms_fab;
5785 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5786         defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5787         if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5788 #endif
5789         rms_setup_nam(defnam);
5790
5791         rms_bind_fab_nam(deffab, defnam);
5792
5793         /* Cast ok */
5794         rms_set_fna
5795             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5796
5797         /* RMS needs the esa/esal as a work area if wildcards are involved */
5798         rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5799
5800         rms_clear_nam_nop(defnam);
5801         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5802 #ifdef NAM$M_NO_SHORT_UPCASE
5803         if (decc_efs_case_preserve)
5804           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5805 #endif
5806 #ifdef NAML$M_OPEN_SPECIAL
5807         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5808           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5809 #endif
5810         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5811           if (trimver) {
5812              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5813           }
5814           if (trimtype) {
5815             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5816           }
5817         }
5818         if (defesal != NULL)
5819             PerlMem_free(defesal);
5820         PerlMem_free(defesa);
5821       } else {
5822           _ckvmssts_noperl(SS$_INSFMEM);
5823       }
5824     }
5825     if (trimver) {
5826       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5827         if (*(rms_nam_verl(mynam)) != '\"')
5828           speclen = rms_nam_verl(mynam) - spec_buf;
5829       }
5830       else {
5831         if (*(rms_nam_ver(mynam)) != '\"')
5832           speclen = rms_nam_ver(mynam) - spec_buf;
5833       }
5834     }
5835     if (trimtype) {
5836       /* If we didn't already trim version, copy down */
5837       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5838         if (speclen > rms_nam_verl(mynam) - spec_buf)
5839           memmove
5840            (rms_nam_typel(mynam),
5841             rms_nam_verl(mynam),
5842             speclen - (rms_nam_verl(mynam) - spec_buf));
5843           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5844       }
5845       else {
5846         if (speclen > rms_nam_ver(mynam) - spec_buf)
5847           memmove
5848            (rms_nam_type(mynam),
5849             rms_nam_ver(mynam),
5850             speclen - (rms_nam_ver(mynam) - spec_buf));
5851           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5852       }
5853     }
5854   }
5855
5856    /* Done with these copies of the input files */
5857   /*-------------------------------------------*/
5858   if (vmsfspec != NULL)
5859         PerlMem_free(vmsfspec);
5860   if (vmsdefspec != NULL)
5861         PerlMem_free(vmsdefspec);
5862
5863   /* If we just had a directory spec on input, $PARSE "helpfully"
5864    * adds an empty name and type for us */
5865 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5866   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5867     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5868         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5869         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5870       speclen = rms_nam_namel(mynam) - spec_buf;
5871   }
5872   else
5873 #endif
5874   {
5875     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5876         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5877         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5878       speclen = rms_nam_name(mynam) - spec_buf;
5879   }
5880
5881   /* Posix format specifications must have matching quotes */
5882   if (speclen < (VMS_MAXRSS - 1)) {
5883     if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5884       if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5885         spec_buf[speclen] = '\"';
5886         speclen++;
5887       }
5888     }
5889   }
5890   spec_buf[speclen] = '\0';
5891   if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
5892
5893   /* Have we been working with an expanded, but not resultant, spec? */
5894   /* Also, convert back to Unix syntax if necessary. */
5895   {
5896   int rsl;
5897
5898 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5899     if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5900       rsl = rms_nam_rsll(mynam);
5901     } else
5902 #endif
5903     {
5904       rsl = rms_nam_rsl(mynam);
5905     }
5906     if (!rsl) {
5907       /* rsl is not present, it means that spec_buf is either */
5908       /* esa or esal, and needs to be copied to outbuf */
5909       /* convert to Unix if desired */
5910       if (isunix) {
5911         ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5912       } else {
5913         /* VMS file specs are not in UTF-8 */
5914         if (fs_utf8 != NULL)
5915             *fs_utf8 = 0;
5916         strcpy(outbuf, spec_buf);
5917         ret_spec = outbuf;
5918       }
5919     }
5920     else {
5921       /* Now spec_buf is either outbuf or outbufl */
5922       /* We need the result into outbuf */
5923       if (isunix) {
5924            /* If we need this in UNIX, then we need another buffer */
5925            /* to keep things in order */
5926            char * src;
5927            char * new_src = NULL;
5928            if (spec_buf == outbuf) {
5929                new_src = PerlMem_malloc(VMS_MAXRSS);
5930                strcpy(new_src, spec_buf);
5931            } else {
5932                src = spec_buf;
5933            }
5934            ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5935            if (new_src) {
5936                PerlMem_free(new_src);
5937            }
5938       } else {
5939            /* VMS file specs are not in UTF-8 */
5940            if (fs_utf8 != NULL)
5941                *fs_utf8 = 0;
5942
5943            /* Copy the buffer if needed */
5944            if (outbuf != spec_buf)
5945                strcpy(outbuf, spec_buf);
5946            ret_spec = outbuf;
5947       }
5948     }
5949   }
5950
5951   /* Need to clean up the search context */
5952   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5953   sts = rms_free_search_context(&myfab); /* Free search context */
5954
5955   /* Clean up the extra buffers */
5956   if (esal != NULL)
5957       PerlMem_free(esal);
5958   PerlMem_free(esa);
5959   if (outbufl != NULL)
5960      PerlMem_free(outbufl);
5961
5962   /* Return the result */
5963   return ret_spec;
5964 }
5965
5966 /* Common simple case - Expand an already VMS spec */
5967 static char *
5968 int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5969     opts |= PERL_RMSEXPAND_M_VMS_IN;
5970     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5971 }
5972
5973 /* Common simple case - Expand to a VMS spec */
5974 static char *
5975 int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5976     opts |= PERL_RMSEXPAND_M_VMS;
5977     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5978 }
5979
5980
5981 /* Entry point used by perl routines */
5982 static char *
5983 mp_do_rmsexpand
5984    (pTHX_ const char *filespec,
5985     char *outbuf,
5986     int ts,
5987     const char *defspec,
5988     unsigned opts,
5989     int * fs_utf8,
5990     int * dfs_utf8)
5991 {
5992     static char __rmsexpand_retbuf[VMS_MAXRSS];
5993     char * expanded, *ret_spec, *ret_buf;
5994
5995     expanded = NULL;
5996     ret_buf = outbuf;
5997     if (ret_buf == NULL) {
5998         if (ts) {
5999             Newx(expanded, VMS_MAXRSS, char);
6000             if (expanded == NULL)
6001                 _ckvmssts(SS$_INSFMEM);
6002             ret_buf = expanded;
6003         } else {
6004             ret_buf = __rmsexpand_retbuf;
6005         }
6006     }
6007
6008
6009     ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
6010                              opts, fs_utf8,  dfs_utf8);
6011
6012     if (ret_spec == NULL) {
6013        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6014        if (expanded)
6015            Safefree(expanded);
6016     }
6017
6018     return ret_spec;
6019 }
6020 /*}}}*/
6021 /* External entry points */
6022 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
6023 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
6024 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
6025 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
6026 char *Perl_rmsexpand_utf8
6027   (pTHX_ const char *spec, char *buf, const char *def,
6028    unsigned opt, int * fs_utf8, int * dfs_utf8)
6029 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
6030 char *Perl_rmsexpand_utf8_ts
6031   (pTHX_ const char *spec, char *buf, const char *def,
6032    unsigned opt, int * fs_utf8, int * dfs_utf8)
6033 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
6034
6035
6036 /*
6037 ** The following routines are provided to make life easier when
6038 ** converting among VMS-style and Unix-style directory specifications.
6039 ** All will take input specifications in either VMS or Unix syntax. On
6040 ** failure, all return NULL.  If successful, the routines listed below
6041 ** return a pointer to a buffer containing the appropriately
6042 ** reformatted spec (and, therefore, subsequent calls to that routine
6043 ** will clobber the result), while the routines of the same names with
6044 ** a _ts suffix appended will return a pointer to a mallocd string
6045 ** containing the appropriately reformatted spec.
6046 ** In all cases, only explicit syntax is altered; no check is made that
6047 ** the resulting string is valid or that the directory in question
6048 ** actually exists.
6049 **
6050 **   fileify_dirspec() - convert a directory spec into the name of the
6051 **     directory file (i.e. what you can stat() to see if it's a dir).
6052 **     The style (VMS or Unix) of the result is the same as the style
6053 **     of the parameter passed in.
6054 **   pathify_dirspec() - convert a directory spec into a path (i.e.
6055 **     what you prepend to a filename to indicate what directory it's in).
6056 **     The style (VMS or Unix) of the result is the same as the style
6057 **     of the parameter passed in.
6058 **   tounixpath() - convert a directory spec into a Unix-style path.
6059 **   tovmspath() - convert a directory spec into a VMS-style path.
6060 **   tounixspec() - convert any file spec into a Unix-style file spec.
6061 **   tovmsspec() - convert any file spec into a VMS-style spec.
6062 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
6063 **
6064 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
6065 ** Permission is given to distribute this code as part of the Perl
6066 ** standard distribution under the terms of the GNU General Public
6067 ** License or the Perl Artistic License.  Copies of each may be
6068 ** found in the Perl standard distribution.
6069  */
6070
6071 /*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6072 static char *
6073 int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
6074 {
6075     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
6076     char *cp1, *cp2, *lastdir;
6077     char *trndir, *vmsdir;
6078     unsigned short int trnlnm_iter_count;
6079     int is_vms = 0;
6080     int is_unix = 0;
6081     int sts;
6082     if (utf8_fl != NULL)
6083         *utf8_fl = 0;
6084
6085     if (!dir || !*dir) {
6086       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6087     }
6088     dirlen = strlen(dir);
6089     while (dirlen && dir[dirlen-1] == '/') --dirlen;
6090     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
6091       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
6092         dir = "/sys$disk";
6093         dirlen = 9;
6094       }
6095       else
6096         dirlen = 1;
6097     }
6098     if (dirlen > (VMS_MAXRSS - 1)) {
6099       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
6100       return NULL;
6101     }
6102     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
6103     if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6104     if (!strpbrk(dir+1,"/]>:")  &&
6105         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
6106       strcpy(trndir,*dir == '/' ? dir + 1: dir);
6107       trnlnm_iter_count = 0;
6108       while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
6109         trnlnm_iter_count++;
6110         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6111       }
6112       dirlen = strlen(trndir);
6113     }
6114     else {
6115       strncpy(trndir,dir,dirlen);
6116       trndir[dirlen] = '\0';
6117     }
6118
6119     /* At this point we are done with *dir and use *trndir which is a
6120      * copy that can be modified.  *dir must not be modified.
6121      */
6122
6123     /* If we were handed a rooted logical name or spec, treat it like a
6124      * simple directory, so that
6125      *    $ Define myroot dev:[dir.]
6126      *    ... do_fileify_dirspec("myroot",buf,1) ...
6127      * does something useful.
6128      */
6129     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
6130       trndir[--dirlen] = '\0';
6131       trndir[dirlen-1] = ']';
6132     }
6133     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
6134       trndir[--dirlen] = '\0';
6135       trndir[dirlen-1] = '>';
6136     }
6137
6138     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
6139       /* If we've got an explicit filename, we can just shuffle the string. */
6140       if (*(cp1+1)) hasfilename = 1;
6141       /* Similarly, we can just back up a level if we've got multiple levels
6142          of explicit directories in a VMS spec which ends with directories. */
6143       else {
6144         for (cp2 = cp1; cp2 > trndir; cp2--) {
6145           if (*cp2 == '.') {
6146             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
6147 /* fix-me, can not scan EFS file specs backward like this */
6148               *cp2 = *cp1; *cp1 = '\0';
6149               hasfilename = 1;
6150               break;
6151             }
6152           }
6153           if (*cp2 == '[' || *cp2 == '<') break;
6154         }
6155       }
6156     }
6157
6158     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
6159     if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6160     cp1 = strpbrk(trndir,"]:>");
6161     if (hasfilename || !cp1) { /* filename present or not VMS */
6162
6163       if (decc_efs_charset && !cp1) {
6164
6165           /* EFS handling for UNIX mode */
6166
6167           /* Just remove the trailing '/' and we should be done */
6168           STRLEN trndir_len;
6169           trndir_len = strlen(trndir);
6170
6171           if (trndir_len > 1) {
6172               trndir_len--;
6173               if (trndir[trndir_len] == '/') {
6174                   trndir[trndir_len] = '\0';
6175               }
6176           }
6177           strcpy(buf, trndir);
6178           PerlMem_free(trndir);
6179           PerlMem_free(vmsdir);
6180           return buf;
6181       }
6182
6183       /* For non-EFS mode, this is left for backwards compatibility */
6184       /* For EFS mode, this is only done for VMS format filespecs as */
6185       /* Perl programs generally have problems when a UNIX format spec */
6186       /* returns a VMS format spec */
6187       if (trndir[0] == '.') {
6188         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
6189           PerlMem_free(trndir);
6190           PerlMem_free(vmsdir);
6191           return int_fileify_dirspec("[]", buf, NULL);
6192         }
6193         else if (trndir[1] == '.' &&
6194                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
6195           PerlMem_free(trndir);
6196           PerlMem_free(vmsdir);
6197           return int_fileify_dirspec("[-]", buf, NULL);
6198         }
6199       }
6200       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
6201         dirlen -= 1;                 /* to last element */
6202         lastdir = strrchr(trndir,'/');
6203       }
6204       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
6205         /* If we have "/." or "/..", VMSify it and let the VMS code
6206          * below expand it, rather than repeating the code to handle
6207          * relative components of a filespec here */
6208         do {
6209           if (*(cp1+2) == '.') cp1++;
6210           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
6211             char * ret_chr;
6212             if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
6213                 PerlMem_free(trndir);
6214                 PerlMem_free(vmsdir);
6215                 return NULL;
6216             }
6217             if (strchr(vmsdir,'/') != NULL) {
6218               /* If int_tovmsspec() returned it, it must have VMS syntax
6219                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
6220                * the time to check this here only so we avoid a recursion
6221                * loop; otherwise, gigo.
6222                */
6223               PerlMem_free(trndir);
6224               PerlMem_free(vmsdir);
6225               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
6226               return NULL;
6227             }
6228             if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6229                 PerlMem_free(trndir);
6230                 PerlMem_free(vmsdir);
6231                 return NULL;
6232             }
6233             ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6234             PerlMem_free(trndir);
6235             PerlMem_free(vmsdir);
6236             return ret_chr;
6237           }
6238           cp1++;
6239         } while ((cp1 = strstr(cp1,"/.")) != NULL);
6240         lastdir = strrchr(trndir,'/');
6241       }
6242       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
6243         char * ret_chr;
6244         /* Ditto for specs that end in an MFD -- let the VMS code
6245          * figure out whether it's a real device or a rooted logical. */
6246
6247         /* This should not happen any more.  Allowing the fake /000000
6248          * in a UNIX pathname causes all sorts of problems when trying
6249          * to run in UNIX emulation.  So the VMS to UNIX conversions
6250          * now remove the fake /000000 directories.
6251          */
6252
6253         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6254         if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6255             PerlMem_free(trndir);
6256             PerlMem_free(vmsdir);
6257             return NULL;
6258         }
6259         if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6260             PerlMem_free(trndir);
6261             PerlMem_free(vmsdir);
6262             return NULL;
6263         }
6264         ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6265         PerlMem_free(trndir);
6266         PerlMem_free(vmsdir);
6267         return ret_chr;
6268       }
6269       else {
6270
6271         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6272              !(lastdir = cp1 = strrchr(trndir,']')) &&
6273              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6274
6275         cp2 = strrchr(cp1,'.');
6276         if (cp2) {
6277             int e_len, vs_len = 0;
6278             int is_dir = 0;
6279             char * cp3;
6280             cp3 = strchr(cp2,';');
6281             e_len = strlen(cp2);
6282             if (cp3) {
6283                 vs_len = strlen(cp3);
6284                 e_len = e_len - vs_len;
6285             }
6286             is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6287             if (!is_dir) {
6288                 if (!decc_efs_charset) {
6289                     /* If this is not EFS, then not a directory */
6290                     PerlMem_free(trndir);
6291                     PerlMem_free(vmsdir);
6292                     set_errno(ENOTDIR);
6293                     set_vaxc_errno(RMS$_DIR);
6294                     return NULL;
6295                 }
6296             } else {
6297                 /* Ok, here we have an issue, technically if a .dir shows */
6298                 /* from inside a directory, then we should treat it as */
6299                 /* xxx^.dir.dir.  But we do not have that context at this */
6300                 /* point unless this is totally restructured, so we remove */
6301                 /* The .dir for now, and fix this better later */
6302                 dirlen = cp2 - trndir;
6303             }
6304         }
6305
6306       }
6307
6308       retlen = dirlen + 6;
6309       memcpy(buf, trndir, dirlen);
6310       buf[dirlen] = '\0';
6311
6312       /* We've picked up everything up to the directory file name.
6313          Now just add the type and version, and we're set. */
6314
6315       /* We should only add type for VMS syntax, but historically Perl
6316          has added it for UNIX style also */
6317
6318       /* Fix me - we should not be using the same routine for VMS and
6319          UNIX format files.  Things are too tangled so we need to lookup
6320          what syntax the output is */
6321
6322       is_unix = 0;
6323       is_vms = 0;
6324       lastdir = strrchr(trndir,'/');
6325       if (lastdir) {
6326           is_unix = 1;
6327       } else {
6328           lastdir = strpbrk(trndir,"]:>");
6329           if (lastdir) {
6330               is_vms = 1;
6331           }
6332       }
6333
6334       if ((is_vms == 0) && (is_unix == 0)) {
6335           /* We still do not  know? */
6336           is_unix = decc_filename_unix_report;
6337           if (is_unix == 0)
6338               is_vms = 1;
6339       }
6340
6341       if ((is_unix && !decc_efs_charset) || is_vms) {
6342
6343            /* It is a bug to add a .dir to a UNIX format directory spec */
6344            /* However Perl on VMS may have programs that expect this so */
6345            /* If not using EFS character specifications allow it. */
6346
6347            if ((!decc_efs_case_preserve) && vms_process_case_tolerant) {
6348                /* Traditionally Perl expects filenames in lower case */
6349                strcat(buf, ".dir");
6350            } else {
6351                /* VMS expects the .DIR to be in upper case */
6352                strcat(buf, ".DIR");
6353            }
6354
6355            /* It is also a bug to put a VMS format version on a UNIX file */
6356            /* specification.  Perl self tests are looking for this */
6357            if (is_vms || !(decc_efs_charset || decc_filename_unix_report))
6358                strcat(buf, ";1");
6359       }
6360       PerlMem_free(trndir);
6361       PerlMem_free(vmsdir);
6362       return buf;
6363     }
6364     else {  /* VMS-style directory spec */
6365
6366       char *esa, *esal, term, *cp;
6367       char *my_esa;
6368       int my_esa_len;
6369       unsigned long int sts, cmplen, haslower = 0;
6370       unsigned int nam_fnb;
6371       char * nam_type;
6372       struct FAB dirfab = cc$rms_fab;
6373       rms_setup_nam(savnam);
6374       rms_setup_nam(dirnam);
6375
6376       esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6377       if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6378       esal = NULL;
6379 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6380       esal = PerlMem_malloc(VMS_MAXRSS);
6381       if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6382 #endif
6383       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6384       rms_bind_fab_nam(dirfab, dirnam);
6385       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6386       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6387 #ifdef NAM$M_NO_SHORT_UPCASE
6388       if (decc_efs_case_preserve)
6389         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6390 #endif
6391
6392       for (cp = trndir; *cp; cp++)
6393         if (islower(*cp)) { haslower = 1; break; }
6394       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6395         if ((dirfab.fab$l_sts == RMS$_DIR) ||
6396             (dirfab.fab$l_sts == RMS$_DNF) ||
6397             (dirfab.fab$l_sts == RMS$_PRV)) {
6398             rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6399             sts = sys$parse(&dirfab);
6400         }
6401         if (!sts) {
6402           PerlMem_free(esa);
6403           if (esal != NULL)
6404               PerlMem_free(esal);
6405           PerlMem_free(trndir);
6406           PerlMem_free(vmsdir);
6407           set_errno(EVMSERR);
6408           set_vaxc_errno(dirfab.fab$l_sts);
6409           return NULL;
6410         }
6411       }
6412       else {
6413         savnam = dirnam;
6414         /* Does the file really exist? */
6415         if (sys$search(&dirfab)& STS$K_SUCCESS) {
6416           /* Yes; fake the fnb bits so we'll check type below */
6417           rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6418         }
6419         else { /* No; just work with potential name */
6420           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6421           else {
6422             int fab_sts;
6423             fab_sts = dirfab.fab$l_sts;
6424             sts = rms_free_search_context(&dirfab);
6425             PerlMem_free(esa);
6426             if (esal != NULL)
6427                 PerlMem_free(esal);
6428             PerlMem_free(trndir);
6429             PerlMem_free(vmsdir);
6430             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
6431             return NULL;
6432           }
6433         }
6434       }
6435
6436       /* Make sure we are using the right buffer */
6437       if (esal != NULL) {
6438         my_esa = esal;
6439         my_esa_len = rms_nam_esll(dirnam);
6440       } else {
6441         my_esa = esa;
6442         my_esa_len = rms_nam_esl(dirnam);
6443       }
6444       my_esa[my_esa_len] = '\0';
6445       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6446         cp1 = strchr(my_esa,']');
6447         if (!cp1) cp1 = strchr(my_esa,'>');
6448         if (cp1) {  /* Should always be true */
6449           my_esa_len -= cp1 - my_esa - 1;
6450           memmove(my_esa, cp1 + 1, my_esa_len);
6451         }
6452       }
6453       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6454         /* Yep; check version while we're at it, if it's there. */
6455         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6456         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6457           /* Something other than .DIR[;1].  Bzzt. */
6458           sts = rms_free_search_context(&dirfab);
6459           PerlMem_free(esa);
6460           if (esal != NULL)
6461              PerlMem_free(esal);
6462           PerlMem_free(trndir);
6463           PerlMem_free(vmsdir);
6464           set_errno(ENOTDIR);
6465           set_vaxc_errno(RMS$_DIR);
6466           return NULL;
6467         }
6468       }
6469
6470       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6471         /* They provided at least the name; we added the type, if necessary, */
6472         strcpy(buf, my_esa);
6473         sts = rms_free_search_context(&dirfab);
6474         PerlMem_free(trndir);
6475         PerlMem_free(esa);
6476         if (esal != NULL)
6477             PerlMem_free(esal);
6478         PerlMem_free(vmsdir);
6479         return buf;
6480       }
6481       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6482         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6483         *cp1 = '\0';
6484         my_esa_len -= 9;
6485       }
6486       if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6487       if (cp1 == NULL) { /* should never happen */
6488         sts = rms_free_search_context(&dirfab);
6489         PerlMem_free(trndir);
6490         PerlMem_free(esa);
6491         if (esal != NULL)
6492             PerlMem_free(esal);
6493         PerlMem_free(vmsdir);
6494         return NULL;
6495       }
6496       term = *cp1;
6497       *cp1 = '\0';
6498       retlen = strlen(my_esa);
6499       cp1 = strrchr(my_esa,'.');
6500       /* ODS-5 directory specifications can have extra "." in them. */
6501       /* Fix-me, can not scan EFS file specifications backwards */
6502       while (cp1 != NULL) {
6503         if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6504           break;
6505         else {
6506            cp1--;
6507            while ((cp1 > my_esa) && (*cp1 != '.'))
6508              cp1--;
6509         }
6510         if (cp1 == my_esa)
6511           cp1 = NULL;
6512       }
6513
6514       if ((cp1) != NULL) {
6515         /* There's more than one directory in the path.  Just roll back. */
6516         *cp1 = term;
6517         strcpy(buf, my_esa);
6518       }
6519       else {
6520         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6521           /* Go back and expand rooted logical name */
6522           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6523 #ifdef NAM$M_NO_SHORT_UPCASE
6524           if (decc_efs_case_preserve)
6525             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6526 #endif
6527           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6528             sts = rms_free_search_context(&dirfab);
6529             PerlMem_free(esa);
6530             if (esal != NULL)
6531                 PerlMem_free(esal);
6532             PerlMem_free(trndir);
6533             PerlMem_free(vmsdir);
6534             set_errno(EVMSERR);
6535             set_vaxc_errno(dirfab.fab$l_sts);
6536             return NULL;
6537           }
6538
6539           /* This changes the length of the string of course */
6540           if (esal != NULL) {
6541               my_esa_len = rms_nam_esll(dirnam);
6542           } else {
6543               my_esa_len = rms_nam_esl(dirnam);
6544           }
6545
6546           retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6547           cp1 = strstr(my_esa,"][");
6548           if (!cp1) cp1 = strstr(my_esa,"]<");
6549           dirlen = cp1 - my_esa;
6550           memcpy(buf, my_esa, dirlen);
6551           if (!strncmp(cp1+2,"000000]",7)) {
6552             buf[dirlen-1] = '\0';
6553             /* fix-me Not full ODS-5, just extra dots in directories for now */
6554             cp1 = buf + dirlen - 1;
6555             while (cp1 > buf)
6556             {
6557               if (*cp1 == '[')
6558                 break;
6559               if (*cp1 == '.') {
6560                 if (*(cp1-1) != '^')
6561                   break;
6562               }
6563               cp1--;
6564             }
6565             if (*cp1 == '.') *cp1 = ']';
6566             else {
6567               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6568               memmove(cp1+1,"000000]",7);
6569             }
6570           }
6571           else {
6572             memmove(buf+dirlen, cp1+2, retlen-dirlen);
6573             buf[retlen] = '\0';
6574             /* Convert last '.' to ']' */
6575             cp1 = buf+retlen-1;
6576             while (*cp != '[') {
6577               cp1--;
6578               if (*cp1 == '.') {
6579                 /* Do not trip on extra dots in ODS-5 directories */
6580                 if ((cp1 == buf) || (*(cp1-1) != '^'))
6581                 break;
6582               }
6583             }
6584             if (*cp1 == '.') *cp1 = ']';
6585             else {
6586               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6587               memmove(cp1+1,"000000]",7);
6588             }
6589           }
6590         }
6591         else {  /* This is a top-level dir.  Add the MFD to the path. */
6592           cp1 = my_esa;
6593           cp2 = buf;
6594           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6595           strcpy(cp2,":[000000]");
6596           cp1 += 2;
6597           strcpy(cp2+9,cp1);
6598         }
6599       }
6600       sts = rms_free_search_context(&dirfab);
6601       /* We've set up the string up through the filename.  Add the
6602          type and version, and we're done. */
6603       strcat(buf,".DIR;1");
6604
6605       /* $PARSE may have upcased filespec, so convert output to lower
6606        * case if input contained any lowercase characters. */
6607       if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
6608       PerlMem_free(trndir);
6609       PerlMem_free(esa);
6610       if (esal != NULL)
6611         PerlMem_free(esal);
6612       PerlMem_free(vmsdir);
6613       return buf;
6614     }
6615 }  /* end of int_fileify_dirspec() */
6616
6617
6618 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6619 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
6620 {
6621     static char __fileify_retbuf[VMS_MAXRSS];
6622     char * fileified, *ret_spec, *ret_buf;
6623
6624     fileified = NULL;
6625     ret_buf = buf;
6626     if (ret_buf == NULL) {
6627         if (ts) {
6628             Newx(fileified, VMS_MAXRSS, char);
6629             if (fileified == NULL)
6630                 _ckvmssts(SS$_INSFMEM);
6631             ret_buf = fileified;
6632         } else {
6633             ret_buf = __fileify_retbuf;
6634         }
6635     }
6636
6637     ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6638
6639     if (ret_spec == NULL) {
6640        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6641        if (fileified)
6642            Safefree(fileified);
6643     }
6644
6645     return ret_spec;
6646 }  /* end of do_fileify_dirspec() */
6647 /*}}}*/
6648
6649 /* External entry points */
6650 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6651 { return do_fileify_dirspec(dir,buf,0,NULL); }
6652 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6653 { return do_fileify_dirspec(dir,buf,1,NULL); }
6654 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6655 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6656 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6657 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6658
6659 static char * int_pathify_dirspec_simple(const char * dir, char * buf,
6660     char * v_spec, int v_len, char * r_spec, int r_len,
6661     char * d_spec, int d_len, char * n_spec, int n_len,
6662     char * e_spec, int e_len, char * vs_spec, int vs_len) {
6663
6664     /* VMS specification - Try to do this the simple way */
6665     if ((v_len + r_len > 0) || (d_len > 0)) {
6666         int is_dir;
6667
6668         /* No name or extension component, already a directory */
6669         if ((n_len + e_len + vs_len) == 0) {
6670             strcpy(buf, dir);
6671             return buf;
6672         }
6673
6674         /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6675         /* This results from catfile() being used instead of catdir() */
6676         /* So even though it should not work, we need to allow it */
6677
6678         /* If this is .DIR;1 then do a simple conversion */
6679         is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6680         if (is_dir || (e_len == 0) && (d_len > 0)) {
6681              int len;
6682              len = v_len + r_len + d_len - 1;
6683              char dclose = d_spec[d_len - 1];
6684              strncpy(buf, dir, len);
6685              buf[len] = '.';
6686              len++;
6687              strncpy(&buf[len], n_spec, n_len);
6688              len += n_len;
6689              buf[len] = dclose;
6690              buf[len + 1] = '\0';
6691              return buf;
6692         }
6693
6694 #ifdef HAS_SYMLINK
6695         else if (d_len > 0) {
6696             /* In the olden days, a directory needed to have a .DIR */
6697             /* extension to be a valid directory, but now it could  */
6698             /* be a symbolic link */
6699             int len;
6700             len = v_len + r_len + d_len - 1;
6701             char dclose = d_spec[d_len - 1];
6702             strncpy(buf, dir, len);
6703             buf[len] = '.';
6704             len++;
6705             strncpy(&buf[len], n_spec, n_len);
6706             len += n_len;
6707             if (e_len > 0) {
6708                 if (decc_efs_charset) {
6709                     buf[len] = '^';
6710                     len++;
6711                     strncpy(&buf[len], e_spec, e_len);
6712                     len += e_len;
6713                 } else {
6714                     set_vaxc_errno(RMS$_DIR);
6715                     set_errno(ENOTDIR);
6716                     return NULL;
6717                 }
6718             }
6719             buf[len] = dclose;
6720             buf[len + 1] = '\0';
6721             return buf;
6722         }
6723 #else
6724         else {
6725             set_vaxc_errno(RMS$_DIR);
6726             set_errno(ENOTDIR);
6727             return NULL;
6728         }
6729 #endif
6730     }
6731     set_vaxc_errno(RMS$_DIR);
6732     set_errno(ENOTDIR);
6733     return NULL;
6734 }
6735
6736
6737 /* Internal routine to make sure or convert a directory to be in a */
6738 /* path specification.  No utf8 flag because it is not changed or used */
6739 static char *int_pathify_dirspec(const char *dir, char *buf)
6740 {
6741     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6742     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6743     char * exp_spec, *ret_spec;
6744     char * trndir;
6745     unsigned short int trnlnm_iter_count;
6746     STRLEN trnlen;
6747     int need_to_lower;
6748
6749     if (vms_debug_fileify) {
6750         if (dir == NULL)
6751             fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6752         else
6753             fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6754     }
6755
6756     /* We may need to lower case the result if we translated  */
6757     /* a logical name or got the current working directory */
6758     need_to_lower = 0;
6759
6760     if (!dir || !*dir) {
6761       set_errno(EINVAL);
6762       set_vaxc_errno(SS$_BADPARAM);
6763       return NULL;
6764     }
6765
6766     trndir = PerlMem_malloc(VMS_MAXRSS);
6767     if (trndir == NULL)
6768         _ckvmssts_noperl(SS$_INSFMEM);
6769
6770     /* If no directory specified use the current default */
6771     if (*dir)
6772         strcpy(trndir, dir);
6773     else {
6774         getcwd(trndir, VMS_MAXRSS - 1);
6775         need_to_lower = 1;
6776     }
6777
6778     /* now deal with bare names that could be logical names */
6779     trnlnm_iter_count = 0;
6780     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6781            && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6782         trnlnm_iter_count++;
6783         need_to_lower = 1;
6784         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6785             break;
6786         trnlen = strlen(trndir);
6787
6788         /* Trap simple rooted lnms, and return lnm:[000000] */
6789         if (!strcmp(trndir+trnlen-2,".]")) {
6790             strcpy(buf, dir);
6791             strcat(buf, ":[000000]");
6792             PerlMem_free(trndir);
6793
6794             if (vms_debug_fileify) {
6795                 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6796             }
6797             return buf;
6798         }
6799     }
6800
6801     /* At this point we do not work with *dir, but the copy in  *trndir */
6802
6803     if (need_to_lower && !decc_efs_case_preserve) {
6804         /* Legacy mode, lower case the returned value */
6805         __mystrtolower(trndir);
6806     }
6807
6808
6809     /* Some special cases, '..', '.' */
6810     sts = 0;
6811     if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6812        /* Force UNIX filespec */
6813        sts = 1;
6814
6815     } else {
6816         /* Is this Unix or VMS format? */
6817         sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6818                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6819                              &e_len, &vs_spec, &vs_len);
6820         if (sts == 0) {
6821
6822             /* Just a filename? */
6823             if ((v_len + r_len + d_len) == 0) {
6824
6825                 /* Now we have a problem, this could be Unix or VMS */
6826                 /* We have to guess.  .DIR usually means VMS */
6827
6828                 /* In UNIX report mode, the .DIR extension is removed */
6829                 /* if one shows up, it is for a non-directory or a directory */
6830                 /* in EFS charset mode */
6831
6832                 /* So if we are in Unix report mode, assume that this */
6833                 /* is a relative Unix directory specification */
6834
6835                 sts = 1;
6836                 if (!decc_filename_unix_report && decc_efs_charset) {
6837                     int is_dir;
6838                     is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6839
6840                     if (is_dir) {
6841                         /* Traditional mode, assume .DIR is directory */
6842                         buf[0] = '[';
6843                         buf[1] = '.';
6844                         strncpy(&buf[2], n_spec, n_len);
6845                         buf[n_len + 2] = ']';
6846                         buf[n_len + 3] = '\0';
6847                         PerlMem_free(trndir);
6848                         if (vms_debug_fileify) {
6849                             fprintf(stderr,
6850                                     "int_pathify_dirspec: buf = %s\n",
6851                                     buf);
6852                         }
6853                         return buf;
6854                     }
6855                 }
6856             }
6857         }
6858     }
6859     if (sts == 0) {
6860         ret_spec = int_pathify_dirspec_simple(trndir, buf,
6861             v_spec, v_len, r_spec, r_len,
6862             d_spec, d_len, n_spec, n_len,
6863             e_spec, e_len, vs_spec, vs_len);
6864
6865         if (ret_spec != NULL) {
6866             PerlMem_free(trndir);
6867             if (vms_debug_fileify) {
6868                 fprintf(stderr,
6869                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6870             }
6871             return ret_spec;
6872         }
6873
6874         /* Simple way did not work, which means that a logical name */
6875         /* was present for the directory specification.             */
6876         /* Need to use an rmsexpand variant to decode it completely */
6877         exp_spec = PerlMem_malloc(VMS_MAXRSS);
6878         if (exp_spec == NULL)
6879             _ckvmssts_noperl(SS$_INSFMEM);
6880
6881         ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6882         if (ret_spec != NULL) {
6883             sts = vms_split_path(exp_spec, &v_spec, &v_len,
6884                                  &r_spec, &r_len, &d_spec, &d_len,
6885                                  &n_spec, &n_len, &e_spec,
6886                                  &e_len, &vs_spec, &vs_len);
6887             if (sts == 0) {
6888                 ret_spec = int_pathify_dirspec_simple(
6889                     exp_spec, buf, v_spec, v_len, r_spec, r_len,
6890                     d_spec, d_len, n_spec, n_len,
6891                     e_spec, e_len, vs_spec, vs_len);
6892
6893                 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6894                     /* Legacy mode, lower case the returned value */
6895                     __mystrtolower(ret_spec);
6896                 }
6897             } else {
6898                 set_vaxc_errno(RMS$_DIR);
6899                 set_errno(ENOTDIR);
6900                 ret_spec = NULL;
6901             }
6902         }
6903         PerlMem_free(exp_spec);
6904         PerlMem_free(trndir);
6905         if (vms_debug_fileify) {
6906             if (ret_spec == NULL)
6907                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6908             else
6909                 fprintf(stderr,
6910                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6911         }
6912         return ret_spec;
6913
6914     } else {
6915         /* Unix specification, Could be trivial conversion */
6916         STRLEN dir_len;
6917         dir_len = strlen(trndir);
6918
6919         /* If the extended file character set is in effect */
6920         /* then pathify is simple */
6921
6922         if (!decc_efs_charset) {
6923             /* Have to deal with traiing '.dir' or extra '.' */
6924             /* that should not be there in legacy mode, but is */
6925
6926             char * lastdot;
6927             char * lastslash;
6928             int is_dir;
6929
6930             lastslash = strrchr(trndir, '/');
6931             if (lastslash == NULL)
6932                 lastslash = trndir;
6933             else
6934                 lastslash++;
6935
6936             lastdot = NULL;
6937
6938             /* '..' or '.' are valid directory components */
6939             is_dir = 0;
6940             if (lastslash[0] == '.') {
6941                 if (lastslash[1] == '\0') {
6942                    is_dir = 1;
6943                 } else if (lastslash[1] == '.') {
6944                     if (lastslash[2] == '\0') {
6945                         is_dir = 1;
6946                     } else {
6947                         /* And finally allow '...' */
6948                         if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
6949                             is_dir = 1;
6950                         }
6951                     }
6952                 }
6953             }
6954
6955             if (!is_dir) {
6956                lastdot = strrchr(lastslash, '.');
6957             }
6958             if (lastdot != NULL) {
6959                 STRLEN e_len;
6960
6961                 /* '.dir' is discarded, and any other '.' is invalid */
6962                 e_len = strlen(lastdot);
6963
6964                 is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
6965
6966                 if (is_dir) {
6967                     dir_len = dir_len - 4;
6968
6969                 }
6970             }
6971         }
6972
6973         strcpy(buf, trndir);
6974         if (buf[dir_len - 1] != '/') {
6975             buf[dir_len] = '/';
6976             buf[dir_len + 1] = '\0';
6977         }
6978
6979         /* Under ODS-2 rules, '.' becomes '_', so fix it up */
6980         if (!decc_efs_charset) {
6981              int dir_start = 0;
6982              char * str = buf;
6983              if (str[0] == '.') {
6984                  char * dots = str;
6985                  int cnt = 1;
6986                  while ((dots[cnt] == '.') && (cnt < 3))
6987                      cnt++;
6988                  if (cnt <= 3) {
6989                      if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
6990                          dir_start = 1;
6991                          str += cnt;
6992                      }
6993                  }
6994              }
6995              for (; *str; ++str) {
6996                  while (*str == '/') {
6997                      dir_start = 1;
6998                      *str++;
6999                  }
7000                  if (dir_start) {
7001
7002                      /* Have to skip up to three dots which could be */
7003                      /* directories, 3 dots being a VMS extension for Perl */
7004                      char * dots = str;
7005                      int cnt = 0;
7006                      while ((dots[cnt] == '.') && (cnt < 3)) {
7007                          cnt++;
7008                      }
7009                      if (dots[cnt] == '\0')
7010                          break;
7011                      if ((cnt > 1) && (dots[cnt] != '/')) {
7012                          dir_start = 0;
7013                      } else {
7014                          str += cnt;
7015                      }
7016
7017                      /* too many dots? */
7018                      if ((cnt == 0) || (cnt > 3)) {
7019                          dir_start = 0;
7020                      }
7021                  }
7022                  if (!dir_start && (*str == '.')) {
7023                      *str = '_';
7024                  }
7025              }
7026         }
7027         PerlMem_free(trndir);
7028         ret_spec = buf;
7029         if (vms_debug_fileify) {
7030             if (ret_spec == NULL)
7031                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
7032             else
7033                 fprintf(stderr,
7034                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
7035         }
7036         return ret_spec;
7037     }
7038 }
7039
7040 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
7041 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
7042 {
7043     static char __pathify_retbuf[VMS_MAXRSS];
7044     char * pathified, *ret_spec, *ret_buf;
7045
7046     pathified = NULL;
7047     ret_buf = buf;
7048     if (ret_buf == NULL) {
7049         if (ts) {
7050             Newx(pathified, VMS_MAXRSS, char);
7051             if (pathified == NULL)
7052                 _ckvmssts(SS$_INSFMEM);
7053             ret_buf = pathified;
7054         } else {
7055             ret_buf = __pathify_retbuf;
7056         }
7057     }
7058
7059     ret_spec = int_pathify_dirspec(dir, ret_buf);
7060
7061     if (ret_spec == NULL) {
7062        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7063        if (pathified)
7064            Safefree(pathified);
7065     }
7066
7067     return ret_spec;
7068
7069 }  /* end of do_pathify_dirspec() */
7070
7071
7072 /* External entry points */
7073 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
7074 { return do_pathify_dirspec(dir,buf,0,NULL); }
7075 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
7076 { return do_pathify_dirspec(dir,buf,1,NULL); }
7077 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
7078 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
7079 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
7080 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
7081
7082 /* Internal tounixspec routine that does not use a thread context */
7083 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
7084 static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
7085 {
7086   char *dirend, *cp1, *cp3, *tmp;
7087   const char *cp2;
7088   int devlen, dirlen, retlen = VMS_MAXRSS;
7089   int expand = 1; /* guarantee room for leading and trailing slashes */
7090   unsigned short int trnlnm_iter_count;
7091   int cmp_rslt;
7092   if (utf8_fl != NULL)
7093     *utf8_fl = 0;
7094
7095   if (vms_debug_fileify) {
7096       if (spec == NULL)
7097           fprintf(stderr, "int_tounixspec: spec = NULL\n");
7098       else
7099           fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
7100   }
7101
7102
7103   if (spec == NULL) {
7104       set_errno(EINVAL);
7105       set_vaxc_errno(SS$_BADPARAM);
7106       return NULL;
7107   }
7108   if (strlen(spec) > (VMS_MAXRSS-1)) {
7109       set_errno(E2BIG);
7110       set_vaxc_errno(SS$_BUFFEROVF);
7111       return NULL;
7112   }
7113
7114   /* New VMS specific format needs translation
7115    * glob passes filenames with trailing '\n' and expects this preserved.
7116    */
7117   if (decc_posix_compliant_pathnames) {
7118     if (strncmp(spec, "\"^UP^", 5) == 0) {
7119       char * uspec;
7120       char *tunix;
7121       int tunix_len;
7122       int nl_flag;
7123
7124       tunix = PerlMem_malloc(VMS_MAXRSS);
7125       if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7126       strcpy(tunix, spec);
7127       tunix_len = strlen(tunix);
7128       nl_flag = 0;
7129       if (tunix[tunix_len - 1] == '\n') {
7130         tunix[tunix_len - 1] = '\"';
7131         tunix[tunix_len] = '\0';
7132         tunix_len--;
7133         nl_flag = 1;
7134       }
7135       uspec = decc$translate_vms(tunix);
7136       PerlMem_free(tunix);
7137       if ((int)uspec > 0) {
7138         strcpy(rslt,uspec);
7139         if (nl_flag) {
7140           strcat(rslt,"\n");
7141         }
7142         else {
7143           /* If we can not translate it, makemaker wants as-is */
7144           strcpy(rslt, spec);
7145         }
7146         return rslt;
7147       }
7148     }
7149   }
7150
7151   cmp_rslt = 0; /* Presume VMS */
7152   cp1 = strchr(spec, '/');
7153   if (cp1 == NULL)
7154     cmp_rslt = 0;
7155
7156     /* Look for EFS ^/ */
7157     if (decc_efs_charset) {
7158       while (cp1 != NULL) {
7159         cp2 = cp1 - 1;
7160         if (*cp2 != '^') {
7161           /* Found illegal VMS, assume UNIX */
7162           cmp_rslt = 1;
7163           break;
7164         }
7165       cp1++;
7166       cp1 = strchr(cp1, '/');
7167     }
7168   }
7169
7170   /* Look for "." and ".." */
7171   if (decc_filename_unix_report) {
7172     if (spec[0] == '.') {
7173       if ((spec[1] == '\0') || (spec[1] == '\n')) {
7174         cmp_rslt = 1;
7175       }
7176       else {
7177         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
7178           cmp_rslt = 1;
7179         }
7180       }
7181     }
7182   }
7183   /* This is already UNIX or at least nothing VMS understands */
7184   if (cmp_rslt) {
7185     strcpy(rslt,spec);
7186     if (vms_debug_fileify) {
7187         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7188     }
7189     return rslt;
7190   }
7191
7192   cp1 = rslt;
7193   cp2 = spec;
7194   dirend = strrchr(spec,']');
7195   if (dirend == NULL) dirend = strrchr(spec,'>');
7196   if (dirend == NULL) dirend = strchr(spec,':');
7197   if (dirend == NULL) {
7198     strcpy(rslt,spec);
7199     if (vms_debug_fileify) {
7200         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7201     }
7202     return rslt;
7203   }
7204
7205   /* Special case 1 - sys$posix_root = / */
7206 #if __CRTL_VER >= 70000000
7207   if (!decc_disable_posix_root) {
7208     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
7209       *cp1 = '/';
7210       cp1++;
7211       cp2 = cp2 + 15;
7212       }
7213   }
7214 #endif
7215
7216   /* Special case 2 - Convert NLA0: to /dev/null */
7217 #if __CRTL_VER < 70000000
7218   cmp_rslt = strncmp(spec,"NLA0:", 5);
7219   if (cmp_rslt != 0)
7220      cmp_rslt = strncmp(spec,"nla0:", 5);
7221 #else
7222   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
7223 #endif
7224   if (cmp_rslt == 0) {
7225     strcpy(rslt, "/dev/null");
7226     cp1 = cp1 + 9;
7227     cp2 = cp2 + 5;
7228     if (spec[6] != '\0') {
7229       cp1[9] == '/';
7230       cp1++;
7231       cp2++;
7232     }
7233   }
7234
7235    /* Also handle special case "SYS$SCRATCH:" */
7236 #if __CRTL_VER < 70000000
7237   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
7238   if (cmp_rslt != 0)
7239      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
7240 #else
7241   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
7242 #endif
7243   tmp = PerlMem_malloc(VMS_MAXRSS);
7244   if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7245   if (cmp_rslt == 0) {
7246   int islnm;
7247
7248     islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
7249     if (!islnm) {
7250       strcpy(rslt, "/tmp");
7251       cp1 = cp1 + 4;
7252       cp2 = cp2 + 12;
7253       if (spec[12] != '\0') {
7254         cp1[4] == '/';
7255         cp1++;
7256         cp2++;
7257       }
7258     }
7259   }
7260
7261   if (*cp2 != '[' && *cp2 != '<') {
7262     *(cp1++) = '/';
7263   }
7264   else {  /* the VMS spec begins with directories */
7265     cp2++;
7266     if (*cp2 == ']' || *cp2 == '>') {
7267       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
7268       PerlMem_free(tmp);
7269       return rslt;
7270     }
7271     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
7272       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
7273         PerlMem_free(tmp);
7274         if (vms_debug_fileify) {
7275             fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7276         }
7277         return NULL;
7278       }
7279       trnlnm_iter_count = 0;
7280       do {
7281         cp3 = tmp;
7282         while (*cp3 != ':' && *cp3) cp3++;
7283         *(cp3++) = '\0';
7284         if (strchr(cp3,']') != NULL) break;
7285         trnlnm_iter_count++;
7286         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7287       } while (vmstrnenv(tmp,tmp,0,fildev,0));
7288       cp1 = rslt;
7289       cp3 = tmp;
7290       *(cp1++) = '/';
7291       while (*cp3) {
7292         *(cp1++) = *(cp3++);
7293         if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7294             PerlMem_free(tmp);
7295             set_errno(ENAMETOOLONG);
7296             set_vaxc_errno(SS$_BUFFEROVF);
7297             if (vms_debug_fileify) {
7298                 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7299             }
7300             return NULL; /* No room */
7301         }
7302       }
7303       *(cp1++) = '/';
7304     }
7305     if ((*cp2 == '^')) {
7306         /* EFS file escape, pass the next character as is */
7307         /* Fix me: HEX encoding for Unicode not implemented */
7308         cp2++;
7309     }
7310     else if ( *cp2 == '.') {
7311       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7312         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7313         cp2 += 3;
7314       }
7315       else cp2++;
7316     }
7317   }
7318   PerlMem_free(tmp);
7319   for (; cp2 <= dirend; cp2++) {
7320     if ((*cp2 == '^')) {
7321         /* EFS file escape, pass the next character as is */
7322         /* Fix me: HEX encoding for Unicode not implemented */
7323         *(cp1++) = *(++cp2);
7324         /* An escaped dot stays as is -- don't convert to slash */
7325         if (*cp2 == '.') cp2++;
7326     }
7327     if (*cp2 == ':') {
7328       *(cp1++) = '/';
7329       if (*(cp2+1) == '[') cp2++;
7330     }
7331     else if (*cp2 == ']' || *cp2 == '>') {
7332       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7333     }
7334     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7335       *(cp1++) = '/';
7336       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7337         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7338                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7339         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7340             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7341       }
7342       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7343         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7344         cp2 += 2;
7345       }
7346     }
7347     else if (*cp2 == '-') {
7348       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7349         while (*cp2 == '-') {
7350           cp2++;
7351           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7352         }
7353         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7354                                                          /* filespecs like */
7355           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
7356           if (vms_debug_fileify) {
7357               fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7358           }
7359           return NULL;
7360         }
7361       }
7362       else *(cp1++) = *cp2;
7363     }
7364     else *(cp1++) = *cp2;
7365   }
7366   /* Translate the rest of the filename. */
7367   while (*cp2) {
7368       int dot_seen;
7369       dot_seen = 0;
7370       switch(*cp2) {
7371       /* Fixme - for compatibility with the CRTL we should be removing */
7372       /* spaces from the file specifications, but this may show that */
7373       /* some tests that were appearing to pass are not really passing */
7374       case '%':
7375           cp2++;
7376           *(cp1++) = '?';
7377           break;
7378       case '^':
7379           /* Fix me hex expansions not implemented */
7380           cp2++;  /* '^.' --> '.' and other. */
7381           if (*cp2) {
7382               if (*cp2 == '_') {
7383                   cp2++;
7384                   *(cp1++) = ' ';
7385               } else {
7386                   *(cp1++) = *(cp2++);
7387               }
7388           }
7389           break;
7390       case ';':
7391           if (decc_filename_unix_no_version) {
7392               /* Easy, drop the version */
7393               while (*cp2)
7394                   cp2++;
7395               break;
7396           } else {
7397               /* Punt - passing the version as a dot will probably */
7398               /* break perl in weird ways, but so did passing */
7399               /* through the ; as a version.  Follow the CRTL and */
7400               /* hope for the best. */
7401               cp2++;
7402               *(cp1++) = '.';
7403           }
7404           break;
7405       case '.':
7406           if (dot_seen) {
7407               /* We will need to fix this properly later */
7408               /* As Perl may be installed on an ODS-5 volume, but not */
7409               /* have the EFS_CHARSET enabled, it still may encounter */
7410               /* filenames with extra dots in them, and a precedent got */
7411               /* set which allowed them to work, that we will uphold here */
7412               /* If extra dots are present in a name and no ^ is on them */
7413               /* VMS assumes that the first one is the extension delimiter */
7414               /* the rest have an implied ^. */
7415
7416               /* this is also a conflict as the . is also a version */
7417               /* delimiter in VMS, */
7418
7419               *(cp1++) = *(cp2++);
7420               break;
7421           }
7422           dot_seen = 1;
7423           /* This is an extension */
7424           if (decc_readdir_dropdotnotype) {
7425               cp2++;
7426               if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7427                   /* Drop the dot for the extension */
7428                   break;
7429               } else {
7430                   *(cp1++) = '.';
7431               }
7432               break;
7433           }
7434       default:
7435           *(cp1++) = *(cp2++);
7436       }
7437   }
7438   *cp1 = '\0';
7439
7440   /* This still leaves /000000/ when working with a
7441    * VMS device root or concealed root.
7442    */
7443   {
7444   int ulen;
7445   char * zeros;
7446
7447       ulen = strlen(rslt);
7448
7449       /* Get rid of "000000/ in rooted filespecs */
7450       if (ulen > 7) {
7451         zeros = strstr(rslt, "/000000/");
7452         if (zeros != NULL) {
7453           int mlen;
7454           mlen = ulen - (zeros - rslt) - 7;
7455           memmove(zeros, &zeros[7], mlen);
7456           ulen = ulen - 7;
7457           rslt[ulen] = '\0';
7458         }
7459       }
7460   }
7461
7462   if (vms_debug_fileify) {
7463       fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7464   }
7465   return rslt;
7466
7467 }  /* end of int_tounixspec() */
7468
7469
7470 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7471 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7472 {
7473     static char __tounixspec_retbuf[VMS_MAXRSS];
7474     char * unixspec, *ret_spec, *ret_buf;
7475
7476     unixspec = NULL;
7477     ret_buf = buf;
7478     if (ret_buf == NULL) {
7479         if (ts) {
7480             Newx(unixspec, VMS_MAXRSS, char);
7481             if (unixspec == NULL)
7482                 _ckvmssts(SS$_INSFMEM);
7483             ret_buf = unixspec;
7484         } else {
7485             ret_buf = __tounixspec_retbuf;
7486         }
7487     }
7488
7489     ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7490
7491     if (ret_spec == NULL) {
7492        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7493        if (unixspec)
7494            Safefree(unixspec);
7495     }
7496
7497     return ret_spec;
7498
7499 }  /* end of do_tounixspec() */
7500 /*}}}*/
7501 /* External entry points */
7502 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
7503   { return do_tounixspec(spec,buf,0, NULL); }
7504 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7505   { return do_tounixspec(spec,buf,1, NULL); }
7506 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7507   { return do_tounixspec(spec,buf,0, utf8_fl); }
7508 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7509   { return do_tounixspec(spec,buf,1, utf8_fl); }
7510
7511 #if __CRTL_VER >= 70200000 && !defined(__VAX)
7512
7513 /*
7514  This procedure is used to identify if a path is based in either
7515  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7516  it returns the OpenVMS format directory for it.
7517
7518  It is expecting specifications of only '/' or '/xxxx/'
7519
7520  If a posix root does not exist, or 'xxxx' is not a directory
7521  in the posix root, it returns a failure.
7522
7523  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7524
7525  It is used only internally by posix_to_vmsspec_hardway().
7526  */
7527
7528 static int posix_root_to_vms
7529   (char *vmspath, int vmspath_len,
7530    const char *unixpath,
7531    const int * utf8_fl)
7532 {
7533 int sts;
7534 struct FAB myfab = cc$rms_fab;
7535 rms_setup_nam(mynam);
7536 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7537 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7538 char * esa, * esal, * rsa, * rsal;
7539 char *vms_delim;
7540 int dir_flag;
7541 int unixlen;
7542
7543     dir_flag = 0;
7544     vmspath[0] = '\0';
7545     unixlen = strlen(unixpath);
7546     if (unixlen == 0) {
7547       return RMS$_FNF;
7548     }
7549
7550 #if __CRTL_VER >= 80200000
7551   /* If not a posix spec already, convert it */
7552   if (decc_posix_compliant_pathnames) {
7553     if (strncmp(unixpath,"\"^UP^",5) != 0) {
7554       sprintf(vmspath,"\"^UP^%s\"",unixpath);
7555     }
7556     else {
7557       /* This is already a VMS specification, no conversion */
7558       unixlen--;
7559       strncpy(vmspath,unixpath, vmspath_len);
7560     }
7561   }
7562   else
7563 #endif
7564   {
7565   int path_len;
7566   int i,j;
7567
7568      /* Check to see if this is under the POSIX root */
7569      if (decc_disable_posix_root) {
7570         return RMS$_FNF;
7571      }
7572
7573      /* Skip leading / */
7574      if (unixpath[0] == '/') {
7575         unixpath++;
7576         unixlen--;
7577      }
7578
7579
7580      strcpy(vmspath,"SYS$POSIX_ROOT:");
7581
7582      /* If this is only the / , or blank, then... */
7583      if (unixpath[0] == '\0') {
7584         /* by definition, this is the answer */
7585         return SS$_NORMAL;
7586      }
7587
7588      /* Need to look up a directory */
7589      vmspath[15] = '[';
7590      vmspath[16] = '\0';
7591
7592      /* Copy and add '^' escape characters as needed */
7593      j = 16;
7594      i = 0;
7595      while (unixpath[i] != 0) {
7596      int k;
7597
7598         j += copy_expand_unix_filename_escape
7599             (&vmspath[j], &unixpath[i], &k, utf8_fl);
7600         i += k;
7601      }
7602
7603      path_len = strlen(vmspath);
7604      if (vmspath[path_len - 1] == '/')
7605         path_len--;
7606      vmspath[path_len] = ']';
7607      path_len++;
7608      vmspath[path_len] = '\0';
7609
7610   }
7611   vmspath[vmspath_len] = 0;
7612   if (unixpath[unixlen - 1] == '/')
7613   dir_flag = 1;
7614   esal = PerlMem_malloc(VMS_MAXRSS);
7615   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7616   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7617   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7618   rsal = PerlMem_malloc(VMS_MAXRSS);
7619   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7620   rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7621   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7622   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7623   rms_bind_fab_nam(myfab, mynam);
7624   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7625   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7626   if (decc_efs_case_preserve)
7627     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7628 #ifdef NAML$M_OPEN_SPECIAL
7629   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7630 #endif
7631
7632   /* Set up the remaining naml fields */
7633   sts = sys$parse(&myfab);
7634
7635   /* It failed! Try again as a UNIX filespec */
7636   if (!(sts & 1)) {
7637     PerlMem_free(esal);
7638     PerlMem_free(esa);
7639     PerlMem_free(rsal);
7640     PerlMem_free(rsa);
7641     return sts;
7642   }
7643
7644    /* get the Device ID and the FID */
7645    sts = sys$search(&myfab);
7646
7647    /* These are no longer needed */
7648    PerlMem_free(esa);
7649    PerlMem_free(rsal);
7650    PerlMem_free(rsa);
7651
7652    /* on any failure, returned the POSIX ^UP^ filespec */
7653    if (!(sts & 1)) {
7654       PerlMem_free(esal);
7655       return sts;
7656    }
7657    specdsc.dsc$a_pointer = vmspath;
7658    specdsc.dsc$w_length = vmspath_len;
7659
7660    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7661    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7662    sts = lib$fid_to_name
7663       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7664
7665   /* on any failure, returned the POSIX ^UP^ filespec */
7666   if (!(sts & 1)) {
7667      /* This can happen if user does not have permission to read directories */
7668      if (strncmp(unixpath,"\"^UP^",5) != 0)
7669        sprintf(vmspath,"\"^UP^%s\"",unixpath);
7670      else
7671        strcpy(vmspath, unixpath);
7672   }
7673   else {
7674     vmspath[specdsc.dsc$w_length] = 0;
7675
7676     /* Are we expecting a directory? */
7677     if (dir_flag != 0) {
7678     int i;
7679     char *eptr;
7680
7681       eptr = NULL;
7682
7683       i = specdsc.dsc$w_length - 1;
7684       while (i > 0) {
7685       int zercnt;
7686         zercnt = 0;
7687         /* Version must be '1' */
7688         if (vmspath[i--] != '1')
7689           break;
7690         /* Version delimiter is one of ".;" */
7691         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7692           break;
7693         i--;
7694         if (vmspath[i--] != 'R')
7695           break;
7696         if (vmspath[i--] != 'I')
7697           break;
7698         if (vmspath[i--] != 'D')
7699           break;
7700         if (vmspath[i--] != '.')
7701           break;
7702         eptr = &vmspath[i+1];
7703         while (i > 0) {
7704           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7705             if (vmspath[i-1] != '^') {
7706               if (zercnt != 6) {
7707                 *eptr = vmspath[i];
7708                 eptr[1] = '\0';
7709                 vmspath[i] = '.';
7710                 break;
7711               }
7712               else {
7713                 /* Get rid of 6 imaginary zero directory filename */
7714                 vmspath[i+1] = '\0';
7715               }
7716             }
7717           }
7718           if (vmspath[i] == '0')
7719             zercnt++;
7720           else
7721             zercnt = 10;
7722           i--;
7723         }
7724         break;
7725       }
7726     }
7727   }
7728   PerlMem_free(esal);
7729   return sts;
7730 }
7731
7732 /* /dev/mumble needs to be handled special.
7733    /dev/null becomes NLA0:, And there is the potential for other stuff
7734    like /dev/tty which may need to be mapped to something.
7735 */
7736
7737 static int
7738 slash_dev_special_to_vms
7739    (const char * unixptr,
7740     char * vmspath,
7741     int vmspath_len)
7742 {
7743 char * nextslash;
7744 int len;
7745 int cmp;
7746 int islnm;
7747
7748     unixptr += 4;
7749     nextslash = strchr(unixptr, '/');
7750     len = strlen(unixptr);
7751     if (nextslash != NULL)
7752         len = nextslash - unixptr;
7753     cmp = strncmp("null", unixptr, 5);
7754     if (cmp == 0) {
7755         if (vmspath_len >= 6) {
7756             strcpy(vmspath, "_NLA0:");
7757             return SS$_NORMAL;
7758         }
7759     }
7760 }
7761
7762
7763 /* The built in routines do not understand perl's special needs, so
7764     doing a manual conversion from UNIX to VMS
7765
7766     If the utf8_fl is not null and points to a non-zero value, then
7767     treat 8 bit characters as UTF-8.
7768
7769     The sequence starting with '$(' and ending with ')' will be passed
7770     through with out interpretation instead of being escaped.
7771
7772   */
7773 static int posix_to_vmsspec_hardway
7774   (char *vmspath, int vmspath_len,
7775    const char *unixpath,
7776    int dir_flag,
7777    int * utf8_fl) {
7778
7779 char *esa;
7780 const char *unixptr;
7781 const char *unixend;
7782 char *vmsptr;
7783 const char *lastslash;
7784 const char *lastdot;
7785 int unixlen;
7786 int vmslen;
7787 int dir_start;
7788 int dir_dot;
7789 int quoted;
7790 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7791 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7792
7793   if (utf8_fl != NULL)
7794     *utf8_fl = 0;
7795
7796   unixptr = unixpath;
7797   dir_dot = 0;
7798
7799   /* Ignore leading "/" characters */
7800   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7801     unixptr++;
7802   }
7803   unixlen = strlen(unixptr);
7804
7805   /* Do nothing with blank paths */
7806   if (unixlen == 0) {
7807     vmspath[0] = '\0';
7808     return SS$_NORMAL;
7809   }
7810
7811   quoted = 0;
7812   /* This could have a "^UP^ on the front */
7813   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7814     quoted = 1;
7815     unixptr+= 5;
7816     unixlen-= 5;
7817   }
7818
7819   lastslash = strrchr(unixptr,'/');
7820   lastdot = strrchr(unixptr,'.');
7821   unixend = strrchr(unixptr,'\"');
7822   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7823     unixend = unixptr + unixlen;
7824   }
7825
7826   /* last dot is last dot or past end of string */
7827   if (lastdot == NULL)
7828     lastdot = unixptr + unixlen;
7829
7830   /* if no directories, set last slash to beginning of string */
7831   if (lastslash == NULL) {
7832     lastslash = unixptr;
7833   }
7834   else {
7835     /* Watch out for trailing "." after last slash, still a directory */
7836     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7837       lastslash = unixptr + unixlen;
7838     }
7839
7840     /* Watch out for traiing ".." after last slash, still a directory */
7841     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7842       lastslash = unixptr + unixlen;
7843     }
7844
7845     /* dots in directories are aways escaped */
7846     if (lastdot < lastslash)
7847       lastdot = unixptr + unixlen;
7848   }
7849
7850   /* if (unixptr < lastslash) then we are in a directory */
7851
7852   dir_start = 0;
7853
7854   vmsptr = vmspath;
7855   vmslen = 0;
7856
7857   /* Start with the UNIX path */
7858   if (*unixptr != '/') {
7859     /* relative paths */
7860
7861     /* If allowing logical names on relative pathnames, then handle here */
7862     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7863         !decc_posix_compliant_pathnames) {
7864     char * nextslash;
7865     int seg_len;
7866     char * trn;
7867     int islnm;
7868
7869         /* Find the next slash */
7870         nextslash = strchr(unixptr,'/');
7871
7872         esa = PerlMem_malloc(vmspath_len);
7873         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7874
7875         trn = PerlMem_malloc(VMS_MAXRSS);
7876         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7877
7878         if (nextslash != NULL) {
7879
7880             seg_len = nextslash - unixptr;
7881             strncpy(esa, unixptr, seg_len);
7882             esa[seg_len] = 0;
7883         }
7884         else {
7885             strcpy(esa, unixptr);
7886             seg_len = strlen(unixptr);
7887         }
7888         /* trnlnm(section) */
7889         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7890
7891         if (islnm) {
7892             /* Now fix up the directory */
7893
7894             /* Split up the path to find the components */
7895             sts = vms_split_path
7896                   (trn,
7897                    &v_spec,
7898                    &v_len,
7899                    &r_spec,
7900                    &r_len,
7901                    &d_spec,
7902                    &d_len,
7903                    &n_spec,
7904                    &n_len,
7905                    &e_spec,
7906                    &e_len,
7907                    &vs_spec,
7908                    &vs_len);
7909
7910             while (sts == 0) {
7911             char * strt;
7912             int cmp;
7913
7914                 /* A logical name must be a directory  or the full
7915                    specification.  It is only a full specification if
7916                    it is the only component */
7917                 if ((unixptr[seg_len] == '\0') ||
7918                     (unixptr[seg_len+1] == '\0')) {
7919
7920                     /* Is a directory being required? */
7921                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7922                         /* Not a logical name */
7923                         break;
7924                     }
7925
7926
7927                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7928                         /* This must be a directory */
7929                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7930                             strcpy(vmsptr, esa);
7931                             vmslen=strlen(vmsptr);
7932                             vmsptr[vmslen] = ':';
7933                             vmslen++;
7934                             vmsptr[vmslen] = '\0';
7935                             return SS$_NORMAL;
7936                         }
7937                     }
7938
7939                 }
7940
7941
7942                 /* must be dev/directory - ignore version */
7943                 if ((n_len + e_len) != 0)
7944                     break;
7945
7946                 /* transfer the volume */
7947                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7948                     strncpy(vmsptr, v_spec, v_len);
7949                     vmsptr += v_len;
7950                     vmsptr[0] = '\0';
7951                     vmslen += v_len;
7952                 }
7953
7954                 /* unroot the rooted directory */
7955                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7956                     r_spec[0] = '[';
7957                     r_spec[r_len - 1] = ']';
7958
7959                     /* This should not be there, but nothing is perfect */
7960                     if (r_len > 9) {
7961                         cmp = strcmp(&r_spec[1], "000000.");
7962                         if (cmp == 0) {
7963                             r_spec += 7;
7964                             r_spec[7] = '[';
7965                             r_len -= 7;
7966                             if (r_len == 2)
7967                                 r_len = 0;
7968                         }
7969                     }
7970                     if (r_len > 0) {
7971                         strncpy(vmsptr, r_spec, r_len);
7972                         vmsptr += r_len;
7973                         vmslen += r_len;
7974                         vmsptr[0] = '\0';
7975                     }
7976                 }
7977                 /* Bring over the directory. */
7978                 if ((d_len > 0) &&
7979                     ((d_len + vmslen) < vmspath_len)) {
7980                     d_spec[0] = '[';
7981                     d_spec[d_len - 1] = ']';
7982                     if (d_len > 9) {
7983                         cmp = strcmp(&d_spec[1], "000000.");
7984                         if (cmp == 0) {
7985                             d_spec += 7;
7986                             d_spec[7] = '[';
7987                             d_len -= 7;
7988                             if (d_len == 2)
7989                                 d_len = 0;
7990                         }
7991                     }
7992
7993                     if (r_len > 0) {
7994                         /* Remove the redundant root */
7995                         if (r_len > 0) {
7996                             /* remove the ][ */
7997                             vmsptr--;
7998                             vmslen--;
7999                             d_spec++;
8000                             d_len--;
8001                         }
8002                         strncpy(vmsptr, d_spec, d_len);
8003                             vmsptr += d_len;
8004                             vmslen += d_len;
8005                             vmsptr[0] = '\0';
8006                     }
8007                 }
8008                 break;
8009             }
8010         }
8011
8012         PerlMem_free(esa);
8013         PerlMem_free(trn);
8014     }
8015
8016     if (lastslash > unixptr) {
8017     int dotdir_seen;
8018
8019       /* skip leading ./ */
8020       dotdir_seen = 0;
8021       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
8022         dotdir_seen = 1;
8023         unixptr++;
8024         unixptr++;
8025       }
8026
8027       /* Are we still in a directory? */
8028       if (unixptr <= lastslash) {
8029         *vmsptr++ = '[';
8030         vmslen = 1;
8031         dir_start = 1;
8032
8033         /* if not backing up, then it is relative forward. */
8034         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
8035               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
8036           *vmsptr++ = '.';
8037           vmslen++;
8038           dir_dot = 1;
8039           }
8040        }
8041        else {
8042          if (dotdir_seen) {
8043            /* Perl wants an empty directory here to tell the difference
8044             * between a DCL commmand and a filename
8045             */
8046           *vmsptr++ = '[';
8047           *vmsptr++ = ']';
8048           vmslen = 2;
8049         }
8050       }
8051     }
8052     else {
8053       /* Handle two special files . and .. */
8054       if (unixptr[0] == '.') {
8055         if (&unixptr[1] == unixend) {
8056           *vmsptr++ = '[';
8057           *vmsptr++ = ']';
8058           vmslen += 2;
8059           *vmsptr++ = '\0';
8060           return SS$_NORMAL;
8061         }
8062         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
8063           *vmsptr++ = '[';
8064           *vmsptr++ = '-';
8065           *vmsptr++ = ']';
8066           vmslen += 3;
8067           *vmsptr++ = '\0';
8068           return SS$_NORMAL;
8069         }
8070       }
8071     }
8072   }
8073   else {        /* Absolute PATH handling */
8074   int sts;
8075   char * nextslash;
8076   int seg_len;
8077     /* Need to find out where root is */
8078
8079     /* In theory, this procedure should never get an absolute POSIX pathname
8080      * that can not be found on the POSIX root.
8081      * In practice, that can not be relied on, and things will show up
8082      * here that are a VMS device name or concealed logical name instead.
8083      * So to make things work, this procedure must be tolerant.
8084      */
8085     esa = PerlMem_malloc(vmspath_len);
8086     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8087
8088     sts = SS$_NORMAL;
8089     nextslash = strchr(&unixptr[1],'/');
8090     seg_len = 0;
8091     if (nextslash != NULL) {
8092     int cmp;
8093       seg_len = nextslash - &unixptr[1];
8094       strncpy(vmspath, unixptr, seg_len + 1);
8095       vmspath[seg_len+1] = 0;
8096       cmp = 1;
8097       if (seg_len == 3) {
8098         cmp = strncmp(vmspath, "dev", 4);
8099         if (cmp == 0) {
8100             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
8101             if (sts = SS$_NORMAL)
8102                 return SS$_NORMAL;
8103         }
8104       }
8105       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
8106     }
8107
8108     if ($VMS_STATUS_SUCCESS(sts)) {
8109       /* This is verified to be a real path */
8110
8111       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
8112       if ($VMS_STATUS_SUCCESS(sts)) {
8113         strcpy(vmspath, esa);
8114         vmslen = strlen(vmspath);
8115         vmsptr = vmspath + vmslen;
8116         unixptr++;
8117         if (unixptr < lastslash) {
8118         char * rptr;
8119           vmsptr--;
8120           *vmsptr++ = '.';
8121           dir_start = 1;
8122           dir_dot = 1;
8123           if (vmslen > 7) {
8124           int cmp;
8125             rptr = vmsptr - 7;
8126             cmp = strcmp(rptr,"000000.");
8127             if (cmp == 0) {
8128               vmslen -= 7;
8129               vmsptr -= 7;
8130               vmsptr[1] = '\0';
8131             } /* removing 6 zeros */
8132           } /* vmslen < 7, no 6 zeros possible */
8133         } /* Not in a directory */
8134       } /* Posix root found */
8135       else {
8136         /* No posix root, fall back to default directory */
8137         strcpy(vmspath, "SYS$DISK:[");
8138         vmsptr = &vmspath[10];
8139         vmslen = 10;
8140         if (unixptr > lastslash) {
8141            *vmsptr = ']';
8142            vmsptr++;
8143            vmslen++;
8144         }
8145         else {
8146            dir_start = 1;
8147         }
8148       }
8149     } /* end of verified real path handling */
8150     else {
8151     int add_6zero;
8152     int islnm;
8153
8154       /* Ok, we have a device or a concealed root that is not in POSIX
8155        * or we have garbage.  Make the best of it.
8156        */
8157
8158       /* Posix to VMS destroyed this, so copy it again */
8159       strncpy(vmspath, &unixptr[1], seg_len);
8160       vmspath[seg_len] = 0;
8161       vmslen = seg_len;
8162       vmsptr = &vmsptr[vmslen];
8163       islnm = 0;
8164
8165       /* Now do we need to add the fake 6 zero directory to it? */
8166       add_6zero = 1;
8167       if ((*lastslash == '/') && (nextslash < lastslash)) {
8168         /* No there is another directory */
8169         add_6zero = 0;
8170       }
8171       else {
8172       int trnend;
8173       int cmp;
8174
8175         /* now we have foo:bar or foo:[000000]bar to decide from */
8176         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
8177
8178         if (!islnm && !decc_posix_compliant_pathnames) {
8179
8180             cmp = strncmp("bin", vmspath, 4);
8181             if (cmp == 0) {
8182                 /* bin => SYS$SYSTEM: */
8183                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
8184             }
8185             else {
8186                 /* tmp => SYS$SCRATCH: */
8187                 cmp = strncmp("tmp", vmspath, 4);
8188                 if (cmp == 0) {
8189                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
8190                 }
8191             }
8192         }
8193
8194         trnend = islnm ? islnm - 1 : 0;
8195
8196         /* if this was a logical name, ']' or '>' must be present */
8197         /* if not a logical name, then assume a device and hope. */
8198         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
8199
8200         /* if log name and trailing '.' then rooted - treat as device */
8201         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
8202
8203         /* Fix me, if not a logical name, a device lookup should be
8204          * done to see if the device is file structured.  If the device
8205          * is not file structured, the 6 zeros should not be put on.
8206          *
8207          * As it is, perl is occasionally looking for dev:[000000]tty.
8208          * which looks a little strange.
8209          *
8210          * Not that easy to detect as "/dev" may be file structured with
8211          * special device files.
8212          */
8213
8214         if ((add_6zero == 0) && (*nextslash == '/') &&
8215             (&nextslash[1] == unixend)) {
8216           /* No real directory present */
8217           add_6zero = 1;
8218         }
8219       }
8220
8221       /* Put the device delimiter on */
8222       *vmsptr++ = ':';
8223       vmslen++;
8224       unixptr = nextslash;
8225       unixptr++;
8226
8227       /* Start directory if needed */
8228       if (!islnm || add_6zero) {
8229         *vmsptr++ = '[';
8230         vmslen++;
8231         dir_start = 1;
8232       }
8233
8234       /* add fake 000000] if needed */
8235       if (add_6zero) {
8236         *vmsptr++ = '0';
8237         *vmsptr++ = '0';
8238         *vmsptr++ = '0';
8239         *vmsptr++ = '0';
8240         *vmsptr++ = '0';
8241         *vmsptr++ = '0';
8242         *vmsptr++ = ']';
8243         vmslen += 7;
8244         dir_start = 0;
8245       }
8246
8247     } /* non-POSIX translation */
8248     PerlMem_free(esa);
8249   } /* End of relative/absolute path handling */
8250
8251   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
8252   int dash_flag;
8253   int in_cnt;
8254   int out_cnt;
8255
8256     dash_flag = 0;
8257
8258     if (dir_start != 0) {
8259
8260       /* First characters in a directory are handled special */
8261       while ((*unixptr == '/') ||
8262              ((*unixptr == '.') &&
8263               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8264                 (&unixptr[1]==unixend)))) {
8265       int loop_flag;
8266
8267         loop_flag = 0;
8268
8269         /* Skip redundant / in specification */
8270         while ((*unixptr == '/') && (dir_start != 0)) {
8271           loop_flag = 1;
8272           unixptr++;
8273           if (unixptr == lastslash)
8274             break;
8275         }
8276         if (unixptr == lastslash)
8277           break;
8278
8279         /* Skip redundant ./ characters */
8280         while ((*unixptr == '.') &&
8281                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8282           loop_flag = 1;
8283           unixptr++;
8284           if (unixptr == lastslash)
8285             break;
8286           if (*unixptr == '/')
8287             unixptr++;
8288         }
8289         if (unixptr == lastslash)
8290           break;
8291
8292         /* Skip redundant ../ characters */
8293         while ((*unixptr == '.') && (unixptr[1] == '.') &&
8294              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8295           /* Set the backing up flag */
8296           loop_flag = 1;
8297           dir_dot = 0;
8298           dash_flag = 1;
8299           *vmsptr++ = '-';
8300           vmslen++;
8301           unixptr++; /* first . */
8302           unixptr++; /* second . */
8303           if (unixptr == lastslash)
8304             break;
8305           if (*unixptr == '/') /* The slash */
8306             unixptr++;
8307         }
8308         if (unixptr == lastslash)
8309           break;
8310
8311         /* To do: Perl expects /.../ to be translated to [...] on VMS */
8312         /* Not needed when VMS is pretending to be UNIX. */
8313
8314         /* Is this loop stuck because of too many dots? */
8315         if (loop_flag == 0) {
8316           /* Exit the loop and pass the rest through */
8317           break;
8318         }
8319       }
8320
8321       /* Are we done with directories yet? */
8322       if (unixptr >= lastslash) {
8323
8324         /* Watch out for trailing dots */
8325         if (dir_dot != 0) {
8326             vmslen --;
8327             vmsptr--;
8328         }
8329         *vmsptr++ = ']';
8330         vmslen++;
8331         dash_flag = 0;
8332         dir_start = 0;
8333         if (*unixptr == '/')
8334           unixptr++;
8335       }
8336       else {
8337         /* Have we stopped backing up? */
8338         if (dash_flag) {
8339           *vmsptr++ = '.';
8340           vmslen++;
8341           dash_flag = 0;
8342           /* dir_start continues to be = 1 */
8343         }
8344         if (*unixptr == '-') {
8345           *vmsptr++ = '^';
8346           *vmsptr++ = *unixptr++;
8347           vmslen += 2;
8348           dir_start = 0;
8349
8350           /* Now are we done with directories yet? */
8351           if (unixptr >= lastslash) {
8352
8353             /* Watch out for trailing dots */
8354             if (dir_dot != 0) {
8355               vmslen --;
8356               vmsptr--;
8357             }
8358
8359             *vmsptr++ = ']';
8360             vmslen++;
8361             dash_flag = 0;
8362             dir_start = 0;
8363           }
8364         }
8365       }
8366     }
8367
8368     /* All done? */
8369     if (unixptr >= unixend)
8370       break;
8371
8372     /* Normal characters - More EFS work probably needed */
8373     dir_start = 0;
8374     dir_dot = 0;
8375
8376     switch(*unixptr) {
8377     case '/':
8378         /* remove multiple / */
8379         while (unixptr[1] == '/') {
8380            unixptr++;
8381         }
8382         if (unixptr == lastslash) {
8383           /* Watch out for trailing dots */
8384           if (dir_dot != 0) {
8385             vmslen --;
8386             vmsptr--;
8387           }
8388           *vmsptr++ = ']';
8389         }
8390         else {
8391           dir_start = 1;
8392           *vmsptr++ = '.';
8393           dir_dot = 1;
8394
8395           /* To do: Perl expects /.../ to be translated to [...] on VMS */
8396           /* Not needed when VMS is pretending to be UNIX. */
8397
8398         }
8399         dash_flag = 0;
8400         if (unixptr != unixend)
8401           unixptr++;
8402         vmslen++;
8403         break;
8404     case '.':
8405         if ((unixptr < lastdot) || (unixptr < lastslash) ||
8406             (&unixptr[1] == unixend)) {
8407           *vmsptr++ = '^';
8408           *vmsptr++ = '.';
8409           vmslen += 2;
8410           unixptr++;
8411
8412           /* trailing dot ==> '^..' on VMS */
8413           if (unixptr == unixend) {
8414             *vmsptr++ = '.';
8415             vmslen++;
8416             unixptr++;
8417           }
8418           break;
8419         }
8420
8421         *vmsptr++ = *unixptr++;
8422         vmslen ++;
8423         break;
8424     case '"':
8425         if (quoted && (&unixptr[1] == unixend)) {
8426             unixptr++;
8427             break;
8428         }
8429         in_cnt = copy_expand_unix_filename_escape
8430                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8431         vmsptr += out_cnt;
8432         unixptr += in_cnt;
8433         break;
8434     case '~':
8435     case ';':
8436     case '\\':
8437     case '?':
8438     case ' ':
8439     default:
8440         in_cnt = copy_expand_unix_filename_escape
8441                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8442         vmsptr += out_cnt;
8443         unixptr += in_cnt;
8444         break;
8445     }
8446   }
8447
8448   /* Make sure directory is closed */
8449   if (unixptr == lastslash) {
8450     char *vmsptr2;
8451     vmsptr2 = vmsptr - 1;
8452
8453     if (*vmsptr2 != ']') {
8454       *vmsptr2--;
8455
8456       /* directories do not end in a dot bracket */
8457       if (*vmsptr2 == '.') {
8458         vmsptr2--;
8459
8460         /* ^. is allowed */
8461         if (*vmsptr2 != '^') {
8462           vmsptr--; /* back up over the dot */
8463         }
8464       }
8465       *vmsptr++ = ']';
8466     }
8467   }
8468   else {
8469     char *vmsptr2;
8470     /* Add a trailing dot if a file with no extension */
8471     vmsptr2 = vmsptr - 1;
8472     if ((vmslen > 1) &&
8473         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8474         (*vmsptr2 != ')') && (*lastdot != '.')) {
8475         *vmsptr++ = '.';
8476         vmslen++;
8477     }
8478   }
8479
8480   *vmsptr = '\0';
8481   return SS$_NORMAL;
8482 }
8483 #endif
8484
8485  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
8486 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
8487 {
8488 char * result;
8489 int utf8_flag;
8490
8491    /* If a UTF8 flag is being passed, honor it */
8492    utf8_flag = 0;
8493    if (utf8_fl != NULL) {
8494      utf8_flag = *utf8_fl;
8495     *utf8_fl = 0;
8496    }
8497
8498    if (utf8_flag) {
8499      /* If there is a possibility of UTF8, then if any UTF8 characters
8500         are present, then they must be converted to VTF-7
8501       */
8502      result = strcpy(rslt, path); /* FIX-ME */
8503    }
8504    else
8505      result = strcpy(rslt, path);
8506
8507    return result;
8508 }
8509
8510
8511
8512 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8513 static char *int_tovmsspec
8514    (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
8515   char *dirend;
8516   char *lastdot;
8517   char *vms_delim;
8518   register char *cp1;
8519   const char *cp2;
8520   unsigned long int infront = 0, hasdir = 1;
8521   int rslt_len;
8522   int no_type_seen;
8523   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8524   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8525
8526   if (vms_debug_fileify) {
8527       if (path == NULL)
8528           fprintf(stderr, "int_tovmsspec: path = NULL\n");
8529       else
8530           fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8531   }
8532
8533   if (path == NULL) {
8534       /* If we fail, we should be setting errno */
8535       set_errno(EINVAL);
8536       set_vaxc_errno(SS$_BADPARAM);
8537       return NULL;
8538   }
8539   rslt_len = VMS_MAXRSS-1;
8540
8541   /* '.' and '..' are "[]" and "[-]" for a quick check */
8542   if (path[0] == '.') {
8543     if (path[1] == '\0') {
8544       strcpy(rslt,"[]");
8545       if (utf8_flag != NULL)
8546         *utf8_flag = 0;
8547       return rslt;
8548     }
8549     else {
8550       if (path[1] == '.' && path[2] == '\0') {
8551         strcpy(rslt,"[-]");
8552         if (utf8_flag != NULL)
8553            *utf8_flag = 0;
8554         return rslt;
8555       }
8556     }
8557   }
8558
8559    /* Posix specifications are now a native VMS format */
8560   /*--------------------------------------------------*/
8561 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8562   if (decc_posix_compliant_pathnames) {
8563     if (strncmp(path,"\"^UP^",5) == 0) {
8564       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8565       return rslt;
8566     }
8567   }
8568 #endif
8569
8570   /* This is really the only way to see if this is already in VMS format */
8571   sts = vms_split_path
8572        (path,
8573         &v_spec,
8574         &v_len,
8575         &r_spec,
8576         &r_len,
8577         &d_spec,
8578         &d_len,
8579         &n_spec,
8580         &n_len,
8581         &e_spec,
8582         &e_len,
8583         &vs_spec,
8584         &vs_len);
8585   if (sts == 0) {
8586     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8587        replacement, because the above parse just took care of most of
8588        what is needed to do vmspath when the specification is already
8589        in VMS format.
8590
8591        And if it is not already, it is easier to do the conversion as
8592        part of this routine than to call this routine and then work on
8593        the result.
8594      */
8595
8596     /* If VMS punctuation was found, it is already VMS format */
8597     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8598       if (utf8_flag != NULL)
8599         *utf8_flag = 0;
8600       strcpy(rslt, path);
8601       if (vms_debug_fileify) {
8602           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8603       }
8604       return rslt;
8605     }
8606     /* Now, what to do with trailing "." cases where there is no
8607        extension?  If this is a UNIX specification, and EFS characters
8608        are enabled, then the trailing "." should be converted to a "^.".
8609        But if this was already a VMS specification, then it should be
8610        left alone.
8611
8612        So in the case of ambiguity, leave the specification alone.
8613      */
8614
8615
8616     /* If there is a possibility of UTF8, then if any UTF8 characters
8617         are present, then they must be converted to VTF-7
8618      */
8619     if (utf8_flag != NULL)
8620       *utf8_flag = 0;
8621     strcpy(rslt, path);
8622     if (vms_debug_fileify) {
8623         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8624     }
8625     return rslt;
8626   }
8627
8628   dirend = strrchr(path,'/');
8629
8630   if (dirend == NULL) {
8631      char *macro_start;
8632      int has_macro;
8633
8634      /* If we get here with no UNIX directory delimiters, then this is
8635         not a complete file specification, either garbage a UNIX glob
8636         specification that can not be converted to a VMS wildcard, or
8637         it a UNIX shell macro.  MakeMaker wants shell macros passed
8638         through AS-IS,
8639
8640         utf8 flag setting needs to be preserved.
8641       */
8642       hasdir = 0;
8643
8644       has_macro = 0;
8645       macro_start = strchr(path,'$');
8646       if (macro_start != NULL) {
8647           if (macro_start[1] == '(') {
8648               has_macro = 1;
8649           }
8650       }
8651       if ((decc_efs_charset == 0) || (has_macro)) {
8652           strcpy(rslt, path);
8653           if (vms_debug_fileify) {
8654               fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8655           }
8656           return rslt;
8657       }
8658   }
8659
8660 /* If POSIX mode active, handle the conversion */
8661 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8662   if (decc_efs_charset) {
8663     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8664     if (vms_debug_fileify) {
8665         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8666     }
8667     return rslt;
8668   }
8669 #endif
8670
8671   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
8672     if (!*(dirend+2)) dirend +=2;
8673     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8674     if (decc_efs_charset == 0) {
8675       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8676     }
8677   }
8678
8679   cp1 = rslt;
8680   cp2 = path;
8681   lastdot = strrchr(cp2,'.');
8682   if (*cp2 == '/') {
8683     char *trndev;
8684     int islnm, rooted;
8685     STRLEN trnend;
8686
8687     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8688     if (!*(cp2+1)) {
8689       if (decc_disable_posix_root) {
8690         strcpy(rslt,"sys$disk:[000000]");
8691       }
8692       else {
8693         strcpy(rslt,"sys$posix_root:[000000]");
8694       }
8695       if (utf8_flag != NULL)
8696         *utf8_flag = 0;
8697       if (vms_debug_fileify) {
8698           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8699       }
8700       return rslt;
8701     }
8702     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8703     *cp1 = '\0';
8704     trndev = PerlMem_malloc(VMS_MAXRSS);
8705     if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8706     islnm =  simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8707
8708      /* DECC special handling */
8709     if (!islnm) {
8710       if (strcmp(rslt,"bin") == 0) {
8711         strcpy(rslt,"sys$system");
8712         cp1 = rslt + 10;
8713         *cp1 = 0;
8714         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8715       }
8716       else if (strcmp(rslt,"tmp") == 0) {
8717         strcpy(rslt,"sys$scratch");
8718         cp1 = rslt + 11;
8719         *cp1 = 0;
8720         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8721       }
8722       else if (!decc_disable_posix_root) {
8723         strcpy(rslt, "sys$posix_root");
8724         cp1 = rslt + 14;
8725         *cp1 = 0;
8726         cp2 = path;
8727         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8728         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8729       }
8730       else if (strcmp(rslt,"dev") == 0) {
8731         if (strncmp(cp2,"/null", 5) == 0) {
8732           if ((cp2[5] == 0) || (cp2[5] == '/')) {
8733             strcpy(rslt,"NLA0");
8734             cp1 = rslt + 4;
8735             *cp1 = 0;
8736             cp2 = cp2 + 5;
8737             islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8738           }
8739         }
8740       }
8741     }
8742
8743     trnend = islnm ? strlen(trndev) - 1 : 0;
8744     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8745     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8746     /* If the first element of the path is a logical name, determine
8747      * whether it has to be translated so we can add more directories. */
8748     if (!islnm || rooted) {
8749       *(cp1++) = ':';
8750       *(cp1++) = '[';
8751       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8752       else cp2++;
8753     }
8754     else {
8755       if (cp2 != dirend) {
8756         strcpy(rslt,trndev);
8757         cp1 = rslt + trnend;
8758         if (*cp2 != 0) {
8759           *(cp1++) = '.';
8760           cp2++;
8761         }
8762       }
8763       else {
8764         if (decc_disable_posix_root) {
8765           *(cp1++) = ':';
8766           hasdir = 0;
8767         }
8768       }
8769     }
8770     PerlMem_free(trndev);
8771   }
8772   else {
8773     *(cp1++) = '[';
8774     if (*cp2 == '.') {
8775       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8776         cp2 += 2;         /* skip over "./" - it's redundant */
8777         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8778       }
8779       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8780         *(cp1++) = '-';                                 /* "../" --> "-" */
8781         cp2 += 3;
8782       }
8783       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8784                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8785         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8786         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8787         cp2 += 4;
8788       }
8789       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8790         /* Escape the extra dots in EFS file specifications */
8791         *(cp1++) = '^';
8792       }
8793       if (cp2 > dirend) cp2 = dirend;
8794     }
8795     else *(cp1++) = '.';
8796   }
8797   for (; cp2 < dirend; cp2++) {
8798     if (*cp2 == '/') {
8799       if (*(cp2-1) == '/') continue;
8800       if (*(cp1-1) != '.') *(cp1++) = '.';
8801       infront = 0;
8802     }
8803     else if (!infront && *cp2 == '.') {
8804       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8805       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8806       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8807         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8808         else if (*(cp1-2) == '[') *(cp1-1) = '-';
8809         else {  /* back up over previous directory name */
8810           cp1--;
8811           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
8812           if (*(cp1-1) == '[') {
8813             memcpy(cp1,"000000.",7);
8814             cp1 += 7;
8815           }
8816         }
8817         cp2 += 2;
8818         if (cp2 == dirend) break;
8819       }
8820       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8821                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8822         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8823         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8824         if (!*(cp2+3)) {
8825           *(cp1++) = '.';  /* Simulate trailing '/' */
8826           cp2 += 2;  /* for loop will incr this to == dirend */
8827         }
8828         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8829       }
8830       else {
8831         if (decc_efs_charset == 0)
8832           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8833         else {
8834           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
8835           *(cp1++) = '.';
8836         }
8837       }
8838     }
8839     else {
8840       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
8841       if (*cp2 == '.') {
8842         if (decc_efs_charset == 0)
8843           *(cp1++) = '_';
8844         else {
8845           *(cp1++) = '^';
8846           *(cp1++) = '.';
8847         }
8848       }
8849       else                  *(cp1++) =  *cp2;
8850       infront = 1;
8851     }
8852   }
8853   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8854   if (hasdir) *(cp1++) = ']';
8855   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
8856   /* fixme for ODS5 */
8857   no_type_seen = 0;
8858   if (cp2 > lastdot)
8859     no_type_seen = 1;
8860   while (*cp2) {
8861     switch(*cp2) {
8862     case '?':
8863         if (decc_efs_charset == 0)
8864           *(cp1++) = '%';
8865         else
8866           *(cp1++) = '?';
8867         cp2++;
8868     case ' ':
8869         *(cp1)++ = '^';
8870         *(cp1)++ = '_';
8871         cp2++;
8872         break;
8873     case '.':
8874         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8875             decc_readdir_dropdotnotype) {
8876           *(cp1)++ = '^';
8877           *(cp1)++ = '.';
8878           cp2++;
8879
8880           /* trailing dot ==> '^..' on VMS */
8881           if (*cp2 == '\0') {
8882             *(cp1++) = '.';
8883             no_type_seen = 0;
8884           }
8885         }
8886         else {
8887           *(cp1++) = *(cp2++);
8888           no_type_seen = 0;
8889         }
8890         break;
8891     case '$':
8892          /* This could be a macro to be passed through */
8893         *(cp1++) = *(cp2++);
8894         if (*cp2 == '(') {
8895         const char * save_cp2;
8896         char * save_cp1;
8897         int is_macro;
8898
8899             /* paranoid check */
8900             save_cp2 = cp2;
8901             save_cp1 = cp1;
8902             is_macro = 0;
8903
8904             /* Test through */
8905             *(cp1++) = *(cp2++);
8906             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8907                 *(cp1++) = *(cp2++);
8908                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8909                     *(cp1++) = *(cp2++);
8910                 }
8911                 if (*cp2 == ')') {
8912                     *(cp1++) = *(cp2++);
8913                     is_macro = 1;
8914                 }
8915             }
8916             if (is_macro == 0) {
8917                 /* Not really a macro - never mind */
8918                 cp2 = save_cp2;
8919                 cp1 = save_cp1;
8920             }
8921         }
8922         break;
8923     case '\"':
8924     case '~':
8925     case '`':
8926     case '!':
8927     case '#':
8928     case '%':
8929     case '^':
8930         /* Don't escape again if following character is
8931          * already something we escape.
8932          */
8933         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8934             *(cp1++) = *(cp2++);
8935             break;
8936         }
8937         /* But otherwise fall through and escape it. */
8938     case '&':
8939     case '(':
8940     case ')':
8941     case '=':
8942     case '+':
8943     case '\'':
8944     case '@':
8945     case '[':
8946     case ']':
8947     case '{':
8948     case '}':
8949     case ':':
8950     case '\\':
8951     case '|':
8952     case '<':
8953     case '>':
8954         *(cp1++) = '^';
8955         *(cp1++) = *(cp2++);
8956         break;
8957     case ';':
8958         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8959          * which is wrong.  UNIX notation should be ".dir." unless
8960          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8961          * changing this behavior could break more things at this time.
8962          * efs character set effectively does not allow "." to be a version
8963          * delimiter as a further complication about changing this.
8964          */
8965         if (decc_filename_unix_report != 0) {
8966           *(cp1++) = '^';
8967         }
8968         *(cp1++) = *(cp2++);
8969         break;
8970     default:
8971         *(cp1++) = *(cp2++);
8972     }
8973   }
8974   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8975   char *lcp1;
8976     lcp1 = cp1;
8977     lcp1--;
8978      /* Fix me for "^]", but that requires making sure that you do
8979       * not back up past the start of the filename
8980       */
8981     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8982       *cp1++ = '.';
8983   }
8984   *cp1 = '\0';
8985
8986   if (utf8_flag != NULL)
8987     *utf8_flag = 0;
8988   if (vms_debug_fileify) {
8989       fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8990   }
8991   return rslt;
8992
8993 }  /* end of int_tovmsspec() */
8994
8995
8996 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8997 static char *mp_do_tovmsspec
8998    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
8999   static char __tovmsspec_retbuf[VMS_MAXRSS];
9000     char * vmsspec, *ret_spec, *ret_buf;
9001
9002     vmsspec = NULL;
9003     ret_buf = buf;
9004     if (ret_buf == NULL) {
9005         if (ts) {
9006             Newx(vmsspec, VMS_MAXRSS, char);
9007             if (vmsspec == NULL)
9008                 _ckvmssts(SS$_INSFMEM);
9009             ret_buf = vmsspec;
9010         } else {
9011             ret_buf = __tovmsspec_retbuf;
9012         }
9013     }
9014
9015     ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
9016
9017     if (ret_spec == NULL) {
9018        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
9019        if (vmsspec)
9020            Safefree(vmsspec);
9021     }
9022
9023     return ret_spec;
9024
9025 }  /* end of mp_do_tovmsspec() */
9026 /*}}}*/
9027 /* External entry points */
9028 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
9029   { return do_tovmsspec(path,buf,0,NULL); }
9030 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
9031   { return do_tovmsspec(path,buf,1,NULL); }
9032 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9033   { return do_tovmsspec(path,buf,0,utf8_fl); }
9034 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9035   { return do_tovmsspec(path,buf,1,utf8_fl); }
9036
9037 /*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
9038 /* Internal routine for use with out an explict context present */
9039 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl) {
9040
9041     char * ret_spec, *pathified;
9042
9043     if (path == NULL)
9044         return NULL;
9045
9046     pathified = PerlMem_malloc(VMS_MAXRSS);
9047     if (pathified == NULL)
9048         _ckvmssts_noperl(SS$_INSFMEM);
9049
9050     ret_spec = int_pathify_dirspec(path, pathified);
9051
9052     if (ret_spec == NULL) {
9053         PerlMem_free(pathified);
9054         return NULL;
9055     }
9056
9057     ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
9058
9059     PerlMem_free(pathified);
9060     return ret_spec;
9061
9062 }
9063
9064 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
9065 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
9066   static char __tovmspath_retbuf[VMS_MAXRSS];
9067   int vmslen;
9068   char *pathified, *vmsified, *cp;
9069
9070   if (path == NULL) return NULL;
9071   pathified = PerlMem_malloc(VMS_MAXRSS);
9072   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
9073   if (int_pathify_dirspec(path, pathified) == NULL) {
9074     PerlMem_free(pathified);
9075     return NULL;
9076   }
9077
9078   vmsified = NULL;
9079   if (buf == NULL)
9080      Newx(vmsified, VMS_MAXRSS, char);
9081   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
9082     PerlMem_free(pathified);
9083     if (vmsified) Safefree(vmsified);
9084     return NULL;
9085   }
9086   PerlMem_free(pathified);
9087   if (buf) {
9088     return buf;
9089   }
9090   else if (ts) {
9091     vmslen = strlen(vmsified);
9092     Newx(cp,vmslen+1,char);
9093     memcpy(cp,vmsified,vmslen);
9094     cp[vmslen] = '\0';
9095     Safefree(vmsified);
9096     return cp;
9097   }
9098   else {
9099     strcpy(__tovmspath_retbuf,vmsified);
9100     Safefree(vmsified);
9101     return __tovmspath_retbuf;
9102   }
9103
9104 }  /* end of do_tovmspath() */
9105 /*}}}*/
9106 /* External entry points */
9107 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
9108   { return do_tovmspath(path,buf,0, NULL); }
9109 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
9110   { return do_tovmspath(path,buf,1, NULL); }
9111 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
9112   { return do_tovmspath(path,buf,0,utf8_fl); }
9113 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
9114   { return do_tovmspath(path,buf,1,utf8_fl); }
9115
9116
9117 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
9118 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
9119   static char __tounixpath_retbuf[VMS_MAXRSS];
9120   int unixlen;
9121   char *pathified, *unixified, *cp;
9122
9123   if (path == NULL) return NULL;
9124   pathified = PerlMem_malloc(VMS_MAXRSS);
9125   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
9126   if (int_pathify_dirspec(path, pathified) == NULL) {
9127     PerlMem_free(pathified);
9128     return NULL;
9129   }
9130
9131   unixified = NULL;
9132   if (buf == NULL) {
9133       Newx(unixified, VMS_MAXRSS, char);
9134   }
9135   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
9136     PerlMem_free(pathified);
9137     if (unixified) Safefree(unixified);
9138     return NULL;
9139   }
9140   PerlMem_free(pathified);
9141   if (buf) {
9142     return buf;
9143   }
9144   else if (ts) {
9145     unixlen = strlen(unixified);
9146     Newx(cp,unixlen+1,char);
9147     memcpy(cp,unixified,unixlen);
9148     cp[unixlen] = '\0';
9149     Safefree(unixified);
9150     return cp;
9151   }
9152   else {
9153     strcpy(__tounixpath_retbuf,unixified);
9154     Safefree(unixified);
9155     return __tounixpath_retbuf;
9156   }
9157
9158 }  /* end of do_tounixpath() */
9159 /*}}}*/
9160 /* External entry points */
9161 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
9162   { return do_tounixpath(path,buf,0,NULL); }
9163 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
9164   { return do_tounixpath(path,buf,1,NULL); }
9165 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9166   { return do_tounixpath(path,buf,0,utf8_fl); }
9167 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9168   { return do_tounixpath(path,buf,1,utf8_fl); }
9169
9170 /*
9171  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
9172  *
9173  *****************************************************************************
9174  *                                                                           *
9175  *  Copyright (C) 1989-1994, 2007 by                                         *
9176  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
9177  *                                                                           *
9178  *  Permission is hereby granted for the reproduction of this software       *
9179  *  on condition that this copyright notice is included in source            *
9180  *  distributions of the software.  The code may be modified and             *
9181  *  distributed under the same terms as Perl itself.                         *
9182  *                                                                           *
9183  *  27-Aug-1994 Modified for inclusion in perl5                              *
9184  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
9185  *****************************************************************************
9186  */
9187
9188 /*
9189  * getredirection() is intended to aid in porting C programs
9190  * to VMS (Vax-11 C).  The native VMS environment does not support
9191  * '>' and '<' I/O redirection, or command line wild card expansion,
9192  * or a command line pipe mechanism using the '|' AND background
9193  * command execution '&'.  All of these capabilities are provided to any
9194  * C program which calls this procedure as the first thing in the
9195  * main program.
9196  * The piping mechanism will probably work with almost any 'filter' type
9197  * of program.  With suitable modification, it may useful for other
9198  * portability problems as well.
9199  *
9200  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
9201  */
9202 struct list_item
9203     {
9204     struct list_item *next;
9205     char *value;
9206     };
9207
9208 static void add_item(struct list_item **head,
9209                      struct list_item **tail,
9210                      char *value,
9211                      int *count);
9212
9213 static void mp_expand_wild_cards(pTHX_ char *item,
9214                                 struct list_item **head,
9215                                 struct list_item **tail,
9216                                 int *count);
9217
9218 static int background_process(pTHX_ int argc, char **argv);
9219
9220 static void pipe_and_fork(pTHX_ char **cmargv);
9221
9222 /*{{{ void getredirection(int *ac, char ***av)*/
9223 static void
9224 mp_getredirection(pTHX_ int *ac, char ***av)
9225 /*
9226  * Process vms redirection arg's.  Exit if any error is seen.
9227  * If getredirection() processes an argument, it is erased
9228  * from the vector.  getredirection() returns a new argc and argv value.
9229  * In the event that a background command is requested (by a trailing "&"),
9230  * this routine creates a background subprocess, and simply exits the program.
9231  *
9232  * Warning: do not try to simplify the code for vms.  The code
9233  * presupposes that getredirection() is called before any data is
9234  * read from stdin or written to stdout.
9235  *
9236  * Normal usage is as follows:
9237  *
9238  *      main(argc, argv)
9239  *      int             argc;
9240  *      char            *argv[];
9241  *      {
9242  *              getredirection(&argc, &argv);
9243  *      }
9244  */
9245 {
9246     int                 argc = *ac;     /* Argument Count         */
9247     char                **argv = *av;   /* Argument Vector        */
9248     char                *ap;            /* Argument pointer       */
9249     int                 j;              /* argv[] index           */
9250     int                 item_count = 0; /* Count of Items in List */
9251     struct list_item    *list_head = 0; /* First Item in List       */
9252     struct list_item    *list_tail;     /* Last Item in List        */
9253     char                *in = NULL;     /* Input File Name          */
9254     char                *out = NULL;    /* Output File Name         */
9255     char                *outmode = "w"; /* Mode to Open Output File */
9256     char                *err = NULL;    /* Error File Name          */
9257     char                *errmode = "w"; /* Mode to Open Error File  */
9258     int                 cmargc = 0;     /* Piped Command Arg Count  */
9259     char                **cmargv = NULL;/* Piped Command Arg Vector */
9260
9261     /*
9262      * First handle the case where the last thing on the line ends with
9263      * a '&'.  This indicates the desire for the command to be run in a
9264      * subprocess, so we satisfy that desire.
9265      */
9266     ap = argv[argc-1];
9267     if (0 == strcmp("&", ap))
9268        exit(background_process(aTHX_ --argc, argv));
9269     if (*ap && '&' == ap[strlen(ap)-1])
9270         {
9271         ap[strlen(ap)-1] = '\0';
9272        exit(background_process(aTHX_ argc, argv));
9273         }
9274     /*
9275      * Now we handle the general redirection cases that involve '>', '>>',
9276      * '<', and pipes '|'.
9277      */
9278     for (j = 0; j < argc; ++j)
9279         {
9280         if (0 == strcmp("<", argv[j]))
9281             {
9282             if (j+1 >= argc)
9283                 {
9284                 fprintf(stderr,"No input file after < on command line");
9285                 exit(LIB$_WRONUMARG);
9286                 }
9287             in = argv[++j];
9288             continue;
9289             }
9290         if ('<' == *(ap = argv[j]))
9291             {
9292             in = 1 + ap;
9293             continue;
9294             }
9295         if (0 == strcmp(">", ap))
9296             {
9297             if (j+1 >= argc)
9298                 {
9299                 fprintf(stderr,"No output file after > on command line");
9300                 exit(LIB$_WRONUMARG);
9301                 }
9302             out = argv[++j];
9303             continue;
9304             }
9305         if ('>' == *ap)
9306             {
9307             if ('>' == ap[1])
9308                 {
9309                 outmode = "a";
9310                 if ('\0' == ap[2])
9311                     out = argv[++j];
9312                 else
9313                     out = 2 + ap;
9314                 }
9315             else
9316                 out = 1 + ap;
9317             if (j >= argc)
9318                 {
9319                 fprintf(stderr,"No output file after > or >> on command line");
9320                 exit(LIB$_WRONUMARG);
9321                 }
9322             continue;
9323             }
9324         if (('2' == *ap) && ('>' == ap[1]))
9325             {
9326             if ('>' == ap[2])
9327                 {
9328                 errmode = "a";
9329                 if ('\0' == ap[3])
9330                     err = argv[++j];
9331                 else
9332                     err = 3 + ap;
9333                 }
9334             else
9335                 if ('\0' == ap[2])
9336                     err = argv[++j];
9337                 else
9338                     err = 2 + ap;
9339             if (j >= argc)
9340                 {
9341                 fprintf(stderr,"No output file after 2> or 2>> on command line");
9342                 exit(LIB$_WRONUMARG);
9343                 }
9344             continue;
9345             }
9346         if (0 == strcmp("|", argv[j]))
9347             {
9348             if (j+1 >= argc)
9349                 {
9350                 fprintf(stderr,"No command into which to pipe on command line");
9351                 exit(LIB$_WRONUMARG);
9352                 }
9353             cmargc = argc-(j+1);
9354             cmargv = &argv[j+1];
9355             argc = j;
9356             continue;
9357             }
9358         if ('|' == *(ap = argv[j]))
9359             {
9360             ++argv[j];
9361             cmargc = argc-j;
9362             cmargv = &argv[j];
9363             argc = j;
9364             continue;
9365             }
9366         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9367         }
9368     /*
9369      * Allocate and fill in the new argument vector, Some Unix's terminate
9370      * the list with an extra null pointer.
9371      */
9372     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9373     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9374     *av = argv;
9375     for (j = 0; j < item_count; ++j, list_head = list_head->next)
9376         argv[j] = list_head->value;
9377     *ac = item_count;
9378     if (cmargv != NULL)
9379         {
9380         if (out != NULL)
9381             {
9382             fprintf(stderr,"'|' and '>' may not both be specified on command line");
9383             exit(LIB$_INVARGORD);
9384             }
9385         pipe_and_fork(aTHX_ cmargv);
9386         }
9387
9388     /* Check for input from a pipe (mailbox) */
9389
9390     if (in == NULL && 1 == isapipe(0))
9391         {
9392         char mbxname[L_tmpnam];
9393         long int bufsize;
9394         long int dvi_item = DVI$_DEVBUFSIZ;
9395         $DESCRIPTOR(mbxnam, "");
9396         $DESCRIPTOR(mbxdevnam, "");
9397
9398         /* Input from a pipe, reopen it in binary mode to disable       */
9399         /* carriage control processing.                                 */
9400
9401         fgetname(stdin, mbxname);
9402         mbxnam.dsc$a_pointer = mbxname;
9403         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9404         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9405         mbxdevnam.dsc$a_pointer = mbxname;
9406         mbxdevnam.dsc$w_length = sizeof(mbxname);
9407         dvi_item = DVI$_DEVNAM;
9408         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9409         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9410         set_errno(0);
9411         set_vaxc_errno(1);
9412         freopen(mbxname, "rb", stdin);
9413         if (errno != 0)
9414             {
9415             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9416             exit(vaxc$errno);
9417             }
9418         }
9419     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9420         {
9421         fprintf(stderr,"Can't open input file %s as stdin",in);
9422         exit(vaxc$errno);
9423         }
9424     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9425         {
9426         fprintf(stderr,"Can't open output file %s as stdout",out);
9427         exit(vaxc$errno);
9428         }
9429         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
9430
9431     if (err != NULL) {
9432         if (strcmp(err,"&1") == 0) {
9433             dup2(fileno(stdout), fileno(stderr));
9434             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
9435         } else {
9436         FILE *tmperr;
9437         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9438             {
9439             fprintf(stderr,"Can't open error file %s as stderr",err);
9440             exit(vaxc$errno);
9441             }
9442             fclose(tmperr);
9443            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9444                 {
9445                 exit(vaxc$errno);
9446                 }
9447             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
9448         }
9449         }
9450 #ifdef ARGPROC_DEBUG
9451     PerlIO_printf(Perl_debug_log, "Arglist:\n");
9452     for (j = 0; j < *ac;  ++j)
9453         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9454 #endif
9455    /* Clear errors we may have hit expanding wildcards, so they don't
9456       show up in Perl's $! later */
9457    set_errno(0); set_vaxc_errno(1);
9458 }  /* end of getredirection() */
9459 /*}}}*/
9460
9461 static void add_item(struct list_item **head,
9462                      struct list_item **tail,
9463                      char *value,
9464                      int *count)
9465 {
9466     if (*head == 0)
9467         {
9468         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9469         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9470         *tail = *head;
9471         }
9472     else {
9473         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9474         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9475         *tail = (*tail)->next;
9476         }
9477     (*tail)->value = value;
9478     ++(*count);
9479 }
9480
9481 static void mp_expand_wild_cards(pTHX_ char *item,
9482                               struct list_item **head,
9483                               struct list_item **tail,
9484                               int *count)
9485 {
9486 int expcount = 0;
9487 unsigned long int context = 0;
9488 int isunix = 0;
9489 int item_len = 0;
9490 char *had_version;
9491 char *had_device;
9492 int had_directory;
9493 char *devdir,*cp;
9494 char *vmsspec;
9495 $DESCRIPTOR(filespec, "");
9496 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9497 $DESCRIPTOR(resultspec, "");
9498 unsigned long int lff_flags = 0;
9499 int sts;
9500 int rms_sts;
9501
9502 #ifdef VMS_LONGNAME_SUPPORT
9503     lff_flags = LIB$M_FIL_LONG_NAMES;
9504 #endif
9505
9506     for (cp = item; *cp; cp++) {
9507         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9508         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9509     }
9510     if (!*cp || isspace(*cp))
9511         {
9512         add_item(head, tail, item, count);
9513         return;
9514         }
9515     else
9516         {
9517      /* "double quoted" wild card expressions pass as is */
9518      /* From DCL that means using e.g.:                  */
9519      /* perl program """perl.*"""                        */
9520      item_len = strlen(item);
9521      if ( '"' == *item && '"' == item[item_len-1] )
9522        {
9523        item++;
9524        item[item_len-2] = '\0';
9525        add_item(head, tail, item, count);
9526        return;
9527        }
9528      }
9529     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9530     resultspec.dsc$b_class = DSC$K_CLASS_D;
9531     resultspec.dsc$a_pointer = NULL;
9532     vmsspec = PerlMem_malloc(VMS_MAXRSS);
9533     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9534     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9535       filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9536     if (!isunix || !filespec.dsc$a_pointer)
9537       filespec.dsc$a_pointer = item;
9538     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9539     /*
9540      * Only return version specs, if the caller specified a version
9541      */
9542     had_version = strchr(item, ';');
9543     /*
9544      * Only return device and directory specs, if the caller specifed either.
9545      */
9546     had_device = strchr(item, ':');
9547     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9548
9549     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9550                                  (&filespec, &resultspec, &context,
9551                                   &defaultspec, 0, &rms_sts, &lff_flags)))
9552         {
9553         char *string;
9554         char *c;
9555
9556         string = PerlMem_malloc(resultspec.dsc$w_length+1);
9557         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9558         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
9559         string[resultspec.dsc$w_length] = '\0';
9560         if (NULL == had_version)
9561             *(strrchr(string, ';')) = '\0';
9562         if ((!had_directory) && (had_device == NULL))
9563             {
9564             if (NULL == (devdir = strrchr(string, ']')))
9565                 devdir = strrchr(string, '>');
9566             strcpy(string, devdir + 1);
9567             }
9568         /*
9569          * Be consistent with what the C RTL has already done to the rest of
9570          * the argv items and lowercase all of these names.
9571          */
9572         if (!decc_efs_case_preserve) {
9573             for (c = string; *c; ++c)
9574             if (isupper(*c))
9575                 *c = tolower(*c);
9576         }
9577         if (isunix) trim_unixpath(string,item,1);
9578         add_item(head, tail, string, count);
9579         ++expcount;
9580     }
9581     PerlMem_free(vmsspec);
9582     if (sts != RMS$_NMF)
9583         {
9584         set_vaxc_errno(sts);
9585         switch (sts)
9586             {
9587             case RMS$_FNF: case RMS$_DNF:
9588                 set_errno(ENOENT); break;
9589             case RMS$_DIR:
9590                 set_errno(ENOTDIR); break;
9591             case RMS$_DEV:
9592                 set_errno(ENODEV); break;
9593             case RMS$_FNM: case RMS$_SYN:
9594                 set_errno(EINVAL); break;
9595             case RMS$_PRV:
9596                 set_errno(EACCES); break;
9597             default:
9598                 _ckvmssts_noperl(sts);
9599             }
9600         }
9601     if (expcount == 0)
9602         add_item(head, tail, item, count);
9603     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9604     _ckvmssts_noperl(lib$find_file_end(&context));
9605 }
9606
9607 static int child_st[2];/* Event Flag set when child process completes   */
9608
9609 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
9610
9611 static unsigned long int exit_handler(int *status)
9612 {
9613 short iosb[4];
9614
9615     if (0 == child_st[0])
9616         {
9617 #ifdef ARGPROC_DEBUG
9618         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
9619 #endif
9620         fflush(stdout);     /* Have to flush pipe for binary data to    */
9621                             /* terminate properly -- <tp@mccall.com>    */
9622         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
9623         sys$dassgn(child_chan);
9624         fclose(stdout);
9625         sys$synch(0, child_st);
9626         }
9627     return(1);
9628 }
9629
9630 static void sig_child(int chan)
9631 {
9632 #ifdef ARGPROC_DEBUG
9633     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
9634 #endif
9635     if (child_st[0] == 0)
9636         child_st[0] = 1;
9637 }
9638
9639 static struct exit_control_block exit_block =
9640     {
9641     0,
9642     exit_handler,
9643     1,
9644     &exit_block.exit_status,
9645     0
9646     };
9647
9648 static void
9649 pipe_and_fork(pTHX_ char **cmargv)
9650 {
9651     PerlIO *fp;
9652     struct dsc$descriptor_s *vmscmd;
9653     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9654     int sts, j, l, ismcr, quote, tquote = 0;
9655
9656     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9657     vms_execfree(vmscmd);
9658
9659     j = l = 0;
9660     p = subcmd;
9661     q = cmargv[0];
9662     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
9663               && toupper(*(q+2)) == 'R' && !*(q+3);
9664
9665     while (q && l < MAX_DCL_LINE_LENGTH) {
9666         if (!*q) {
9667             if (j > 0 && quote) {
9668                 *p++ = '"';
9669                 l++;
9670             }
9671             q = cmargv[++j];
9672             if (q) {
9673                 if (ismcr && j > 1) quote = 1;
9674                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
9675                 *p++ = ' ';
9676                 l++;
9677                 if (quote || tquote) {
9678                     *p++ = '"';
9679                     l++;
9680                 }
9681             }
9682         } else {
9683             if ((quote||tquote) && *q == '"') {
9684                 *p++ = '"';
9685                 l++;
9686             }
9687             *p++ = *q++;
9688             l++;
9689         }
9690     }
9691     *p = '\0';
9692
9693     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9694     if (fp == NULL) {
9695         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9696     }
9697 }
9698
9699 static int background_process(pTHX_ int argc, char **argv)
9700 {
9701 char command[MAX_DCL_SYMBOL + 1] = "$";
9702 $DESCRIPTOR(value, "");
9703 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9704 static $DESCRIPTOR(null, "NLA0:");
9705 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9706 char pidstring[80];
9707 $DESCRIPTOR(pidstr, "");
9708 int pid;
9709 unsigned long int flags = 17, one = 1, retsts;
9710 int len;
9711
9712     strcat(command, argv[0]);
9713     len = strlen(command);
9714     while (--argc && (len < MAX_DCL_SYMBOL))
9715         {
9716         strcat(command, " \"");
9717         strcat(command, *(++argv));
9718         strcat(command, "\"");
9719         len = strlen(command);
9720         }
9721     value.dsc$a_pointer = command;
9722     value.dsc$w_length = strlen(value.dsc$a_pointer);
9723     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9724     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9725     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9726         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9727     }
9728     else {
9729         _ckvmssts_noperl(retsts);
9730     }
9731 #ifdef ARGPROC_DEBUG
9732     PerlIO_printf(Perl_debug_log, "%s\n", command);
9733 #endif
9734     sprintf(pidstring, "%08X", pid);
9735     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9736     pidstr.dsc$a_pointer = pidstring;
9737     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9738     lib$set_symbol(&pidsymbol, &pidstr);
9739     return(SS$_NORMAL);
9740 }
9741 /*}}}*/
9742 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9743
9744
9745 /* OS-specific initialization at image activation (not thread startup) */
9746 /* Older VAXC header files lack these constants */
9747 #ifndef JPI$_RIGHTS_SIZE
9748 #  define JPI$_RIGHTS_SIZE 817
9749 #endif
9750 #ifndef KGB$M_SUBSYSTEM
9751 #  define KGB$M_SUBSYSTEM 0x8
9752 #endif
9753
9754 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9755
9756 /*{{{void vms_image_init(int *, char ***)*/
9757 void
9758 vms_image_init(int *argcp, char ***argvp)
9759 {
9760   int status;
9761   char eqv[LNM$C_NAMLENGTH+1] = "";
9762   unsigned int len, tabct = 8, tabidx = 0;
9763   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9764   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9765   unsigned short int dummy, rlen;
9766   struct dsc$descriptor_s **tabvec;
9767 #if defined(PERL_IMPLICIT_CONTEXT)
9768   pTHX = NULL;
9769 #endif
9770   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
9771                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
9772                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9773                                  {          0,                0,    0,      0} };
9774
9775 #ifdef KILL_BY_SIGPRC
9776     Perl_csighandler_init();
9777 #endif
9778
9779     /* This was moved from the pre-image init handler because on threaded */
9780     /* Perl it was always returning 0 for the default value. */
9781     status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9782     if (status > 0) {
9783         int s;
9784         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9785         if (s > 0) {
9786             int initial;
9787             initial = decc$feature_get_value(s, 4);
9788             if (initial > 0) {
9789                 /* initial is: 0 if nothing has set the feature */
9790                 /*            -1 if initialized to default */
9791                 /*             1 if set by logical name */
9792                 /*             2 if set by decc$feature_set_value */
9793                 decc_disable_posix_root = decc$feature_get_value(s, 1);
9794
9795                 /* If the value is not valid, force the feature off */
9796                 if (decc_disable_posix_root < 0) {
9797                     decc$feature_set_value(s, 1, 1);
9798                     decc_disable_posix_root = 1;
9799                 }
9800             }
9801             else {
9802                 /* Nothing has asked for it explicitly, so use our own default. */
9803                 decc_disable_posix_root = 1;
9804                 decc$feature_set_value(s, 1, 1);
9805             }
9806         }
9807     }
9808
9809
9810   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9811   _ckvmssts_noperl(iosb[0]);
9812   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9813     if (iprv[i]) {           /* Running image installed with privs? */
9814       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
9815       will_taint = TRUE;
9816       break;
9817     }
9818   }
9819   /* Rights identifiers might trigger tainting as well. */
9820   if (!will_taint && (rlen || rsz)) {
9821     while (rlen < rsz) {
9822       /* We didn't get all the identifiers on the first pass.  Allocate a
9823        * buffer much larger than $GETJPI wants (rsz is size in bytes that
9824        * were needed to hold all identifiers at time of last call; we'll
9825        * allocate that many unsigned long ints), and go back and get 'em.
9826        * If it gave us less than it wanted to despite ample buffer space,
9827        * something's broken.  Is your system missing a system identifier?
9828        */
9829       if (rsz <= jpilist[1].buflen) {
9830          /* Perl_croak accvios when used this early in startup. */
9831          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9832                          rsz, (unsigned long) jpilist[1].buflen,
9833                          "Check your rights database for corruption.\n");
9834          exit(SS$_ABORT);
9835       }
9836       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9837       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9838       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9839       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9840       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9841       _ckvmssts_noperl(iosb[0]);
9842     }
9843     mask = jpilist[1].bufadr;
9844     /* Check attribute flags for each identifier (2nd longword); protected
9845      * subsystem identifiers trigger tainting.
9846      */
9847     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9848       if (mask[i] & KGB$M_SUBSYSTEM) {
9849         will_taint = TRUE;
9850         break;
9851       }
9852     }
9853     if (mask != rlst) PerlMem_free(mask);
9854   }
9855
9856   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9857    * logical, some versions of the CRTL will add a phanthom /000000/
9858    * directory.  This needs to be removed.
9859    */
9860   if (decc_filename_unix_report) {
9861   char * zeros;
9862   int ulen;
9863     ulen = strlen(argvp[0][0]);
9864     if (ulen > 7) {
9865       zeros = strstr(argvp[0][0], "/000000/");
9866       if (zeros != NULL) {
9867         int mlen;
9868         mlen = ulen - (zeros - argvp[0][0]) - 7;
9869         memmove(zeros, &zeros[7], mlen);
9870         ulen = ulen - 7;
9871         argvp[0][0][ulen] = '\0';
9872       }
9873     }
9874     /* It also may have a trailing dot that needs to be removed otherwise
9875      * it will be converted to VMS mode incorrectly.
9876      */
9877     ulen--;
9878     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9879       argvp[0][0][ulen] = '\0';
9880   }
9881
9882   /* We need to use this hack to tell Perl it should run with tainting,
9883    * since its tainting flag may be part of the PL_curinterp struct, which
9884    * hasn't been allocated when vms_image_init() is called.
9885    */
9886   if (will_taint) {
9887     char **newargv, **oldargv;
9888     oldargv = *argvp;
9889     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9890     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9891     newargv[0] = oldargv[0];
9892     newargv[1] = PerlMem_malloc(3 * sizeof(char));
9893     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9894     strcpy(newargv[1], "-T");
9895     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9896     (*argcp)++;
9897     newargv[*argcp] = NULL;
9898     /* We orphan the old argv, since we don't know where it's come from,
9899      * so we don't know how to free it.
9900      */
9901     *argvp = newargv;
9902   }
9903   else {  /* Did user explicitly request tainting? */
9904     int i;
9905     char *cp, **av = *argvp;
9906     for (i = 1; i < *argcp; i++) {
9907       if (*av[i] != '-') break;
9908       for (cp = av[i]+1; *cp; cp++) {
9909         if (*cp == 'T') { will_taint = 1; break; }
9910         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9911                   strchr("DFIiMmx",*cp)) break;
9912       }
9913       if (will_taint) break;
9914     }
9915   }
9916
9917   for (tabidx = 0;
9918        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9919        tabidx++) {
9920     if (!tabidx) {
9921       tabvec = (struct dsc$descriptor_s **)
9922             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9923       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9924     }
9925     else if (tabidx >= tabct) {
9926       tabct += 8;
9927       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9928       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9929     }
9930     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9931     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9932     tabvec[tabidx]->dsc$w_length  = 0;
9933     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9934     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
9935     tabvec[tabidx]->dsc$a_pointer = NULL;
9936     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9937   }
9938   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9939
9940   getredirection(argcp,argvp);
9941 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9942   {
9943 # include <reentrancy.h>
9944   decc$set_reentrancy(C$C_MULTITHREAD);
9945   }
9946 #endif
9947   return;
9948 }
9949 /*}}}*/
9950
9951
9952 /* trim_unixpath()
9953  * Trim Unix-style prefix off filespec, so it looks like what a shell
9954  * glob expansion would return (i.e. from specified prefix on, not
9955  * full path).  Note that returned filespec is Unix-style, regardless
9956  * of whether input filespec was VMS-style or Unix-style.
9957  *
9958  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9959  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9960  * vector of options; at present, only bit 0 is used, and if set tells
9961  * trim unixpath to try the current default directory as a prefix when
9962  * presented with a possibly ambiguous ... wildcard.
9963  *
9964  * Returns !=0 on success, with trimmed filespec replacing contents of
9965  * fspec, and 0 on failure, with contents of fpsec unchanged.
9966  */
9967 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9968 int
9969 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9970 {
9971   char *unixified, *unixwild,
9972        *template, *base, *end, *cp1, *cp2;
9973   register int tmplen, reslen = 0, dirs = 0;
9974
9975   if (!wildspec || !fspec) return 0;
9976
9977   unixwild = PerlMem_malloc(VMS_MAXRSS);
9978   if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9979   template = unixwild;
9980   if (strpbrk(wildspec,"]>:") != NULL) {
9981     if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
9982         PerlMem_free(unixwild);
9983         return 0;
9984     }
9985   }
9986   else {
9987     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
9988     unixwild[VMS_MAXRSS-1] = 0;
9989   }
9990   unixified = PerlMem_malloc(VMS_MAXRSS);
9991   if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9992   if (strpbrk(fspec,"]>:") != NULL) {
9993     if (int_tounixspec(fspec, unixified, NULL) == NULL) {
9994         PerlMem_free(unixwild);
9995         PerlMem_free(unixified);
9996         return 0;
9997     }
9998     else base = unixified;
9999     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
10000      * check to see that final result fits into (isn't longer than) fspec */
10001     reslen = strlen(fspec);
10002   }
10003   else base = fspec;
10004
10005   /* No prefix or absolute path on wildcard, so nothing to remove */
10006   if (!*template || *template == '/') {
10007     PerlMem_free(unixwild);
10008     if (base == fspec) {
10009         PerlMem_free(unixified);
10010         return 1;
10011     }
10012     tmplen = strlen(unixified);
10013     if (tmplen > reslen) {
10014         PerlMem_free(unixified);
10015         return 0;  /* not enough space */
10016     }
10017     /* Copy unixified resultant, including trailing NUL */
10018     memmove(fspec,unixified,tmplen+1);
10019     PerlMem_free(unixified);
10020     return 1;
10021   }
10022
10023   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
10024   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
10025     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
10026     for (cp1 = end ;cp1 >= base; cp1--)
10027       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
10028         { cp1++; break; }
10029     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
10030     PerlMem_free(unixified);
10031     PerlMem_free(unixwild);
10032     return 1;
10033   }
10034   else {
10035     char *tpl, *lcres;
10036     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
10037     int ells = 1, totells, segdirs, match;
10038     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
10039                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10040
10041     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
10042     totells = ells;
10043     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
10044     tpl = PerlMem_malloc(VMS_MAXRSS);
10045     if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10046     if (ellipsis == template && opts & 1) {
10047       /* Template begins with an ellipsis.  Since we can't tell how many
10048        * directory names at the front of the resultant to keep for an
10049        * arbitrary starting point, we arbitrarily choose the current
10050        * default directory as a starting point.  If it's there as a prefix,
10051        * clip it off.  If not, fall through and act as if the leading
10052        * ellipsis weren't there (i.e. return shortest possible path that
10053        * could match template).
10054        */
10055       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
10056           PerlMem_free(tpl);
10057           PerlMem_free(unixified);
10058           PerlMem_free(unixwild);
10059           return 0;
10060       }
10061       if (!decc_efs_case_preserve) {
10062         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
10063           if (_tolower(*cp1) != _tolower(*cp2)) break;
10064       }
10065       segdirs = dirs - totells;  /* Min # of dirs we must have left */
10066       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
10067       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
10068         memmove(fspec,cp2+1,end - cp2);
10069         PerlMem_free(tpl);
10070         PerlMem_free(unixified);
10071         PerlMem_free(unixwild);
10072         return 1;
10073       }
10074     }
10075     /* First off, back up over constant elements at end of path */
10076     if (dirs) {
10077       for (front = end ; front >= base; front--)
10078          if (*front == '/' && !dirs--) { front++; break; }
10079     }
10080     lcres = PerlMem_malloc(VMS_MAXRSS);
10081     if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10082     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
10083          cp1++,cp2++) {
10084             if (!decc_efs_case_preserve) {
10085                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
10086             }
10087             else {
10088                 *cp2 = *cp1;
10089             }
10090     }
10091     if (cp1 != '\0') {
10092         PerlMem_free(tpl);
10093         PerlMem_free(unixified);
10094         PerlMem_free(unixwild);
10095         PerlMem_free(lcres);
10096         return 0;  /* Path too long. */
10097     }
10098     lcend = cp2;
10099     *cp2 = '\0';  /* Pick up with memcpy later */
10100     lcfront = lcres + (front - base);
10101     /* Now skip over each ellipsis and try to match the path in front of it. */
10102     while (ells--) {
10103       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
10104         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
10105             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
10106       if (cp1 < template) break; /* template started with an ellipsis */
10107       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
10108         ellipsis = cp1; continue;
10109       }
10110       wilddsc.dsc$a_pointer = tpl;
10111       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
10112       nextell = cp1;
10113       for (segdirs = 0, cp2 = tpl;
10114            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
10115            cp1++, cp2++) {
10116          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
10117          else {
10118             if (!decc_efs_case_preserve) {
10119               *cp2 = _tolower(*cp1);  /* else lowercase for match */
10120             }
10121             else {
10122               *cp2 = *cp1;  /* else preserve case for match */
10123             }
10124          }
10125          if (*cp2 == '/') segdirs++;
10126       }
10127       if (cp1 != ellipsis - 1) {
10128           PerlMem_free(tpl);
10129           PerlMem_free(unixified);
10130           PerlMem_free(unixwild);
10131           PerlMem_free(lcres);
10132           return 0; /* Path too long */
10133       }
10134       /* Back up at least as many dirs as in template before matching */
10135       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
10136         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
10137       for (match = 0; cp1 > lcres;) {
10138         resdsc.dsc$a_pointer = cp1;
10139         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
10140           match++;
10141           if (match == 1) lcfront = cp1;
10142         }
10143         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
10144       }
10145       if (!match) {
10146         PerlMem_free(tpl);
10147         PerlMem_free(unixified);
10148         PerlMem_free(unixwild);
10149         PerlMem_free(lcres);
10150         return 0;  /* Can't find prefix ??? */
10151       }
10152       if (match > 1 && opts & 1) {
10153         /* This ... wildcard could cover more than one set of dirs (i.e.
10154          * a set of similar dir names is repeated).  If the template
10155          * contains more than 1 ..., upstream elements could resolve the
10156          * ambiguity, but it's not worth a full backtracking setup here.
10157          * As a quick heuristic, clip off the current default directory
10158          * if it's present to find the trimmed spec, else use the
10159          * shortest string that this ... could cover.
10160          */
10161         char def[NAM$C_MAXRSS+1], *st;
10162
10163         if (getcwd(def, sizeof def,0) == NULL) {
10164             PerlMem_free(unixified);
10165             PerlMem_free(unixwild);
10166             PerlMem_free(lcres);
10167             PerlMem_free(tpl);
10168             return 0;
10169         }
10170         if (!decc_efs_case_preserve) {
10171           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
10172             if (_tolower(*cp1) != _tolower(*cp2)) break;
10173         }
10174         segdirs = dirs - totells;  /* Min # of dirs we must have left */
10175         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
10176         if (*cp1 == '\0' && *cp2 == '/') {
10177           memmove(fspec,cp2+1,end - cp2);
10178           PerlMem_free(tpl);
10179           PerlMem_free(unixified);
10180           PerlMem_free(unixwild);
10181           PerlMem_free(lcres);
10182           return 1;
10183         }
10184         /* Nope -- stick with lcfront from above and keep going. */
10185       }
10186     }
10187     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
10188     PerlMem_free(tpl);
10189     PerlMem_free(unixified);
10190     PerlMem_free(unixwild);
10191     PerlMem_free(lcres);
10192     return 1;
10193     ellipsis = nextell;
10194   }
10195
10196 }  /* end of trim_unixpath() */
10197 /*}}}*/
10198
10199
10200 /*
10201  *  VMS readdir() routines.
10202  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
10203  *
10204  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
10205  *  Minor modifications to original routines.
10206  */
10207
10208 /* readdir may have been redefined by reentr.h, so make sure we get
10209  * the local version for what we do here.
10210  */
10211 #ifdef readdir
10212 # undef readdir
10213 #endif
10214 #if !defined(PERL_IMPLICIT_CONTEXT)
10215 # define readdir Perl_readdir
10216 #else
10217 # define readdir(a) Perl_readdir(aTHX_ a)
10218 #endif
10219
10220     /* Number of elements in vms_versions array */
10221 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
10222
10223 /*
10224  *  Open a directory, return a handle for later use.
10225  */
10226 /*{{{ DIR *opendir(char*name) */
10227 DIR *
10228 Perl_opendir(pTHX_ const char *name)
10229 {
10230     DIR *dd;
10231     char *dir;
10232     Stat_t sb;
10233
10234     Newx(dir, VMS_MAXRSS, char);
10235     if (int_tovmspath(name, dir, NULL) == NULL) {
10236       Safefree(dir);
10237       return NULL;
10238     }
10239     /* Check access before stat; otherwise stat does not
10240      * accurately report whether it's a directory.
10241      */
10242     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
10243       /* cando_by_name has already set errno */
10244       Safefree(dir);
10245       return NULL;
10246     }
10247     if (flex_stat(dir,&sb) == -1) return NULL;
10248     if (!S_ISDIR(sb.st_mode)) {
10249       Safefree(dir);
10250       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
10251       return NULL;
10252     }
10253     /* Get memory for the handle, and the pattern. */
10254     Newx(dd,1,DIR);
10255     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
10256
10257     /* Fill in the fields; mainly playing with the descriptor. */
10258     sprintf(dd->pattern, "%s*.*",dir);
10259     Safefree(dir);
10260     dd->context = 0;
10261     dd->count = 0;
10262     dd->flags = 0;
10263     /* By saying we always want the result of readdir() in unix format, we
10264      * are really saying we want all the escapes removed.  Otherwise the caller,
10265      * having no way to know whether it's already in VMS format, might send it
10266      * through tovmsspec again, thus double escaping.
10267      */
10268     dd->flags = PERL_VMSDIR_M_UNIXSPECS;
10269     dd->pat.dsc$a_pointer = dd->pattern;
10270     dd->pat.dsc$w_length = strlen(dd->pattern);
10271     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
10272     dd->pat.dsc$b_class = DSC$K_CLASS_S;
10273 #if defined(USE_ITHREADS)
10274     Newx(dd->mutex,1,perl_mutex);
10275     MUTEX_INIT( (perl_mutex *) dd->mutex );
10276 #else
10277     dd->mutex = NULL;
10278 #endif
10279
10280     return dd;
10281 }  /* end of opendir() */
10282 /*}}}*/
10283
10284 /*
10285  *  Set the flag to indicate we want versions or not.
10286  */
10287 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10288 void
10289 vmsreaddirversions(DIR *dd, int flag)
10290 {
10291     if (flag)
10292         dd->flags |= PERL_VMSDIR_M_VERSIONS;
10293     else
10294         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10295 }
10296 /*}}}*/
10297
10298 /*
10299  *  Free up an opened directory.
10300  */
10301 /*{{{ void closedir(DIR *dd)*/
10302 void
10303 Perl_closedir(DIR *dd)
10304 {
10305     int sts;
10306
10307     sts = lib$find_file_end(&dd->context);
10308     Safefree(dd->pattern);
10309 #if defined(USE_ITHREADS)
10310     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10311     Safefree(dd->mutex);
10312 #endif
10313     Safefree(dd);
10314 }
10315 /*}}}*/
10316
10317 /*
10318  *  Collect all the version numbers for the current file.
10319  */
10320 static void
10321 collectversions(pTHX_ DIR *dd)
10322 {
10323     struct dsc$descriptor_s     pat;
10324     struct dsc$descriptor_s     res;
10325     struct dirent *e;
10326     char *p, *text, *buff;
10327     int i;
10328     unsigned long context, tmpsts;
10329
10330     /* Convenient shorthand. */
10331     e = &dd->entry;
10332
10333     /* Add the version wildcard, ignoring the "*.*" put on before */
10334     i = strlen(dd->pattern);
10335     Newx(text,i + e->d_namlen + 3,char);
10336     strcpy(text, dd->pattern);
10337     sprintf(&text[i - 3], "%s;*", e->d_name);
10338
10339     /* Set up the pattern descriptor. */
10340     pat.dsc$a_pointer = text;
10341     pat.dsc$w_length = i + e->d_namlen - 1;
10342     pat.dsc$b_dtype = DSC$K_DTYPE_T;
10343     pat.dsc$b_class = DSC$K_CLASS_S;
10344
10345     /* Set up result descriptor. */
10346     Newx(buff, VMS_MAXRSS, char);
10347     res.dsc$a_pointer = buff;
10348     res.dsc$w_length = VMS_MAXRSS - 1;
10349     res.dsc$b_dtype = DSC$K_DTYPE_T;
10350     res.dsc$b_class = DSC$K_CLASS_S;
10351
10352     /* Read files, collecting versions. */
10353     for (context = 0, e->vms_verscount = 0;
10354          e->vms_verscount < VERSIZE(e);
10355          e->vms_verscount++) {
10356         unsigned long rsts;
10357         unsigned long flags = 0;
10358
10359 #ifdef VMS_LONGNAME_SUPPORT
10360         flags = LIB$M_FIL_LONG_NAMES;
10361 #endif
10362         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10363         if (tmpsts == RMS$_NMF || context == 0) break;
10364         _ckvmssts(tmpsts);
10365         buff[VMS_MAXRSS - 1] = '\0';
10366         if ((p = strchr(buff, ';')))
10367             e->vms_versions[e->vms_verscount] = atoi(p + 1);
10368         else
10369             e->vms_versions[e->vms_verscount] = -1;
10370     }
10371
10372     _ckvmssts(lib$find_file_end(&context));
10373     Safefree(text);
10374     Safefree(buff);
10375
10376 }  /* end of collectversions() */
10377
10378 /*
10379  *  Read the next entry from the directory.
10380  */
10381 /*{{{ struct dirent *readdir(DIR *dd)*/
10382 struct dirent *
10383 Perl_readdir(pTHX_ DIR *dd)
10384 {
10385     struct dsc$descriptor_s     res;
10386     char *p, *buff;
10387     unsigned long int tmpsts;
10388     unsigned long rsts;
10389     unsigned long flags = 0;
10390     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10391     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10392
10393     /* Set up result descriptor, and get next file. */
10394     Newx(buff, VMS_MAXRSS, char);
10395     res.dsc$a_pointer = buff;
10396     res.dsc$w_length = VMS_MAXRSS - 1;
10397     res.dsc$b_dtype = DSC$K_DTYPE_T;
10398     res.dsc$b_class = DSC$K_CLASS_S;
10399
10400 #ifdef VMS_LONGNAME_SUPPORT
10401     flags = LIB$M_FIL_LONG_NAMES;
10402 #endif
10403
10404     tmpsts = lib$find_file
10405         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10406     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
10407     if (!(tmpsts & 1)) {
10408       set_vaxc_errno(tmpsts);
10409       switch (tmpsts) {
10410         case RMS$_PRV:
10411           set_errno(EACCES); break;
10412         case RMS$_DEV:
10413           set_errno(ENODEV); break;
10414         case RMS$_DIR:
10415           set_errno(ENOTDIR); break;
10416         case RMS$_FNF: case RMS$_DNF:
10417           set_errno(ENOENT); break;
10418         default:
10419           set_errno(EVMSERR);
10420       }
10421       Safefree(buff);
10422       return NULL;
10423     }
10424     dd->count++;
10425     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10426     buff[res.dsc$w_length] = '\0';
10427     p = buff + res.dsc$w_length;
10428     while (--p >= buff) if (!isspace(*p)) break;
10429     *p = '\0';
10430     if (!decc_efs_case_preserve) {
10431       for (p = buff; *p; p++) *p = _tolower(*p);
10432     }
10433
10434     /* Skip any directory component and just copy the name. */
10435     sts = vms_split_path
10436        (buff,
10437         &v_spec,
10438         &v_len,
10439         &r_spec,
10440         &r_len,
10441         &d_spec,
10442         &d_len,
10443         &n_spec,
10444         &n_len,
10445         &e_spec,
10446         &e_len,
10447         &vs_spec,
10448         &vs_len);
10449
10450     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10451
10452         /* In Unix report mode, remove the ".dir;1" from the name */
10453         /* if it is a real directory. */
10454         if (decc_filename_unix_report || decc_efs_charset) {
10455             if ((e_len == 4) && (vs_len == 2) && (vs_spec[1] == '1')) {
10456                 if ((toupper(e_spec[1]) == 'D') &&
10457                     (toupper(e_spec[2]) == 'I') &&
10458                     (toupper(e_spec[3]) == 'R')) {
10459                     Stat_t statbuf;
10460                     int ret_sts;
10461
10462                     ret_sts = stat(buff, &statbuf.crtl_stat);
10463                     if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10464                         e_len = 0;
10465                         e_spec[0] = 0;
10466                     }
10467                 }
10468             }
10469         }
10470
10471         /* Drop NULL extensions on UNIX file specification */
10472         if ((e_len == 1) && decc_readdir_dropdotnotype) {
10473             e_len = 0;
10474             e_spec[0] = '\0';
10475         }
10476     }
10477
10478     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
10479     dd->entry.d_name[n_len + e_len] = '\0';
10480     dd->entry.d_namlen = strlen(dd->entry.d_name);
10481
10482     /* Convert the filename to UNIX format if needed */
10483     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10484
10485         /* Translate the encoded characters. */
10486         /* Fixme: Unicode handling could result in embedded 0 characters */
10487         if (strchr(dd->entry.d_name, '^') != NULL) {
10488             char new_name[256];
10489             char * q;
10490             p = dd->entry.d_name;
10491             q = new_name;
10492             while (*p != 0) {
10493                 int inchars_read, outchars_added;
10494                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10495                 p += inchars_read;
10496                 q += outchars_added;
10497                 /* fix-me */
10498                 /* if outchars_added > 1, then this is a wide file specification */
10499                 /* Wide file specifications need to be passed in Perl */
10500                 /* counted strings apparently with a Unicode flag */
10501             }
10502             *q = 0;
10503             strcpy(dd->entry.d_name, new_name);
10504             dd->entry.d_namlen = strlen(dd->entry.d_name);
10505         }
10506     }
10507
10508     dd->entry.vms_verscount = 0;
10509     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10510     Safefree(buff);
10511     return &dd->entry;
10512
10513 }  /* end of readdir() */
10514 /*}}}*/
10515
10516 /*
10517  *  Read the next entry from the directory -- thread-safe version.
10518  */
10519 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10520 int
10521 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10522 {
10523     int retval;
10524
10525     MUTEX_LOCK( (perl_mutex *) dd->mutex );
10526
10527     entry = readdir(dd);
10528     *result = entry;
10529     retval = ( *result == NULL ? errno : 0 );
10530
10531     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10532
10533     return retval;
10534
10535 }  /* end of readdir_r() */
10536 /*}}}*/
10537
10538 /*
10539  *  Return something that can be used in a seekdir later.
10540  */
10541 /*{{{ long telldir(DIR *dd)*/
10542 long
10543 Perl_telldir(DIR *dd)
10544 {
10545     return dd->count;
10546 }
10547 /*}}}*/
10548
10549 /*
10550  *  Return to a spot where we used to be.  Brute force.
10551  */
10552 /*{{{ void seekdir(DIR *dd,long count)*/
10553 void
10554 Perl_seekdir(pTHX_ DIR *dd, long count)
10555 {
10556     int old_flags;
10557
10558     /* If we haven't done anything yet... */
10559     if (dd->count == 0)
10560         return;
10561
10562     /* Remember some state, and clear it. */
10563     old_flags = dd->flags;
10564     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10565     _ckvmssts(lib$find_file_end(&dd->context));
10566     dd->context = 0;
10567
10568     /* The increment is in readdir(). */
10569     for (dd->count = 0; dd->count < count; )
10570         readdir(dd);
10571
10572     dd->flags = old_flags;
10573
10574 }  /* end of seekdir() */
10575 /*}}}*/
10576
10577 /* VMS subprocess management
10578  *
10579  * my_vfork() - just a vfork(), after setting a flag to record that
10580  * the current script is trying a Unix-style fork/exec.
10581  *
10582  * vms_do_aexec() and vms_do_exec() are called in response to the
10583  * perl 'exec' function.  If this follows a vfork call, then they
10584  * call out the regular perl routines in doio.c which do an
10585  * execvp (for those who really want to try this under VMS).
10586  * Otherwise, they do exactly what the perl docs say exec should
10587  * do - terminate the current script and invoke a new command
10588  * (See below for notes on command syntax.)
10589  *
10590  * do_aspawn() and do_spawn() implement the VMS side of the perl
10591  * 'system' function.
10592  *
10593  * Note on command arguments to perl 'exec' and 'system': When handled
10594  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10595  * are concatenated to form a DCL command string.  If the first non-numeric
10596  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10597  * the command string is handed off to DCL directly.  Otherwise,
10598  * the first token of the command is taken as the filespec of an image
10599  * to run.  The filespec is expanded using a default type of '.EXE' and
10600  * the process defaults for device, directory, etc., and if found, the resultant
10601  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10602  * the command string as parameters.  This is perhaps a bit complicated,
10603  * but I hope it will form a happy medium between what VMS folks expect
10604  * from lib$spawn and what Unix folks expect from exec.
10605  */
10606
10607 static int vfork_called;
10608
10609 /*{{{int my_vfork()*/
10610 int
10611 my_vfork()
10612 {
10613   vfork_called++;
10614   return vfork();
10615 }
10616 /*}}}*/
10617
10618
10619 static void
10620 vms_execfree(struct dsc$descriptor_s *vmscmd)
10621 {
10622   if (vmscmd) {
10623       if (vmscmd->dsc$a_pointer) {
10624           PerlMem_free(vmscmd->dsc$a_pointer);
10625       }
10626       PerlMem_free(vmscmd);
10627   }
10628 }
10629
10630 static char *
10631 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10632 {
10633   char *junk, *tmps = NULL;
10634   register size_t cmdlen = 0;
10635   size_t rlen;
10636   register SV **idx;
10637   STRLEN n_a;
10638
10639   idx = mark;
10640   if (really) {
10641     tmps = SvPV(really,rlen);
10642     if (*tmps) {
10643       cmdlen += rlen + 1;
10644       idx++;
10645     }
10646   }
10647
10648   for (idx++; idx <= sp; idx++) {
10649     if (*idx) {
10650       junk = SvPVx(*idx,rlen);
10651       cmdlen += rlen ? rlen + 1 : 0;
10652     }
10653   }
10654   Newx(PL_Cmd, cmdlen+1, char);
10655
10656   if (tmps && *tmps) {
10657     strcpy(PL_Cmd,tmps);
10658     mark++;
10659   }
10660   else *PL_Cmd = '\0';
10661   while (++mark <= sp) {
10662     if (*mark) {
10663       char *s = SvPVx(*mark,n_a);
10664       if (!*s) continue;
10665       if (*PL_Cmd) strcat(PL_Cmd," ");
10666       strcat(PL_Cmd,s);
10667     }
10668   }
10669   return PL_Cmd;
10670
10671 }  /* end of setup_argstr() */
10672
10673
10674 static unsigned long int
10675 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10676                    struct dsc$descriptor_s **pvmscmd)
10677 {
10678   char * vmsspec;
10679   char * resspec;
10680   char image_name[NAM$C_MAXRSS+1];
10681   char image_argv[NAM$C_MAXRSS+1];
10682   $DESCRIPTOR(defdsc,".EXE");
10683   $DESCRIPTOR(defdsc2,".");
10684   struct dsc$descriptor_s resdsc;
10685   struct dsc$descriptor_s *vmscmd;
10686   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10687   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10688   register char *s, *rest, *cp, *wordbreak;
10689   char * cmd;
10690   int cmdlen;
10691   register int isdcl;
10692
10693   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10694   if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10695
10696   /* vmsspec is a DCL command buffer, not just a filename */
10697   vmsspec = PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10698   if (vmsspec == NULL)
10699       _ckvmssts_noperl(SS$_INSFMEM);
10700
10701   resspec = PerlMem_malloc(VMS_MAXRSS);
10702   if (resspec == NULL)
10703       _ckvmssts_noperl(SS$_INSFMEM);
10704
10705   /* Make a copy for modification */
10706   cmdlen = strlen(incmd);
10707   cmd = PerlMem_malloc(cmdlen+1);
10708   if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10709   strncpy(cmd, incmd, cmdlen);
10710   cmd[cmdlen] = 0;
10711   image_name[0] = 0;
10712   image_argv[0] = 0;
10713
10714   resdsc.dsc$a_pointer = resspec;
10715   resdsc.dsc$b_dtype  = DSC$K_DTYPE_T;
10716   resdsc.dsc$b_class  = DSC$K_CLASS_S;
10717   resdsc.dsc$w_length = VMS_MAXRSS - 1;
10718
10719   vmscmd->dsc$a_pointer = NULL;
10720   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
10721   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
10722   vmscmd->dsc$w_length = 0;
10723   if (pvmscmd) *pvmscmd = vmscmd;
10724
10725   if (suggest_quote) *suggest_quote = 0;
10726
10727   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10728     PerlMem_free(cmd);
10729     PerlMem_free(vmsspec);
10730     PerlMem_free(resspec);
10731     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
10732   }
10733
10734   s = cmd;
10735
10736   while (*s && isspace(*s)) s++;
10737
10738   if (*s == '@' || *s == '$') {
10739     vmsspec[0] = *s;  rest = s + 1;
10740     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10741   }
10742   else { cp = vmsspec; rest = s; }
10743   if (*rest == '.' || *rest == '/') {
10744     char *cp2;
10745     for (cp2 = resspec;
10746          *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10747          rest++, cp2++) *cp2 = *rest;
10748     *cp2 = '\0';
10749     if (int_tovmsspec(resspec, cp, 0, NULL)) {
10750       s = vmsspec;
10751
10752       /* When a UNIX spec with no file type is translated to VMS, */
10753       /* A trailing '.' is appended under ODS-5 rules.            */
10754       /* Here we do not want that trailing "." as it prevents     */
10755       /* Looking for a implied ".exe" type. */
10756       if (decc_efs_charset) {
10757           int i;
10758           i = strlen(vmsspec);
10759           if (vmsspec[i-1] == '.') {
10760               vmsspec[i-1] = '\0';
10761           }
10762       }
10763
10764       if (*rest) {
10765         for (cp2 = vmsspec + strlen(vmsspec);
10766              *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10767              rest++, cp2++) *cp2 = *rest;
10768         *cp2 = '\0';
10769       }
10770     }
10771   }
10772   /* Intuit whether verb (first word of cmd) is a DCL command:
10773    *   - if first nonspace char is '@', it's a DCL indirection
10774    * otherwise
10775    *   - if verb contains a filespec separator, it's not a DCL command
10776    *   - if it doesn't, caller tells us whether to default to a DCL
10777    *     command, or to a local image unless told it's DCL (by leading '$')
10778    */
10779   if (*s == '@') {
10780       isdcl = 1;
10781       if (suggest_quote) *suggest_quote = 1;
10782   } else {
10783     register char *filespec = strpbrk(s,":<[.;");
10784     rest = wordbreak = strpbrk(s," \"\t/");
10785     if (!wordbreak) wordbreak = s + strlen(s);
10786     if (*s == '$') check_img = 0;
10787     if (filespec && (filespec < wordbreak)) isdcl = 0;
10788     else isdcl = !check_img;
10789   }
10790
10791   if (!isdcl) {
10792     int rsts;
10793     imgdsc.dsc$a_pointer = s;
10794     imgdsc.dsc$w_length = wordbreak - s;
10795     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10796     if (!(retsts&1)) {
10797         _ckvmssts_noperl(lib$find_file_end(&cxt));
10798         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10799       if (!(retsts & 1) && *s == '$') {
10800         _ckvmssts_noperl(lib$find_file_end(&cxt));
10801         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10802         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10803         if (!(retsts&1)) {
10804           _ckvmssts_noperl(lib$find_file_end(&cxt));
10805           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10806         }
10807       }
10808     }
10809     _ckvmssts_noperl(lib$find_file_end(&cxt));
10810
10811     if (retsts & 1) {
10812       FILE *fp;
10813       s = resspec;
10814       while (*s && !isspace(*s)) s++;
10815       *s = '\0';
10816
10817       /* check that it's really not DCL with no file extension */
10818       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10819       if (fp) {
10820         char b[256] = {0,0,0,0};
10821         read(fileno(fp), b, 256);
10822         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10823         if (isdcl) {
10824           int shebang_len;
10825
10826           /* Check for script */
10827           shebang_len = 0;
10828           if ((b[0] == '#') && (b[1] == '!'))
10829              shebang_len = 2;
10830 #ifdef ALTERNATE_SHEBANG
10831           else {
10832             shebang_len = strlen(ALTERNATE_SHEBANG);
10833             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10834               char * perlstr;
10835                 perlstr = strstr("perl",b);
10836                 if (perlstr == NULL)
10837                   shebang_len = 0;
10838             }
10839             else
10840               shebang_len = 0;
10841           }
10842 #endif
10843
10844           if (shebang_len > 0) {
10845           int i;
10846           int j;
10847           char tmpspec[NAM$C_MAXRSS + 1];
10848
10849             i = shebang_len;
10850              /* Image is following after white space */
10851             /*--------------------------------------*/
10852             while (isprint(b[i]) && isspace(b[i]))
10853                 i++;
10854
10855             j = 0;
10856             while (isprint(b[i]) && !isspace(b[i])) {
10857                 tmpspec[j++] = b[i++];
10858                 if (j >= NAM$C_MAXRSS)
10859                    break;
10860             }
10861             tmpspec[j] = '\0';
10862
10863              /* There may be some default parameters to the image */
10864             /*---------------------------------------------------*/
10865             j = 0;
10866             while (isprint(b[i])) {
10867                 image_argv[j++] = b[i++];
10868                 if (j >= NAM$C_MAXRSS)
10869                    break;
10870             }
10871             while ((j > 0) && !isprint(image_argv[j-1]))
10872                 j--;
10873             image_argv[j] = 0;
10874
10875             /* It will need to be converted to VMS format and validated */
10876             if (tmpspec[0] != '\0') {
10877               char * iname;
10878
10879                /* Try to find the exact program requested to be run */
10880               /*---------------------------------------------------*/
10881               iname = int_rmsexpand
10882                  (tmpspec, image_name, ".exe",
10883                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10884               if (iname != NULL) {
10885                 if (cando_by_name_int
10886                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10887                   /* MCR prefix needed */
10888                   isdcl = 0;
10889                 }
10890                 else {
10891                    /* Try again with a null type */
10892                   /*----------------------------*/
10893                   iname = int_rmsexpand
10894                     (tmpspec, image_name, ".",
10895                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10896                   if (iname != NULL) {
10897                     if (cando_by_name_int
10898                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10899                       /* MCR prefix needed */
10900                       isdcl = 0;
10901                     }
10902                   }
10903                 }
10904
10905                  /* Did we find the image to run the script? */
10906                 /*------------------------------------------*/
10907                 if (isdcl) {
10908                   char *tchr;
10909
10910                    /* Assume DCL or foreign command exists */
10911                   /*--------------------------------------*/
10912                   tchr = strrchr(tmpspec, '/');
10913                   if (tchr != NULL) {
10914                     tchr++;
10915                   }
10916                   else {
10917                     tchr = tmpspec;
10918                   }
10919                   strcpy(image_name, tchr);
10920                 }
10921               }
10922             }
10923           }
10924         }
10925         fclose(fp);
10926       }
10927       if (check_img && isdcl) {
10928           PerlMem_free(cmd);
10929           PerlMem_free(resspec);
10930           PerlMem_free(vmsspec);
10931           return RMS$_FNF;
10932       }
10933
10934       if (cando_by_name(S_IXUSR,0,resspec)) {
10935         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10936         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10937         if (!isdcl) {
10938             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
10939             if (image_name[0] != 0) {
10940                 strcat(vmscmd->dsc$a_pointer, image_name);
10941                 strcat(vmscmd->dsc$a_pointer, " ");
10942             }
10943         } else if (image_name[0] != 0) {
10944             strcpy(vmscmd->dsc$a_pointer, image_name);
10945             strcat(vmscmd->dsc$a_pointer, " ");
10946         } else {
10947             strcpy(vmscmd->dsc$a_pointer,"@");
10948         }
10949         if (suggest_quote) *suggest_quote = 1;
10950
10951         /* If there is an image name, use original command */
10952         if (image_name[0] == 0)
10953             strcat(vmscmd->dsc$a_pointer,resspec);
10954         else {
10955             rest = cmd;
10956             while (*rest && isspace(*rest)) rest++;
10957         }
10958
10959         if (image_argv[0] != 0) {
10960           strcat(vmscmd->dsc$a_pointer,image_argv);
10961           strcat(vmscmd->dsc$a_pointer, " ");
10962         }
10963         if (rest) {
10964            int rest_len;
10965            int vmscmd_len;
10966
10967            rest_len = strlen(rest);
10968            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10969            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10970               strcat(vmscmd->dsc$a_pointer,rest);
10971            else
10972              retsts = CLI$_BUFOVF;
10973         }
10974         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10975         PerlMem_free(cmd);
10976         PerlMem_free(vmsspec);
10977         PerlMem_free(resspec);
10978         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10979       }
10980       else
10981         retsts = RMS$_PRV;
10982     }
10983   }
10984   /* It's either a DCL command or we couldn't find a suitable image */
10985   vmscmd->dsc$w_length = strlen(cmd);
10986
10987   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
10988   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
10989   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
10990
10991   PerlMem_free(cmd);
10992   PerlMem_free(resspec);
10993   PerlMem_free(vmsspec);
10994
10995   /* check if it's a symbol (for quoting purposes) */
10996   if (suggest_quote && !*suggest_quote) {
10997     int iss;
10998     char equiv[LNM$C_NAMLENGTH];
10999     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11000     eqvdsc.dsc$a_pointer = equiv;
11001
11002     iss = lib$get_symbol(vmscmd,&eqvdsc);
11003     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
11004   }
11005   if (!(retsts & 1)) {
11006     /* just hand off status values likely to be due to user error */
11007     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
11008         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
11009        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
11010     else { _ckvmssts_noperl(retsts); }
11011   }
11012
11013   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
11014
11015 }  /* end of setup_cmddsc() */
11016
11017
11018 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
11019 bool
11020 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
11021 {
11022 bool exec_sts;
11023 char * cmd;
11024
11025   if (sp > mark) {
11026     if (vfork_called) {           /* this follows a vfork - act Unixish */
11027       vfork_called--;
11028       if (vfork_called < 0) {
11029         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
11030         vfork_called = 0;
11031       }
11032       else return do_aexec(really,mark,sp);
11033     }
11034                                            /* no vfork - act VMSish */
11035     cmd = setup_argstr(aTHX_ really,mark,sp);
11036     exec_sts = vms_do_exec(cmd);
11037     Safefree(cmd);  /* Clean up from setup_argstr() */
11038     return exec_sts;
11039   }
11040
11041   return FALSE;
11042 }  /* end of vms_do_aexec() */
11043 /*}}}*/
11044
11045 /* {{{bool vms_do_exec(char *cmd) */
11046 bool
11047 Perl_vms_do_exec(pTHX_ const char *cmd)
11048 {
11049   struct dsc$descriptor_s *vmscmd;
11050
11051   if (vfork_called) {             /* this follows a vfork - act Unixish */
11052     vfork_called--;
11053     if (vfork_called < 0) {
11054       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
11055       vfork_called = 0;
11056     }
11057     else return do_exec(cmd);
11058   }
11059
11060   {                               /* no vfork - act VMSish */
11061     unsigned long int retsts;
11062
11063     TAINT_ENV();
11064     TAINT_PROPER("exec");
11065     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
11066       retsts = lib$do_command(vmscmd);
11067
11068     switch (retsts) {
11069       case RMS$_FNF: case RMS$_DNF:
11070         set_errno(ENOENT); break;
11071       case RMS$_DIR:
11072         set_errno(ENOTDIR); break;
11073       case RMS$_DEV:
11074         set_errno(ENODEV); break;
11075       case RMS$_PRV:
11076         set_errno(EACCES); break;
11077       case RMS$_SYN:
11078         set_errno(EINVAL); break;
11079       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11080         set_errno(E2BIG); break;
11081       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11082         _ckvmssts_noperl(retsts); /* fall through */
11083       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11084         set_errno(EVMSERR);
11085     }
11086     set_vaxc_errno(retsts);
11087     if (ckWARN(WARN_EXEC)) {
11088       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
11089              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
11090     }
11091     vms_execfree(vmscmd);
11092   }
11093
11094   return FALSE;
11095
11096 }  /* end of vms_do_exec() */
11097 /*}}}*/
11098
11099 int do_spawn2(pTHX_ const char *, int);
11100
11101 int
11102 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
11103 {
11104 unsigned long int sts;
11105 char * cmd;
11106 int flags = 0;
11107
11108   if (sp > mark) {
11109
11110     /* We'll copy the (undocumented?) Win32 behavior and allow a
11111      * numeric first argument.  But the only value we'll support
11112      * through do_aspawn is a value of 1, which means spawn without
11113      * waiting for completion -- other values are ignored.
11114      */
11115     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
11116         ++mark;
11117         flags = SvIVx(*mark);
11118     }
11119
11120     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
11121         flags = CLI$M_NOWAIT;
11122     else
11123         flags = 0;
11124
11125     cmd = setup_argstr(aTHX_ really, mark, sp);
11126     sts = do_spawn2(aTHX_ cmd, flags);
11127     /* pp_sys will clean up cmd */
11128     return sts;
11129   }
11130   return SS$_ABORT;
11131 }  /* end of do_aspawn() */
11132 /*}}}*/
11133
11134
11135 /* {{{int do_spawn(char* cmd) */
11136 int
11137 Perl_do_spawn(pTHX_ char* cmd)
11138 {
11139     PERL_ARGS_ASSERT_DO_SPAWN;
11140
11141     return do_spawn2(aTHX_ cmd, 0);
11142 }
11143 /*}}}*/
11144
11145 /* {{{int do_spawn_nowait(char* cmd) */
11146 int
11147 Perl_do_spawn_nowait(pTHX_ char* cmd)
11148 {
11149     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
11150
11151     return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
11152 }
11153 /*}}}*/
11154
11155 /* {{{int do_spawn2(char *cmd) */
11156 int
11157 do_spawn2(pTHX_ const char *cmd, int flags)
11158 {
11159   unsigned long int sts, substs;
11160
11161   /* The caller of this routine expects to Safefree(PL_Cmd) */
11162   Newx(PL_Cmd,10,char);
11163
11164   TAINT_ENV();
11165   TAINT_PROPER("spawn");
11166   if (!cmd || !*cmd) {
11167     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
11168     if (!(sts & 1)) {
11169       switch (sts) {
11170         case RMS$_FNF:  case RMS$_DNF:
11171           set_errno(ENOENT); break;
11172         case RMS$_DIR:
11173           set_errno(ENOTDIR); break;
11174         case RMS$_DEV:
11175           set_errno(ENODEV); break;
11176         case RMS$_PRV:
11177           set_errno(EACCES); break;
11178         case RMS$_SYN:
11179           set_errno(EINVAL); break;
11180         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11181           set_errno(E2BIG); break;
11182         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11183           _ckvmssts_noperl(sts); /* fall through */
11184         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11185           set_errno(EVMSERR);
11186       }
11187       set_vaxc_errno(sts);
11188       if (ckWARN(WARN_EXEC)) {
11189         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
11190                     Strerror(errno));
11191       }
11192     }
11193     sts = substs;
11194   }
11195   else {
11196     char mode[3];
11197     PerlIO * fp;
11198     if (flags & CLI$M_NOWAIT)
11199         strcpy(mode, "n");
11200     else
11201         strcpy(mode, "nW");
11202
11203     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
11204     if (fp != NULL)
11205       my_pclose(fp);
11206     /* sts will be the pid in the nowait case */
11207   }
11208   return sts;
11209 }  /* end of do_spawn2() */
11210 /*}}}*/
11211
11212
11213 static unsigned int *sockflags, sockflagsize;
11214
11215 /*
11216  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
11217  * routines found in some versions of the CRTL can't deal with sockets.
11218  * We don't shim the other file open routines since a socket isn't
11219  * likely to be opened by a name.
11220  */
11221 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
11222 FILE *my_fdopen(int fd, const char *mode)
11223 {
11224   FILE *fp = fdopen(fd, mode);
11225
11226   if (fp) {
11227     unsigned int fdoff = fd / sizeof(unsigned int);
11228     Stat_t sbuf; /* native stat; we don't need flex_stat */
11229     if (!sockflagsize || fdoff > sockflagsize) {
11230       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
11231       else           Newx  (sockflags,fdoff+2,unsigned int);
11232       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11233       sockflagsize = fdoff + 2;
11234     }
11235     if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
11236       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11237   }
11238   return fp;
11239
11240 }
11241 /*}}}*/
11242
11243
11244 /*
11245  * Clear the corresponding bit when the (possibly) socket stream is closed.
11246  * There still a small hole: we miss an implicit close which might occur
11247  * via freopen().  >> Todo
11248  */
11249 /*{{{ int my_fclose(FILE *fp)*/
11250 int my_fclose(FILE *fp) {
11251   if (fp) {
11252     unsigned int fd = fileno(fp);
11253     unsigned int fdoff = fd / sizeof(unsigned int);
11254
11255     if (sockflagsize && fdoff < sockflagsize)
11256       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11257   }
11258   return fclose(fp);
11259 }
11260 /*}}}*/
11261
11262
11263 /*
11264  * A simple fwrite replacement which outputs itmsz*nitm chars without
11265  * introducing record boundaries every itmsz chars.
11266  * We are using fputs, which depends on a terminating null.  We may
11267  * well be writing binary data, so we need to accommodate not only
11268  * data with nulls sprinkled in the middle but also data with no null
11269  * byte at the end.
11270  */
11271 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
11272 int
11273 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11274 {
11275   register char *cp, *end, *cpd, *data;
11276   register unsigned int fd = fileno(dest);
11277   register unsigned int fdoff = fd / sizeof(unsigned int);
11278   int retval;
11279   int bufsize = itmsz * nitm + 1;
11280
11281   if (fdoff < sockflagsize &&
11282       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11283     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11284     return nitm;
11285   }
11286
11287   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11288   memcpy( data, src, itmsz*nitm );
11289   data[itmsz*nitm] = '\0';
11290
11291   end = data + itmsz * nitm;
11292   retval = (int) nitm; /* on success return # items written */
11293
11294   cpd = data;
11295   while (cpd <= end) {
11296     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11297     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11298     if (cp < end)
11299       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11300     cpd = cp + 1;
11301   }
11302
11303   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11304   return retval;
11305
11306 }  /* end of my_fwrite() */
11307 /*}}}*/
11308
11309 /*{{{ int my_flush(FILE *fp)*/
11310 int
11311 Perl_my_flush(pTHX_ FILE *fp)
11312 {
11313     int res;
11314     if ((res = fflush(fp)) == 0 && fp) {
11315 #ifdef VMS_DO_SOCKETS
11316         Stat_t s;
11317         if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11318 #endif
11319             res = fsync(fileno(fp));
11320     }
11321 /*
11322  * If the flush succeeded but set end-of-file, we need to clear
11323  * the error because our caller may check ferror().  BTW, this
11324  * probably means we just flushed an empty file.
11325  */
11326     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11327
11328     return res;
11329 }
11330 /*}}}*/
11331
11332 /*
11333  * Here are replacements for the following Unix routines in the VMS environment:
11334  *      getpwuid    Get information for a particular UIC or UID
11335  *      getpwnam    Get information for a named user
11336  *      getpwent    Get information for each user in the rights database
11337  *      setpwent    Reset search to the start of the rights database
11338  *      endpwent    Finish searching for users in the rights database
11339  *
11340  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11341  * (defined in pwd.h), which contains the following fields:-
11342  *      struct passwd {
11343  *              char        *pw_name;    Username (in lower case)
11344  *              char        *pw_passwd;  Hashed password
11345  *              unsigned int pw_uid;     UIC
11346  *              unsigned int pw_gid;     UIC group  number
11347  *              char        *pw_unixdir; Default device/directory (VMS-style)
11348  *              char        *pw_gecos;   Owner name
11349  *              char        *pw_dir;     Default device/directory (Unix-style)
11350  *              char        *pw_shell;   Default CLI name (eg. DCL)
11351  *      };
11352  * If the specified user does not exist, getpwuid and getpwnam return NULL.
11353  *
11354  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11355  * not the UIC member number (eg. what's returned by getuid()),
11356  * getpwuid() can accept either as input (if uid is specified, the caller's
11357  * UIC group is used), though it won't recognise gid=0.
11358  *
11359  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11360  * information about other users in your group or in other groups, respectively.
11361  * If the required privilege is not available, then these routines fill only
11362  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11363  * string).
11364  *
11365  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11366  */
11367
11368 /* sizes of various UAF record fields */
11369 #define UAI$S_USERNAME 12
11370 #define UAI$S_IDENT    31
11371 #define UAI$S_OWNER    31
11372 #define UAI$S_DEFDEV   31
11373 #define UAI$S_DEFDIR   63
11374 #define UAI$S_DEFCLI   31
11375 #define UAI$S_PWD       8
11376
11377 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
11378                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11379                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
11380
11381 static char __empty[]= "";
11382 static struct passwd __passwd_empty=
11383     {(char *) __empty, (char *) __empty, 0, 0,
11384      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11385 static int contxt= 0;
11386 static struct passwd __pwdcache;
11387 static char __pw_namecache[UAI$S_IDENT+1];
11388
11389 /*
11390  * This routine does most of the work extracting the user information.
11391  */
11392 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11393 {
11394     static struct {
11395         unsigned char length;
11396         char pw_gecos[UAI$S_OWNER+1];
11397     } owner;
11398     static union uicdef uic;
11399     static struct {
11400         unsigned char length;
11401         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11402     } defdev;
11403     static struct {
11404         unsigned char length;
11405         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11406     } defdir;
11407     static struct {
11408         unsigned char length;
11409         char pw_shell[UAI$S_DEFCLI+1];
11410     } defcli;
11411     static char pw_passwd[UAI$S_PWD+1];
11412
11413     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11414     struct dsc$descriptor_s name_desc;
11415     unsigned long int sts;
11416
11417     static struct itmlst_3 itmlst[]= {
11418         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
11419         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
11420         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
11421         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
11422         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
11423         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
11424         {0,                0,           NULL,    NULL}};
11425
11426     name_desc.dsc$w_length=  strlen(name);
11427     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11428     name_desc.dsc$b_class=   DSC$K_CLASS_S;
11429     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11430
11431 /*  Note that sys$getuai returns many fields as counted strings. */
11432     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11433     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11434       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11435     }
11436     else { _ckvmssts(sts); }
11437     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
11438
11439     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
11440     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11441     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11442     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11443     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11444     owner.pw_gecos[lowner]=            '\0';
11445     defdev.pw_dir[ldefdev+ldefdir]= '\0';
11446     defcli.pw_shell[ldefcli]=          '\0';
11447     if (valid_uic(uic)) {
11448         pwd->pw_uid= uic.uic$l_uic;
11449         pwd->pw_gid= uic.uic$v_group;
11450     }
11451     else
11452       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11453     pwd->pw_passwd=  pw_passwd;
11454     pwd->pw_gecos=   owner.pw_gecos;
11455     pwd->pw_dir=     defdev.pw_dir;
11456     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11457     pwd->pw_shell=   defcli.pw_shell;
11458     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11459         int ldir;
11460         ldir= strlen(pwd->pw_unixdir) - 1;
11461         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11462     }
11463     else
11464         strcpy(pwd->pw_unixdir, pwd->pw_dir);
11465     if (!decc_efs_case_preserve)
11466         __mystrtolower(pwd->pw_unixdir);
11467     return 1;
11468 }
11469
11470 /*
11471  * Get information for a named user.
11472 */
11473 /*{{{struct passwd *getpwnam(char *name)*/
11474 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
11475 {
11476     struct dsc$descriptor_s name_desc;
11477     union uicdef uic;
11478     unsigned long int status, sts;
11479
11480     __pwdcache = __passwd_empty;
11481     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11482       /* We still may be able to determine pw_uid and pw_gid */
11483       name_desc.dsc$w_length=  strlen(name);
11484       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11485       name_desc.dsc$b_class=   DSC$K_CLASS_S;
11486       name_desc.dsc$a_pointer= (char *) name;
11487       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11488         __pwdcache.pw_uid= uic.uic$l_uic;
11489         __pwdcache.pw_gid= uic.uic$v_group;
11490       }
11491       else {
11492         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11493           set_vaxc_errno(sts);
11494           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11495           return NULL;
11496         }
11497         else { _ckvmssts(sts); }
11498       }
11499     }
11500     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
11501     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
11502     __pwdcache.pw_name= __pw_namecache;
11503     return &__pwdcache;
11504 }  /* end of my_getpwnam() */
11505 /*}}}*/
11506
11507 /*
11508  * Get information for a particular UIC or UID.
11509  * Called by my_getpwent with uid=-1 to list all users.
11510 */
11511 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11512 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
11513 {
11514     const $DESCRIPTOR(name_desc,__pw_namecache);
11515     unsigned short lname;
11516     union uicdef uic;
11517     unsigned long int status;
11518
11519     if (uid == (unsigned int) -1) {
11520       do {
11521         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11522         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11523           set_vaxc_errno(status);
11524           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11525           my_endpwent();
11526           return NULL;
11527         }
11528         else { _ckvmssts(status); }
11529       } while (!valid_uic (uic));
11530     }
11531     else {
11532       uic.uic$l_uic= uid;
11533       if (!uic.uic$v_group)
11534         uic.uic$v_group= PerlProc_getgid();
11535       if (valid_uic(uic))
11536         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11537       else status = SS$_IVIDENT;
11538       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11539           status == RMS$_PRV) {
11540         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11541         return NULL;
11542       }
11543       else { _ckvmssts(status); }
11544     }
11545     __pw_namecache[lname]= '\0';
11546     __mystrtolower(__pw_namecache);
11547
11548     __pwdcache = __passwd_empty;
11549     __pwdcache.pw_name = __pw_namecache;
11550
11551 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11552     The identifier's value is usually the UIC, but it doesn't have to be,
11553     so if we can, we let fillpasswd update this. */
11554     __pwdcache.pw_uid =  uic.uic$l_uic;
11555     __pwdcache.pw_gid =  uic.uic$v_group;
11556
11557     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11558     return &__pwdcache;
11559
11560 }  /* end of my_getpwuid() */
11561 /*}}}*/
11562
11563 /*
11564  * Get information for next user.
11565 */
11566 /*{{{struct passwd *my_getpwent()*/
11567 struct passwd *Perl_my_getpwent(pTHX)
11568 {
11569     return (my_getpwuid((unsigned int) -1));
11570 }
11571 /*}}}*/
11572
11573 /*
11574  * Finish searching rights database for users.
11575 */
11576 /*{{{void my_endpwent()*/
11577 void Perl_my_endpwent(pTHX)
11578 {
11579     if (contxt) {
11580       _ckvmssts(sys$finish_rdb(&contxt));
11581       contxt= 0;
11582     }
11583 }
11584 /*}}}*/
11585
11586 #ifdef HOMEGROWN_POSIX_SIGNALS
11587   /* Signal handling routines, pulled into the core from POSIX.xs.
11588    *
11589    * We need these for threads, so they've been rolled into the core,
11590    * rather than left in POSIX.xs.
11591    *
11592    * (DRS, Oct 23, 1997)
11593    */
11594
11595   /* sigset_t is atomic under VMS, so these routines are easy */
11596 /*{{{int my_sigemptyset(sigset_t *) */
11597 int my_sigemptyset(sigset_t *set) {
11598     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11599     *set = 0; return 0;
11600 }
11601 /*}}}*/
11602
11603
11604 /*{{{int my_sigfillset(sigset_t *)*/
11605 int my_sigfillset(sigset_t *set) {
11606     int i;
11607     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11608     for (i = 0; i < NSIG; i++) *set |= (1 << i);
11609     return 0;
11610 }
11611 /*}}}*/
11612
11613
11614 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
11615 int my_sigaddset(sigset_t *set, int sig) {
11616     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11617     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11618     *set |= (1 << (sig - 1));
11619     return 0;
11620 }
11621 /*}}}*/
11622
11623
11624 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
11625 int my_sigdelset(sigset_t *set, int sig) {
11626     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11627     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11628     *set &= ~(1 << (sig - 1));
11629     return 0;
11630 }
11631 /*}}}*/
11632
11633
11634 /*{{{int my_sigismember(sigset_t *set, int sig)*/
11635 int my_sigismember(sigset_t *set, int sig) {
11636     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11637     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11638     return *set & (1 << (sig - 1));
11639 }
11640 /*}}}*/
11641
11642
11643 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
11644 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
11645     sigset_t tempmask;
11646
11647     /* If set and oset are both null, then things are badly wrong. Bail out. */
11648     if ((oset == NULL) && (set == NULL)) {
11649       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
11650       return -1;
11651     }
11652
11653     /* If set's null, then we're just handling a fetch. */
11654     if (set == NULL) {
11655         tempmask = sigblock(0);
11656     }
11657     else {
11658       switch (how) {
11659       case SIG_SETMASK:
11660         tempmask = sigsetmask(*set);
11661         break;
11662       case SIG_BLOCK:
11663         tempmask = sigblock(*set);
11664         break;
11665       case SIG_UNBLOCK:
11666         tempmask = sigblock(0);
11667         sigsetmask(*oset & ~tempmask);
11668         break;
11669       default:
11670         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11671         return -1;
11672       }
11673     }
11674
11675     /* Did they pass us an oset? If so, stick our holding mask into it */
11676     if (oset)
11677       *oset = tempmask;
11678
11679     return 0;
11680 }
11681 /*}}}*/
11682 #endif  /* HOMEGROWN_POSIX_SIGNALS */
11683
11684
11685 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11686  * my_utime(), and flex_stat(), all of which operate on UTC unless
11687  * VMSISH_TIMES is true.
11688  */
11689 /* method used to handle UTC conversions:
11690  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
11691  */
11692 static int gmtime_emulation_type;
11693 /* number of secs to add to UTC POSIX-style time to get local time */
11694 static long int utc_offset_secs;
11695
11696 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11697  * in vmsish.h.  #undef them here so we can call the CRTL routines
11698  * directly.
11699  */
11700 #undef gmtime
11701 #undef localtime
11702 #undef time
11703
11704
11705 /*
11706  * DEC C previous to 6.0 corrupts the behavior of the /prefix
11707  * qualifier with the extern prefix pragma.  This provisional
11708  * hack circumvents this prefix pragma problem in previous
11709  * precompilers.
11710  */
11711 #if defined(__VMS_VER) && __VMS_VER >= 70000000
11712 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
11713 #    pragma __extern_prefix save
11714 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
11715 #    define gmtime decc$__utctz_gmtime
11716 #    define localtime decc$__utctz_localtime
11717 #    define time decc$__utc_time
11718 #    pragma __extern_prefix restore
11719
11720      struct tm *gmtime(), *localtime();
11721
11722 #  endif
11723 #endif
11724
11725
11726 static time_t toutc_dst(time_t loc) {
11727   struct tm *rsltmp;
11728
11729   if ((rsltmp = localtime(&loc)) == NULL) return -1;
11730   loc -= utc_offset_secs;
11731   if (rsltmp->tm_isdst) loc -= 3600;
11732   return loc;
11733 }
11734 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11735        ((gmtime_emulation_type || my_time(NULL)), \
11736        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11737        ((secs) - utc_offset_secs))))
11738
11739 static time_t toloc_dst(time_t utc) {
11740   struct tm *rsltmp;
11741
11742   utc += utc_offset_secs;
11743   if ((rsltmp = localtime(&utc)) == NULL) return -1;
11744   if (rsltmp->tm_isdst) utc += 3600;
11745   return utc;
11746 }
11747 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11748        ((gmtime_emulation_type || my_time(NULL)), \
11749        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11750        ((secs) + utc_offset_secs))))
11751
11752 #ifndef RTL_USES_UTC
11753 /*
11754
11755     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
11756         DST starts on 1st sun of april      at 02:00  std time
11757             ends on last sun of october     at 02:00  dst time
11758     see the UCX management command reference, SET CONFIG TIMEZONE
11759     for formatting info.
11760
11761     No, it's not as general as it should be, but then again, NOTHING
11762     will handle UK times in a sensible way.
11763 */
11764
11765
11766 /*
11767     parse the DST start/end info:
11768     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
11769 */
11770
11771 static char *
11772 tz_parse_startend(char *s, struct tm *w, int *past)
11773 {
11774     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
11775     int ly, dozjd, d, m, n, hour, min, sec, j, k;
11776     time_t g;
11777
11778     if (!s)    return 0;
11779     if (!w) return 0;
11780     if (!past) return 0;
11781
11782     ly = 0;
11783     if (w->tm_year % 4        == 0) ly = 1;
11784     if (w->tm_year % 100      == 0) ly = 0;
11785     if (w->tm_year+1900 % 400 == 0) ly = 1;
11786     if (ly) dinm[1]++;
11787
11788     dozjd = isdigit(*s);
11789     if (*s == 'J' || *s == 'j' || dozjd) {
11790         if (!dozjd && !isdigit(*++s)) return 0;
11791         d = *s++ - '0';
11792         if (isdigit(*s)) {
11793             d = d*10 + *s++ - '0';
11794             if (isdigit(*s)) {
11795                 d = d*10 + *s++ - '0';
11796             }
11797         }
11798         if (d == 0) return 0;
11799         if (d > 366) return 0;
11800         d--;
11801         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
11802         g = d * 86400;
11803         dozjd = 1;
11804     } else if (*s == 'M' || *s == 'm') {
11805         if (!isdigit(*++s)) return 0;
11806         m = *s++ - '0';
11807         if (isdigit(*s)) m = 10*m + *s++ - '0';
11808         if (*s != '.') return 0;
11809         if (!isdigit(*++s)) return 0;
11810         n = *s++ - '0';
11811         if (n < 1 || n > 5) return 0;
11812         if (*s != '.') return 0;
11813         if (!isdigit(*++s)) return 0;
11814         d = *s++ - '0';
11815         if (d > 6) return 0;
11816     }
11817
11818     if (*s == '/') {
11819         if (!isdigit(*++s)) return 0;
11820         hour = *s++ - '0';
11821         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
11822         if (*s == ':') {
11823             if (!isdigit(*++s)) return 0;
11824             min = *s++ - '0';
11825             if (isdigit(*s)) min = 10*min + *s++ - '0';
11826             if (*s == ':') {
11827                 if (!isdigit(*++s)) return 0;
11828                 sec = *s++ - '0';
11829                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
11830             }
11831         }
11832     } else {
11833         hour = 2;
11834         min = 0;
11835         sec = 0;
11836     }
11837
11838     if (dozjd) {
11839         if (w->tm_yday < d) goto before;
11840         if (w->tm_yday > d) goto after;
11841     } else {
11842         if (w->tm_mon+1 < m) goto before;
11843         if (w->tm_mon+1 > m) goto after;
11844
11845         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
11846         k = d - j; /* mday of first d */
11847         if (k <= 0) k += 7;
11848         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
11849         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
11850         if (w->tm_mday < k) goto before;
11851         if (w->tm_mday > k) goto after;
11852     }
11853
11854     if (w->tm_hour < hour) goto before;
11855     if (w->tm_hour > hour) goto after;
11856     if (w->tm_min  < min)  goto before;
11857     if (w->tm_min  > min)  goto after;
11858     if (w->tm_sec  < sec)  goto before;
11859     goto after;
11860
11861 before:
11862     *past = 0;
11863     return s;
11864 after:
11865     *past = 1;
11866     return s;
11867 }
11868
11869
11870
11871
11872 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
11873
11874 static char *
11875 tz_parse_offset(char *s, int *offset)
11876 {
11877     int hour = 0, min = 0, sec = 0;
11878     int neg = 0;
11879     if (!s) return 0;
11880     if (!offset) return 0;
11881
11882     if (*s == '-') {neg++; s++;}
11883     if (*s == '+') s++;
11884     if (!isdigit(*s)) return 0;
11885     hour = *s++ - '0';
11886     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
11887     if (hour > 24) return 0;
11888     if (*s == ':') {
11889         if (!isdigit(*++s)) return 0;
11890         min = *s++ - '0';
11891         if (isdigit(*s)) min = min*10 + (*s++ - '0');
11892         if (min > 59) return 0;
11893         if (*s == ':') {
11894             if (!isdigit(*++s)) return 0;
11895             sec = *s++ - '0';
11896             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
11897             if (sec > 59) return 0;
11898         }
11899     }
11900
11901     *offset = (hour*60+min)*60 + sec;
11902     if (neg) *offset = -*offset;
11903     return s;
11904 }
11905
11906 /*
11907     input time is w, whatever type of time the CRTL localtime() uses.
11908     sets dst, the zone, and the gmtoff (seconds)
11909
11910     caches the value of TZ and UCX$TZ env variables; note that
11911     my_setenv looks for these and sets a flag if they're changed
11912     for efficiency.
11913
11914     We have to watch out for the "australian" case (dst starts in
11915     october, ends in april)...flagged by "reverse" and checked by
11916     scanning through the months of the previous year.
11917
11918 */
11919
11920 static int
11921 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
11922 {
11923     time_t when;
11924     struct tm *w2;
11925     char *s,*s2;
11926     char *dstzone, *tz, *s_start, *s_end;
11927     int std_off, dst_off, isdst;
11928     int y, dststart, dstend;
11929     static char envtz[1025];  /* longer than any logical, symbol, ... */
11930     static char ucxtz[1025];
11931     static char reversed = 0;
11932
11933     if (!w) return 0;
11934
11935     if (tz_updated) {
11936         tz_updated = 0;
11937         reversed = -1;  /* flag need to check  */
11938         envtz[0] = ucxtz[0] = '\0';
11939         tz = my_getenv("TZ",0);
11940         if (tz) strcpy(envtz, tz);
11941         tz = my_getenv("UCX$TZ",0);
11942         if (tz) strcpy(ucxtz, tz);
11943         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
11944     }
11945     tz = envtz;
11946     if (!*tz) tz = ucxtz;
11947
11948     s = tz;
11949     while (isalpha(*s)) s++;
11950     s = tz_parse_offset(s, &std_off);
11951     if (!s) return 0;
11952     if (!*s) {                  /* no DST, hurray we're done! */
11953         isdst = 0;
11954         goto done;
11955     }
11956
11957     dstzone = s;
11958     while (isalpha(*s)) s++;
11959     s2 = tz_parse_offset(s, &dst_off);
11960     if (s2) {
11961         s = s2;
11962     } else {
11963         dst_off = std_off - 3600;
11964     }
11965
11966     if (!*s) {      /* default dst start/end?? */
11967         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
11968             s = strchr(ucxtz,',');
11969         }
11970         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
11971     }
11972     if (*s != ',') return 0;
11973
11974     when = *w;
11975     when = _toutc(when);      /* convert to utc */
11976     when = when - std_off;    /* convert to pseudolocal time*/
11977
11978     w2 = localtime(&when);
11979     y = w2->tm_year;
11980     s_start = s+1;
11981     s = tz_parse_startend(s_start,w2,&dststart);
11982     if (!s) return 0;
11983     if (*s != ',') return 0;
11984
11985     when = *w;
11986     when = _toutc(when);      /* convert to utc */
11987     when = when - dst_off;    /* convert to pseudolocal time*/
11988     w2 = localtime(&when);
11989     if (w2->tm_year != y) {   /* spans a year, just check one time */
11990         when += dst_off - std_off;
11991         w2 = localtime(&when);
11992     }
11993     s_end = s+1;
11994     s = tz_parse_startend(s_end,w2,&dstend);
11995     if (!s) return 0;
11996
11997     if (reversed == -1) {  /* need to check if start later than end */
11998         int j, ds, de;
11999
12000         when = *w;
12001         if (when < 2*365*86400) {
12002             when += 2*365*86400;
12003         } else {
12004             when -= 365*86400;
12005         }
12006         w2 =localtime(&when);
12007         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
12008
12009         for (j = 0; j < 12; j++) {
12010             w2 =localtime(&when);
12011             tz_parse_startend(s_start,w2,&ds);
12012             tz_parse_startend(s_end,w2,&de);
12013             if (ds != de) break;
12014             when += 30*86400;
12015         }
12016         reversed = 0;
12017         if (de && !ds) reversed = 1;
12018     }
12019
12020     isdst = dststart && !dstend;
12021     if (reversed) isdst = dststart  || !dstend;
12022
12023 done:
12024     if (dst)    *dst = isdst;
12025     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
12026     if (isdst)  tz = dstzone;
12027     if (zone) {
12028         while(isalpha(*tz))  *zone++ = *tz++;
12029         *zone = '\0';
12030     }
12031     return 1;
12032 }
12033
12034 #endif /* !RTL_USES_UTC */
12035
12036 /* my_time(), my_localtime(), my_gmtime()
12037  * By default traffic in UTC time values, using CRTL gmtime() or
12038  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
12039  * Note: We need to use these functions even when the CRTL has working
12040  * UTC support, since they also handle C<use vmsish qw(times);>
12041  *
12042  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
12043  * Modified by Charles Bailey <bailey@newman.upenn.edu>
12044  */
12045
12046 /*{{{time_t my_time(time_t *timep)*/
12047 time_t Perl_my_time(pTHX_ time_t *timep)
12048 {
12049   time_t when;
12050   struct tm *tm_p;
12051
12052   if (gmtime_emulation_type == 0) {
12053     int dstnow;
12054     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
12055                               /* results of calls to gmtime() and localtime() */
12056                               /* for same &base */
12057
12058     gmtime_emulation_type++;
12059     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
12060       char off[LNM$C_NAMLENGTH+1];;
12061
12062       gmtime_emulation_type++;
12063       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
12064         gmtime_emulation_type++;
12065         utc_offset_secs = 0;
12066         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
12067       }
12068       else { utc_offset_secs = atol(off); }
12069     }
12070     else { /* We've got a working gmtime() */
12071       struct tm gmt, local;
12072
12073       gmt = *tm_p;
12074       tm_p = localtime(&base);
12075       local = *tm_p;
12076       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
12077       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
12078       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
12079       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
12080     }
12081   }
12082
12083   when = time(NULL);
12084 # ifdef VMSISH_TIME
12085 # ifdef RTL_USES_UTC
12086   if (VMSISH_TIME) when = _toloc(when);
12087 # else
12088   if (!VMSISH_TIME) when = _toutc(when);
12089 # endif
12090 # endif
12091   if (timep != NULL) *timep = when;
12092   return when;
12093
12094 }  /* end of my_time() */
12095 /*}}}*/
12096
12097
12098 /*{{{struct tm *my_gmtime(const time_t *timep)*/
12099 struct tm *
12100 Perl_my_gmtime(pTHX_ const time_t *timep)
12101 {
12102   char *p;
12103   time_t when;
12104   struct tm *rsltmp;
12105
12106   if (timep == NULL) {
12107     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12108     return NULL;
12109   }
12110   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
12111
12112   when = *timep;
12113 # ifdef VMSISH_TIME
12114   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
12115 #  endif
12116 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
12117   return gmtime(&when);
12118 # else
12119   /* CRTL localtime() wants local time as input, so does no tz correction */
12120   rsltmp = localtime(&when);
12121   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
12122   return rsltmp;
12123 #endif
12124 }  /* end of my_gmtime() */
12125 /*}}}*/
12126
12127
12128 /*{{{struct tm *my_localtime(const time_t *timep)*/
12129 struct tm *
12130 Perl_my_localtime(pTHX_ const time_t *timep)
12131 {
12132   time_t when, whenutc;
12133   struct tm *rsltmp;
12134   int dst, offset;
12135
12136   if (timep == NULL) {
12137     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12138     return NULL;
12139   }
12140   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
12141   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
12142
12143   when = *timep;
12144 # ifdef RTL_USES_UTC
12145 # ifdef VMSISH_TIME
12146   if (VMSISH_TIME) when = _toutc(when);
12147 # endif
12148   /* CRTL localtime() wants UTC as input, does tz correction itself */
12149   return localtime(&when);
12150
12151 # else /* !RTL_USES_UTC */
12152   whenutc = when;
12153 # ifdef VMSISH_TIME
12154   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
12155   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
12156 # endif
12157   dst = -1;
12158 #ifndef RTL_USES_UTC
12159   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
12160       when = whenutc - offset;                   /* pseudolocal time*/
12161   }
12162 # endif
12163   /* CRTL localtime() wants local time as input, so does no tz correction */
12164   rsltmp = localtime(&when);
12165   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
12166   return rsltmp;
12167 # endif
12168
12169 } /*  end of my_localtime() */
12170 /*}}}*/
12171
12172 /* Reset definitions for later calls */
12173 #define gmtime(t)    my_gmtime(t)
12174 #define localtime(t) my_localtime(t)
12175 #define time(t)      my_time(t)
12176
12177
12178 /* my_utime - update modification/access time of a file
12179  *
12180  * VMS 7.3 and later implementation
12181  * Only the UTC translation is home-grown. The rest is handled by the
12182  * CRTL utime(), which will take into account the relevant feature
12183  * logicals and ODS-5 volume characteristics for true access times.
12184  *
12185  * pre VMS 7.3 implementation:
12186  * The calling sequence is identical to POSIX utime(), but under
12187  * VMS with ODS-2, only the modification time is changed; ODS-2 does
12188  * not maintain access times.  Restrictions differ from the POSIX
12189  * definition in that the time can be changed as long as the
12190  * caller has permission to execute the necessary IO$_MODIFY $QIO;
12191  * no separate checks are made to insure that the caller is the
12192  * owner of the file or has special privs enabled.
12193  * Code here is based on Joe Meadows' FILE utility.
12194  *
12195  */
12196
12197 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
12198  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
12199  * in 100 ns intervals.
12200  */
12201 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
12202
12203 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
12204 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
12205 {
12206 #if __CRTL_VER >= 70300000
12207   struct utimbuf utc_utimes, *utc_utimesp;
12208
12209   if (utimes != NULL) {
12210     utc_utimes.actime = utimes->actime;
12211     utc_utimes.modtime = utimes->modtime;
12212 # ifdef VMSISH_TIME
12213     /* If input was local; convert to UTC for sys svc */
12214     if (VMSISH_TIME) {
12215       utc_utimes.actime = _toutc(utimes->actime);
12216       utc_utimes.modtime = _toutc(utimes->modtime);
12217     }
12218 # endif
12219     utc_utimesp = &utc_utimes;
12220   }
12221   else {
12222     utc_utimesp = NULL;
12223   }
12224
12225   return utime(file, utc_utimesp);
12226
12227 #else /* __CRTL_VER < 70300000 */
12228
12229   register int i;
12230   int sts;
12231   long int bintime[2], len = 2, lowbit, unixtime,
12232            secscale = 10000000; /* seconds --> 100 ns intervals */
12233   unsigned long int chan, iosb[2], retsts;
12234   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
12235   struct FAB myfab = cc$rms_fab;
12236   struct NAM mynam = cc$rms_nam;
12237 #if defined (__DECC) && defined (__VAX)
12238   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
12239    * at least through VMS V6.1, which causes a type-conversion warning.
12240    */
12241 #  pragma message save
12242 #  pragma message disable cvtdiftypes
12243 #endif
12244   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
12245   struct fibdef myfib;
12246 #if defined (__DECC) && defined (__VAX)
12247   /* This should be right after the declaration of myatr, but due
12248    * to a bug in VAX DEC C, this takes effect a statement early.
12249    */
12250 #  pragma message restore
12251 #endif
12252   /* cast ok for read only parameter */
12253   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
12254                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
12255                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
12256
12257   if (file == NULL || *file == '\0') {
12258     SETERRNO(ENOENT, LIB$_INVARG);
12259     return -1;
12260   }
12261
12262   /* Convert to VMS format ensuring that it will fit in 255 characters */
12263   if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
12264       SETERRNO(ENOENT, LIB$_INVARG);
12265       return -1;
12266   }
12267   if (utimes != NULL) {
12268     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
12269      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
12270      * Since time_t is unsigned long int, and lib$emul takes a signed long int
12271      * as input, we force the sign bit to be clear by shifting unixtime right
12272      * one bit, then multiplying by an extra factor of 2 in lib$emul().
12273      */
12274     lowbit = (utimes->modtime & 1) ? secscale : 0;
12275     unixtime = (long int) utimes->modtime;
12276 #   ifdef VMSISH_TIME
12277     /* If input was UTC; convert to local for sys svc */
12278     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
12279 #   endif
12280     unixtime >>= 1;  secscale <<= 1;
12281     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
12282     if (!(retsts & 1)) {
12283       SETERRNO(EVMSERR, retsts);
12284       return -1;
12285     }
12286     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
12287     if (!(retsts & 1)) {
12288       SETERRNO(EVMSERR, retsts);
12289       return -1;
12290     }
12291   }
12292   else {
12293     /* Just get the current time in VMS format directly */
12294     retsts = sys$gettim(bintime);
12295     if (!(retsts & 1)) {
12296       SETERRNO(EVMSERR, retsts);
12297       return -1;
12298     }
12299   }
12300
12301   myfab.fab$l_fna = vmsspec;
12302   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
12303   myfab.fab$l_nam = &mynam;
12304   mynam.nam$l_esa = esa;
12305   mynam.nam$b_ess = (unsigned char) sizeof esa;
12306   mynam.nam$l_rsa = rsa;
12307   mynam.nam$b_rss = (unsigned char) sizeof rsa;
12308   if (decc_efs_case_preserve)
12309       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
12310
12311   /* Look for the file to be affected, letting RMS parse the file
12312    * specification for us as well.  I have set errno using only
12313    * values documented in the utime() man page for VMS POSIX.
12314    */
12315   retsts = sys$parse(&myfab,0,0);
12316   if (!(retsts & 1)) {
12317     set_vaxc_errno(retsts);
12318     if      (retsts == RMS$_PRV) set_errno(EACCES);
12319     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
12320     else                         set_errno(EVMSERR);
12321     return -1;
12322   }
12323   retsts = sys$search(&myfab,0,0);
12324   if (!(retsts & 1)) {
12325     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12326     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12327     set_vaxc_errno(retsts);
12328     if      (retsts == RMS$_PRV) set_errno(EACCES);
12329     else if (retsts == RMS$_FNF) set_errno(ENOENT);
12330     else                         set_errno(EVMSERR);
12331     return -1;
12332   }
12333
12334   devdsc.dsc$w_length = mynam.nam$b_dev;
12335   /* cast ok for read only parameter */
12336   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
12337
12338   retsts = sys$assign(&devdsc,&chan,0,0);
12339   if (!(retsts & 1)) {
12340     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12341     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12342     set_vaxc_errno(retsts);
12343     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
12344     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
12345     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
12346     else                               set_errno(EVMSERR);
12347     return -1;
12348   }
12349
12350   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
12351   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
12352
12353   memset((void *) &myfib, 0, sizeof myfib);
12354 #if defined(__DECC) || defined(__DECCXX)
12355   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
12356   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
12357   /* This prevents the revision time of the file being reset to the current
12358    * time as a result of our IO$_MODIFY $QIO. */
12359   myfib.fib$l_acctl = FIB$M_NORECORD;
12360 #else
12361   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
12362   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
12363   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
12364 #endif
12365   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
12366   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12367   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12368   _ckvmssts(sys$dassgn(chan));
12369   if (retsts & 1) retsts = iosb[0];
12370   if (!(retsts & 1)) {
12371     set_vaxc_errno(retsts);
12372     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12373     else                      set_errno(EVMSERR);
12374     return -1;
12375   }
12376
12377   return 0;
12378
12379 #endif /* #if __CRTL_VER >= 70300000 */
12380
12381 }  /* end of my_utime() */
12382 /*}}}*/
12383
12384 /*
12385  * flex_stat, flex_lstat, flex_fstat
12386  * basic stat, but gets it right when asked to stat
12387  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
12388  */
12389
12390 #ifndef _USE_STD_STAT
12391 /* encode_dev packs a VMS device name string into an integer to allow
12392  * simple comparisons. This can be used, for example, to check whether two
12393  * files are located on the same device, by comparing their encoded device
12394  * names. Even a string comparison would not do, because stat() reuses the
12395  * device name buffer for each call; so without encode_dev, it would be
12396  * necessary to save the buffer and use strcmp (this would mean a number of
12397  * changes to the standard Perl code, to say nothing of what a Perl script
12398  * would have to do.
12399  *
12400  * The device lock id, if it exists, should be unique (unless perhaps compared
12401  * with lock ids transferred from other nodes). We have a lock id if the disk is
12402  * mounted cluster-wide, which is when we tend to get long (host-qualified)
12403  * device names. Thus we use the lock id in preference, and only if that isn't
12404  * available, do we try to pack the device name into an integer (flagged by
12405  * the sign bit (LOCKID_MASK) being set).
12406  *
12407  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
12408  * name and its encoded form, but it seems very unlikely that we will find
12409  * two files on different disks that share the same encoded device names,
12410  * and even more remote that they will share the same file id (if the test
12411  * is to check for the same file).
12412  *
12413  * A better method might be to use sys$device_scan on the first call, and to
12414  * search for the device, returning an index into the cached array.
12415  * The number returned would be more intelligible.
12416  * This is probably not worth it, and anyway would take quite a bit longer
12417  * on the first call.
12418  */
12419 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
12420 static mydev_t encode_dev (pTHX_ const char *dev)
12421 {
12422   int i;
12423   unsigned long int f;
12424   mydev_t enc;
12425   char c;
12426   const char *q;
12427
12428   if (!dev || !dev[0]) return 0;
12429
12430 #if LOCKID_MASK
12431   {
12432     struct dsc$descriptor_s dev_desc;
12433     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
12434
12435     /* For cluster-mounted disks, the disk lock identifier is unique, so we
12436        can try that first. */
12437     dev_desc.dsc$w_length =  strlen (dev);
12438     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
12439     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
12440     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
12441     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
12442     if (!$VMS_STATUS_SUCCESS(status)) {
12443       switch (status) {
12444         case SS$_NOSUCHDEV:
12445           SETERRNO(ENODEV, status);
12446           return 0;
12447         default:
12448           _ckvmssts(status);
12449       }
12450     }
12451     if (lockid) return (lockid & ~LOCKID_MASK);
12452   }
12453 #endif
12454
12455   /* Otherwise we try to encode the device name */
12456   enc = 0;
12457   f = 1;
12458   i = 0;
12459   for (q = dev + strlen(dev); q--; q >= dev) {
12460     if (*q == ':')
12461         break;
12462     if (isdigit (*q))
12463       c= (*q) - '0';
12464     else if (isalpha (toupper (*q)))
12465       c= toupper (*q) - 'A' + (char)10;
12466     else
12467       continue; /* Skip '$'s */
12468     i++;
12469     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
12470     if (i>1) f *= 36;
12471     enc += f * (unsigned long int) c;
12472   }
12473   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
12474
12475 }  /* end of encode_dev() */
12476 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12477         device_no = encode_dev(aTHX_ devname)
12478 #else
12479 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12480         device_no = new_dev_no
12481 #endif
12482
12483 static int
12484 is_null_device(name)
12485     const char *name;
12486 {
12487   if (decc_bug_devnull != 0) {
12488     if (strncmp("/dev/null", name, 9) == 0)
12489       return 1;
12490   }
12491     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
12492        The underscore prefix, controller letter, and unit number are
12493        independently optional; for our purposes, the colon punctuation
12494        is not.  The colon can be trailed by optional directory and/or
12495        filename, but two consecutive colons indicates a nodename rather
12496        than a device.  [pr]  */
12497   if (*name == '_') ++name;
12498   if (tolower(*name++) != 'n') return 0;
12499   if (tolower(*name++) != 'l') return 0;
12500   if (tolower(*name) == 'a') ++name;
12501   if (*name == '0') ++name;
12502   return (*name++ == ':') && (*name != ':');
12503 }
12504
12505 static int
12506 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
12507
12508 static I32
12509 Perl_cando_by_name_int
12510    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
12511 {
12512   char usrname[L_cuserid];
12513   struct dsc$descriptor_s usrdsc =
12514          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
12515   char *vmsname = NULL, *fileified = NULL;
12516   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
12517   unsigned short int retlen, trnlnm_iter_count;
12518   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12519   union prvdef curprv;
12520   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
12521          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
12522          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
12523   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
12524          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
12525          {0,0,0,0}};
12526   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
12527          {0,0,0,0}};
12528   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12529   Stat_t st;
12530   static int profile_context = -1;
12531
12532   if (!fname || !*fname) return FALSE;
12533
12534   /* Make sure we expand logical names, since sys$check_access doesn't */
12535   fileified = PerlMem_malloc(VMS_MAXRSS);
12536   if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12537   if (!strpbrk(fname,"/]>:")) {
12538       strcpy(fileified,fname);
12539       trnlnm_iter_count = 0;
12540       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
12541         trnlnm_iter_count++;
12542         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
12543       }
12544       fname = fileified;
12545   }
12546
12547   vmsname = PerlMem_malloc(VMS_MAXRSS);
12548   if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12549   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
12550     /* Don't know if already in VMS format, so make sure */
12551     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
12552       PerlMem_free(fileified);
12553       PerlMem_free(vmsname);
12554       return FALSE;
12555     }
12556   }
12557   else {
12558     strcpy(vmsname,fname);
12559   }
12560
12561   /* sys$check_access needs a file spec, not a directory spec.
12562    * flex_stat now will handle a null thread context during startup.
12563    */
12564
12565   retlen = namdsc.dsc$w_length = strlen(vmsname);
12566   if (vmsname[retlen-1] == ']'
12567       || vmsname[retlen-1] == '>'
12568       || vmsname[retlen-1] == ':'
12569       || (!Perl_flex_stat_int(NULL, vmsname, &st, 1) &&
12570           S_ISDIR(st.st_mode))) {
12571
12572       if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
12573         PerlMem_free(fileified);
12574         PerlMem_free(vmsname);
12575         return FALSE;
12576       }
12577       fname = fileified;
12578   }
12579   else {
12580       fname = vmsname;
12581   }
12582
12583   retlen = namdsc.dsc$w_length = strlen(fname);
12584   namdsc.dsc$a_pointer = (char *)fname;
12585
12586   switch (bit) {
12587     case S_IXUSR: case S_IXGRP: case S_IXOTH:
12588       access = ARM$M_EXECUTE;
12589       flags = CHP$M_READ;
12590       break;
12591     case S_IRUSR: case S_IRGRP: case S_IROTH:
12592       access = ARM$M_READ;
12593       flags = CHP$M_READ | CHP$M_USEREADALL;
12594       break;
12595     case S_IWUSR: case S_IWGRP: case S_IWOTH:
12596       access = ARM$M_WRITE;
12597       flags = CHP$M_READ | CHP$M_WRITE;
12598       break;
12599     case S_IDUSR: case S_IDGRP: case S_IDOTH:
12600       access = ARM$M_DELETE;
12601       flags = CHP$M_READ | CHP$M_WRITE;
12602       break;
12603     default:
12604       if (fileified != NULL)
12605         PerlMem_free(fileified);
12606       if (vmsname != NULL)
12607         PerlMem_free(vmsname);
12608       return FALSE;
12609   }
12610
12611   /* Before we call $check_access, create a user profile with the current
12612    * process privs since otherwise it just uses the default privs from the
12613    * UAF and might give false positives or negatives.  This only works on
12614    * VMS versions v6.0 and later since that's when sys$create_user_profile
12615    * became available.
12616    */
12617
12618   /* get current process privs and username */
12619   _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
12620   _ckvmssts_noperl(iosb[0]);
12621
12622 #if defined(__VMS_VER) && __VMS_VER >= 60000000
12623
12624   /* find out the space required for the profile */
12625   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
12626                                     &usrprodsc.dsc$w_length,&profile_context));
12627
12628   /* allocate space for the profile and get it filled in */
12629   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
12630   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12631   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
12632                                     &usrprodsc.dsc$w_length,&profile_context));
12633
12634   /* use the profile to check access to the file; free profile & analyze results */
12635   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
12636   PerlMem_free(usrprodsc.dsc$a_pointer);
12637   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
12638
12639 #else
12640
12641   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
12642
12643 #endif
12644
12645   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
12646       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
12647       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
12648     set_vaxc_errno(retsts);
12649     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12650     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12651     else set_errno(ENOENT);
12652     if (fileified != NULL)
12653       PerlMem_free(fileified);
12654     if (vmsname != NULL)
12655       PerlMem_free(vmsname);
12656     return FALSE;
12657   }
12658   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12659     if (fileified != NULL)
12660       PerlMem_free(fileified);
12661     if (vmsname != NULL)
12662       PerlMem_free(vmsname);
12663     return TRUE;
12664   }
12665   _ckvmssts_noperl(retsts);
12666
12667   if (fileified != NULL)
12668     PerlMem_free(fileified);
12669   if (vmsname != NULL)
12670     PerlMem_free(vmsname);
12671   return FALSE;  /* Should never get here */
12672
12673 }
12674
12675 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
12676 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12677  * subset of the applicable information.
12678  */
12679 bool
12680 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12681 {
12682   return cando_by_name_int
12683         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12684 }  /* end of cando() */
12685 /*}}}*/
12686
12687
12688 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12689 I32
12690 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12691 {
12692    return cando_by_name_int(bit, effective, fname, 0);
12693
12694 }  /* end of cando_by_name() */
12695 /*}}}*/
12696
12697
12698 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12699 int
12700 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12701 {
12702   if (!fstat(fd, &statbufp->crtl_stat)) {
12703     char *cptr;
12704     char *vms_filename;
12705     vms_filename = PerlMem_malloc(VMS_MAXRSS);
12706     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12707
12708     /* Save name for cando by name in VMS format */
12709     cptr = getname(fd, vms_filename, 1);
12710
12711     /* This should not happen, but just in case */
12712     if (cptr == NULL) {
12713         statbufp->st_devnam[0] = 0;
12714     }
12715     else {
12716         /* Make sure that the saved name fits in 255 characters */
12717         cptr = int_rmsexpand_vms
12718                        (vms_filename,
12719                         statbufp->st_devnam,
12720                         0);
12721         if (cptr == NULL)
12722             statbufp->st_devnam[0] = 0;
12723     }
12724     PerlMem_free(vms_filename);
12725
12726     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12727     VMS_DEVICE_ENCODE
12728         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12729
12730 #   ifdef RTL_USES_UTC
12731 #   ifdef VMSISH_TIME
12732     if (VMSISH_TIME) {
12733       statbufp->st_mtime = _toloc(statbufp->st_mtime);
12734       statbufp->st_atime = _toloc(statbufp->st_atime);
12735       statbufp->st_ctime = _toloc(statbufp->st_ctime);
12736     }
12737 #   endif
12738 #   else
12739 #   ifdef VMSISH_TIME
12740     if (!VMSISH_TIME) { /* Return UTC instead of local time */
12741 #   else
12742     if (1) {
12743 #   endif
12744       statbufp->st_mtime = _toutc(statbufp->st_mtime);
12745       statbufp->st_atime = _toutc(statbufp->st_atime);
12746       statbufp->st_ctime = _toutc(statbufp->st_ctime);
12747     }
12748 #endif
12749     return 0;
12750   }
12751   return -1;
12752
12753 }  /* end of flex_fstat() */
12754 /*}}}*/
12755
12756 #if !defined(__VAX) && __CRTL_VER >= 80200000
12757 #ifdef lstat
12758 #undef lstat
12759 #endif
12760 #else
12761 #ifdef lstat
12762 #undef lstat
12763 #endif
12764 #define lstat(_x, _y) stat(_x, _y)
12765 #endif
12766
12767 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
12768
12769 static int
12770 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12771 {
12772     char *fileified;
12773     char *temp_fspec;
12774     const char *save_spec;
12775     char *ret_spec;
12776     int retval = -1;
12777     int efs_hack = 0;
12778     dSAVEDERRNO;
12779
12780     if (!fspec) {
12781         errno = EINVAL;
12782         return retval;
12783     }
12784
12785     if (decc_bug_devnull != 0) {
12786       if (is_null_device(fspec)) { /* Fake a stat() for the null device */
12787         memset(statbufp,0,sizeof *statbufp);
12788         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12789         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12790         statbufp->st_uid = 0x00010001;
12791         statbufp->st_gid = 0x0001;
12792         time((time_t *)&statbufp->st_mtime);
12793         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12794         return 0;
12795       }
12796     }
12797
12798     /* Try for a directory name first.  If fspec contains a filename without
12799      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12800      * and sea:[wine.dark]water. exist, we prefer the directory here.
12801      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12802      * not sea:[wine.dark]., if the latter exists.  If the intended target is
12803      * the file with null type, specify this by calling flex_stat() with
12804      * a '.' at the end of fspec.
12805      *
12806      * If we are in Posix filespec mode, accept the filename as is.
12807      */
12808
12809
12810     fileified = PerlMem_malloc(VMS_MAXRSS);
12811     if (fileified == NULL)
12812         _ckvmssts_noperl(SS$_INSFMEM);
12813
12814     temp_fspec = PerlMem_malloc(VMS_MAXRSS);
12815     if (temp_fspec == NULL)
12816         _ckvmssts_noperl(SS$_INSFMEM);
12817
12818     strcpy(temp_fspec, fspec);
12819
12820     SAVE_ERRNO;
12821
12822 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12823   if (decc_posix_compliant_pathnames == 0) {
12824 #endif
12825
12826     /* We may be able to optimize this, but in order for fileify_dirspec to
12827      * always return a usuable answer, we have to call vmspath first to
12828      * make sure that it is in VMS directory format, as stat/lstat on 8.3
12829      * can not handle directories in unix format that it does not have read
12830      * access to.  Vmspath handles the case where a bare name which could be
12831      * a logical name gets passed.
12832      */
12833     ret_spec = int_tovmspath(fspec, temp_fspec, NULL);
12834     if (ret_spec != NULL) {
12835         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
12836         if (ret_spec != NULL) {
12837             if (lstat_flag == 0)
12838                 retval = stat(fileified, &statbufp->crtl_stat);
12839             else
12840                 retval = lstat(fileified, &statbufp->crtl_stat);
12841             save_spec = fileified;
12842         }
12843     }
12844
12845     if (retval && vms_bug_stat_filename) {
12846
12847         /* We should try again as a vmsified file specification */
12848         /* However Perl traditionally has not done this, which  */
12849         /* causes problems with existing tests */
12850
12851         ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12852         if (ret_spec != NULL) {
12853             if (lstat_flag == 0)
12854                 retval = stat(temp_fspec, &statbufp->crtl_stat);
12855             else
12856                 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12857             save_spec = temp_fspec;
12858         }
12859     }
12860
12861     if (retval) {
12862         /* Last chance - allow multiple dots with out EFS CHARSET */
12863         /* The CRTL stat() falls down hard on multi-dot filenames in unix
12864          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12865          * enable it if it isn't already.
12866          */
12867 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12868         if (!decc_efs_charset && (decc_efs_charset_index > 0))
12869             decc$feature_set_value(decc_efs_charset_index, 1, 1);
12870 #endif
12871         if (lstat_flag == 0)
12872             retval = stat(fspec, &statbufp->crtl_stat);
12873         else
12874             retval = lstat(fspec, &statbufp->crtl_stat);
12875         save_spec = fspec;
12876 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12877         if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
12878             decc$feature_set_value(decc_efs_charset_index, 1, 0);
12879             efs_hack = 1;
12880         }
12881 #endif
12882     }
12883
12884 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12885   } else {
12886     if (lstat_flag == 0)
12887       retval = stat(temp_fspec, &statbufp->crtl_stat);
12888     else
12889       retval = lstat(temp_fspec, &statbufp->crtl_stat);
12890       save_spec = temp_fspec;
12891   }
12892 #endif
12893
12894 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12895   /* As you were... */
12896   if (!decc_efs_charset)
12897     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12898 #endif
12899
12900     if (!retval) {
12901     char * cptr;
12902     int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12903
12904       /* If this is an lstat, do not follow the link */
12905       if (lstat_flag)
12906         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12907
12908 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12909       /* If we used the efs_hack above, we must also use it here for */
12910       /* perl_cando to work */
12911       if (efs_hack && (decc_efs_charset_index > 0)) {
12912           decc$feature_set_value(decc_efs_charset_index, 1, 1);
12913       }
12914 #endif
12915       cptr = int_rmsexpand_tovms(save_spec, statbufp->st_devnam, rmsex_flags);
12916 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12917       if (efs_hack && (decc_efs_charset_index > 0)) {
12918           decc$feature_set_value(decc_efs_charset, 1, 0);
12919       }
12920 #endif
12921
12922       /* Fix me: If this is NULL then stat found a file, and we could */
12923       /* not convert the specification to VMS - Should never happen */
12924       if (cptr == NULL)
12925         statbufp->st_devnam[0] = 0;
12926
12927       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12928       VMS_DEVICE_ENCODE
12929         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12930 #     ifdef RTL_USES_UTC
12931 #     ifdef VMSISH_TIME
12932       if (VMSISH_TIME) {
12933         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12934         statbufp->st_atime = _toloc(statbufp->st_atime);
12935         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12936       }
12937 #     endif
12938 #     else
12939 #     ifdef VMSISH_TIME
12940       if (!VMSISH_TIME) { /* Return UTC instead of local time */
12941 #     else
12942       if (1) {
12943 #     endif
12944         statbufp->st_mtime = _toutc(statbufp->st_mtime);
12945         statbufp->st_atime = _toutc(statbufp->st_atime);
12946         statbufp->st_ctime = _toutc(statbufp->st_ctime);
12947       }
12948 #     endif
12949     }
12950     /* If we were successful, leave errno where we found it */
12951     if (retval == 0) RESTORE_ERRNO;
12952     return retval;
12953
12954 }  /* end of flex_stat_int() */
12955
12956
12957 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12958 int
12959 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12960 {
12961    return flex_stat_int(fspec, statbufp, 0);
12962 }
12963 /*}}}*/
12964
12965 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12966 int
12967 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12968 {
12969    return flex_stat_int(fspec, statbufp, 1);
12970 }
12971 /*}}}*/
12972
12973
12974 /*{{{char *my_getlogin()*/
12975 /* VMS cuserid == Unix getlogin, except calling sequence */
12976 char *
12977 my_getlogin(void)
12978 {
12979     static char user[L_cuserid];
12980     return cuserid(user);
12981 }
12982 /*}}}*/
12983
12984
12985 /*  rmscopy - copy a file using VMS RMS routines
12986  *
12987  *  Copies contents and attributes of spec_in to spec_out, except owner
12988  *  and protection information.  Name and type of spec_in are used as
12989  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
12990  *  should try to propagate timestamps from the input file to the output file.
12991  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
12992  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
12993  *  propagated to the output file at creation iff the output file specification
12994  *  did not contain an explicit name or type, and the revision date is always
12995  *  updated at the end of the copy operation.  If it is greater than 0, then
12996  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12997  *  other than the revision date should be propagated, and bit 1 indicates
12998  *  that the revision date should be propagated.
12999  *
13000  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
13001  *
13002  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
13003  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
13004  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
13005  * as part of the Perl standard distribution under the terms of the
13006  * GNU General Public License or the Perl Artistic License.  Copies
13007  * of each may be found in the Perl standard distribution.
13008  */ /* FIXME */
13009 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
13010 int
13011 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
13012 {
13013     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
13014          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
13015     unsigned long int i, sts, sts2;
13016     int dna_len;
13017     struct FAB fab_in, fab_out;
13018     struct RAB rab_in, rab_out;
13019     rms_setup_nam(nam);
13020     rms_setup_nam(nam_out);
13021     struct XABDAT xabdat;
13022     struct XABFHC xabfhc;
13023     struct XABRDT xabrdt;
13024     struct XABSUM xabsum;
13025
13026     vmsin = PerlMem_malloc(VMS_MAXRSS);
13027     if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13028     vmsout = PerlMem_malloc(VMS_MAXRSS);
13029     if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13030     if (!spec_in  || !*spec_in  || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
13031         !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
13032       PerlMem_free(vmsin);
13033       PerlMem_free(vmsout);
13034       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13035       return 0;
13036     }
13037
13038     esa = PerlMem_malloc(VMS_MAXRSS);
13039     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13040     esal = NULL;
13041 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
13042     esal = PerlMem_malloc(VMS_MAXRSS);
13043     if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13044 #endif
13045     fab_in = cc$rms_fab;
13046     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
13047     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
13048     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
13049     fab_in.fab$l_fop = FAB$M_SQO;
13050     rms_bind_fab_nam(fab_in, nam);
13051     fab_in.fab$l_xab = (void *) &xabdat;
13052
13053     rsa = PerlMem_malloc(VMS_MAXRSS);
13054     if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13055     rsal = NULL;
13056 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
13057     rsal = PerlMem_malloc(VMS_MAXRSS);
13058     if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13059 #endif
13060     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
13061     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
13062     rms_nam_esl(nam) = 0;
13063     rms_nam_rsl(nam) = 0;
13064     rms_nam_esll(nam) = 0;
13065     rms_nam_rsll(nam) = 0;
13066 #ifdef NAM$M_NO_SHORT_UPCASE
13067     if (decc_efs_case_preserve)
13068         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
13069 #endif
13070
13071     xabdat = cc$rms_xabdat;        /* To get creation date */
13072     xabdat.xab$l_nxt = (void *) &xabfhc;
13073
13074     xabfhc = cc$rms_xabfhc;        /* To get record length */
13075     xabfhc.xab$l_nxt = (void *) &xabsum;
13076
13077     xabsum = cc$rms_xabsum;        /* To get key and area information */
13078
13079     if (!((sts = sys$open(&fab_in)) & 1)) {
13080       PerlMem_free(vmsin);
13081       PerlMem_free(vmsout);
13082       PerlMem_free(esa);
13083       if (esal != NULL)
13084         PerlMem_free(esal);
13085       PerlMem_free(rsa);
13086       if (rsal != NULL)
13087         PerlMem_free(rsal);
13088       set_vaxc_errno(sts);
13089       switch (sts) {
13090         case RMS$_FNF: case RMS$_DNF:
13091           set_errno(ENOENT); break;
13092         case RMS$_DIR:
13093           set_errno(ENOTDIR); break;
13094         case RMS$_DEV:
13095           set_errno(ENODEV); break;
13096         case RMS$_SYN:
13097           set_errno(EINVAL); break;
13098         case RMS$_PRV:
13099           set_errno(EACCES); break;
13100         default:
13101           set_errno(EVMSERR);
13102       }
13103       return 0;
13104     }
13105
13106     nam_out = nam;
13107     fab_out = fab_in;
13108     fab_out.fab$w_ifi = 0;
13109     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
13110     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
13111     fab_out.fab$l_fop = FAB$M_SQO;
13112     rms_bind_fab_nam(fab_out, nam_out);
13113     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
13114     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
13115     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
13116     esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
13117     if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13118     rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
13119     if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13120     esal_out = NULL;
13121     rsal_out = NULL;
13122 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
13123     esal_out = PerlMem_malloc(VMS_MAXRSS);
13124     if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13125     rsal_out = PerlMem_malloc(VMS_MAXRSS);
13126     if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13127 #endif
13128     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
13129     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
13130
13131     if (preserve_dates == 0) {  /* Act like DCL COPY */
13132       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
13133       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
13134       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
13135         PerlMem_free(vmsin);
13136         PerlMem_free(vmsout);
13137         PerlMem_free(esa);
13138         if (esal != NULL)
13139             PerlMem_free(esal);
13140         PerlMem_free(rsa);
13141         if (rsal != NULL)
13142             PerlMem_free(rsal);
13143         PerlMem_free(esa_out);
13144         if (esal_out != NULL)
13145             PerlMem_free(esal_out);
13146         PerlMem_free(rsa_out);
13147         if (rsal_out != NULL)
13148             PerlMem_free(rsal_out);
13149         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
13150         set_vaxc_errno(sts);
13151         return 0;
13152       }
13153       fab_out.fab$l_xab = (void *) &xabdat;
13154       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
13155         preserve_dates = 1;
13156     }
13157     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
13158       preserve_dates =0;      /* bitmask from this point forward   */
13159
13160     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
13161     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
13162       PerlMem_free(vmsin);
13163       PerlMem_free(vmsout);
13164       PerlMem_free(esa);
13165       if (esal != NULL)
13166           PerlMem_free(esal);
13167       PerlMem_free(rsa);
13168       if (rsal != NULL)
13169           PerlMem_free(rsal);
13170       PerlMem_free(esa_out);
13171       if (esal_out != NULL)
13172           PerlMem_free(esal_out);
13173       PerlMem_free(rsa_out);
13174       if (rsal_out != NULL)
13175           PerlMem_free(rsal_out);
13176       set_vaxc_errno(sts);
13177       switch (sts) {
13178         case RMS$_DNF:
13179           set_errno(ENOENT); break;
13180         case RMS$_DIR:
13181           set_errno(ENOTDIR); break;
13182         case RMS$_DEV:
13183           set_errno(ENODEV); break;
13184         case RMS$_SYN:
13185           set_errno(EINVAL); break;
13186         case RMS$_PRV:
13187           set_errno(EACCES); break;
13188         default:
13189           set_errno(EVMSERR);
13190       }
13191       return 0;
13192     }
13193     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
13194     if (preserve_dates & 2) {
13195       /* sys$close() will process xabrdt, not xabdat */
13196       xabrdt = cc$rms_xabrdt;
13197 #ifndef __GNUC__
13198       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
13199 #else
13200       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
13201        * is unsigned long[2], while DECC & VAXC use a struct */
13202       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
13203 #endif
13204       fab_out.fab$l_xab = (void *) &xabrdt;
13205     }
13206
13207     ubf = PerlMem_malloc(32256);
13208     if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13209     rab_in = cc$rms_rab;
13210     rab_in.rab$l_fab = &fab_in;
13211     rab_in.rab$l_rop = RAB$M_BIO;
13212     rab_in.rab$l_ubf = ubf;
13213     rab_in.rab$w_usz = 32256;
13214     if (!((sts = sys$connect(&rab_in)) & 1)) {
13215       sys$close(&fab_in); sys$close(&fab_out);
13216       PerlMem_free(vmsin);
13217       PerlMem_free(vmsout);
13218       PerlMem_free(ubf);
13219       PerlMem_free(esa);
13220       if (esal != NULL)
13221           PerlMem_free(esal);
13222       PerlMem_free(rsa);
13223       if (rsal != NULL)
13224           PerlMem_free(rsal);
13225       PerlMem_free(esa_out);
13226       if (esal_out != NULL)
13227           PerlMem_free(esal_out);
13228       PerlMem_free(rsa_out);
13229       if (rsal_out != NULL)
13230           PerlMem_free(rsal_out);
13231       set_errno(EVMSERR); set_vaxc_errno(sts);
13232       return 0;
13233     }
13234
13235     rab_out = cc$rms_rab;
13236     rab_out.rab$l_fab = &fab_out;
13237     rab_out.rab$l_rbf = ubf;
13238     if (!((sts = sys$connect(&rab_out)) & 1)) {
13239       sys$close(&fab_in); sys$close(&fab_out);
13240       PerlMem_free(vmsin);
13241       PerlMem_free(vmsout);
13242       PerlMem_free(ubf);
13243       PerlMem_free(esa);
13244       if (esal != NULL)
13245           PerlMem_free(esal);
13246       PerlMem_free(rsa);
13247       if (rsal != NULL)
13248           PerlMem_free(rsal);
13249       PerlMem_free(esa_out);
13250       if (esal_out != NULL)
13251           PerlMem_free(esal_out);
13252       PerlMem_free(rsa_out);
13253       if (rsal_out != NULL)
13254           PerlMem_free(rsal_out);
13255       set_errno(EVMSERR); set_vaxc_errno(sts);
13256       return 0;
13257     }
13258
13259     while ((sts = sys$read(&rab_in))) {  /* always true  */
13260       if (sts == RMS$_EOF) break;
13261       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
13262       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
13263         sys$close(&fab_in); sys$close(&fab_out);
13264         PerlMem_free(vmsin);
13265         PerlMem_free(vmsout);
13266         PerlMem_free(ubf);
13267         PerlMem_free(esa);
13268         if (esal != NULL)
13269             PerlMem_free(esal);
13270         PerlMem_free(rsa);
13271         if (rsal != NULL)
13272             PerlMem_free(rsal);
13273         PerlMem_free(esa_out);
13274         if (esal_out != NULL)
13275             PerlMem_free(esal_out);
13276         PerlMem_free(rsa_out);
13277         if (rsal_out != NULL)
13278             PerlMem_free(rsal_out);
13279         set_errno(EVMSERR); set_vaxc_errno(sts);
13280         return 0;
13281       }
13282     }
13283
13284
13285     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
13286     sys$close(&fab_in);  sys$close(&fab_out);
13287     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
13288
13289     PerlMem_free(vmsin);
13290     PerlMem_free(vmsout);
13291     PerlMem_free(ubf);
13292     PerlMem_free(esa);
13293     if (esal != NULL)
13294         PerlMem_free(esal);
13295     PerlMem_free(rsa);
13296     if (rsal != NULL)
13297         PerlMem_free(rsal);
13298     PerlMem_free(esa_out);
13299     if (esal_out != NULL)
13300         PerlMem_free(esal_out);
13301     PerlMem_free(rsa_out);
13302     if (rsal_out != NULL)
13303         PerlMem_free(rsal_out);
13304
13305     if (!(sts & 1)) {
13306       set_errno(EVMSERR); set_vaxc_errno(sts);
13307       return 0;
13308     }
13309
13310     return 1;
13311
13312 }  /* end of rmscopy() */
13313 /*}}}*/
13314
13315
13316 /***  The following glue provides 'hooks' to make some of the routines
13317  * from this file available from Perl.  These routines are sufficiently
13318  * basic, and are required sufficiently early in the build process,
13319  * that's it's nice to have them available to miniperl as well as the
13320  * full Perl, so they're set up here instead of in an extension.  The
13321  * Perl code which handles importation of these names into a given
13322  * package lives in [.VMS]Filespec.pm in @INC.
13323  */
13324
13325 void
13326 rmsexpand_fromperl(pTHX_ CV *cv)
13327 {
13328   dXSARGS;
13329   char *fspec, *defspec = NULL, *rslt;
13330   STRLEN n_a;
13331   int fs_utf8, dfs_utf8;
13332
13333   fs_utf8 = 0;
13334   dfs_utf8 = 0;
13335   if (!items || items > 2)
13336     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
13337   fspec = SvPV(ST(0),n_a);
13338   fs_utf8 = SvUTF8(ST(0));
13339   if (!fspec || !*fspec) XSRETURN_UNDEF;
13340   if (items == 2) {
13341     defspec = SvPV(ST(1),n_a);
13342     dfs_utf8 = SvUTF8(ST(1));
13343   }
13344   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
13345   ST(0) = sv_newmortal();
13346   if (rslt != NULL) {
13347     sv_usepvn(ST(0),rslt,strlen(rslt));
13348     if (fs_utf8) {
13349         SvUTF8_on(ST(0));
13350     }
13351   }
13352   XSRETURN(1);
13353 }
13354
13355 void
13356 vmsify_fromperl(pTHX_ CV *cv)
13357 {
13358   dXSARGS;
13359   char *vmsified;
13360   STRLEN n_a;
13361   int utf8_fl;
13362
13363   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
13364   utf8_fl = SvUTF8(ST(0));
13365   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13366   ST(0) = sv_newmortal();
13367   if (vmsified != NULL) {
13368     sv_usepvn(ST(0),vmsified,strlen(vmsified));
13369     if (utf8_fl) {
13370         SvUTF8_on(ST(0));
13371     }
13372   }
13373   XSRETURN(1);
13374 }
13375
13376 void
13377 unixify_fromperl(pTHX_ CV *cv)
13378 {
13379   dXSARGS;
13380   char *unixified;
13381   STRLEN n_a;
13382   int utf8_fl;
13383
13384   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
13385   utf8_fl = SvUTF8(ST(0));
13386   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13387   ST(0) = sv_newmortal();
13388   if (unixified != NULL) {
13389     sv_usepvn(ST(0),unixified,strlen(unixified));
13390     if (utf8_fl) {
13391         SvUTF8_on(ST(0));
13392     }
13393   }
13394   XSRETURN(1);
13395 }
13396
13397 void
13398 fileify_fromperl(pTHX_ CV *cv)
13399 {
13400   dXSARGS;
13401   char *fileified;
13402   STRLEN n_a;
13403   int utf8_fl;
13404
13405   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
13406   utf8_fl = SvUTF8(ST(0));
13407   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13408   ST(0) = sv_newmortal();
13409   if (fileified != NULL) {
13410     sv_usepvn(ST(0),fileified,strlen(fileified));
13411     if (utf8_fl) {
13412         SvUTF8_on(ST(0));
13413     }
13414   }
13415   XSRETURN(1);
13416 }
13417
13418 void
13419 pathify_fromperl(pTHX_ CV *cv)
13420 {
13421   dXSARGS;
13422   char *pathified;
13423   STRLEN n_a;
13424   int utf8_fl;
13425
13426   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
13427   utf8_fl = SvUTF8(ST(0));
13428   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13429   ST(0) = sv_newmortal();
13430   if (pathified != NULL) {
13431     sv_usepvn(ST(0),pathified,strlen(pathified));
13432     if (utf8_fl) {
13433         SvUTF8_on(ST(0));
13434     }
13435   }
13436   XSRETURN(1);
13437 }
13438
13439 void
13440 vmspath_fromperl(pTHX_ CV *cv)
13441 {
13442   dXSARGS;
13443   char *vmspath;
13444   STRLEN n_a;
13445   int utf8_fl;
13446
13447   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
13448   utf8_fl = SvUTF8(ST(0));
13449   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13450   ST(0) = sv_newmortal();
13451   if (vmspath != NULL) {
13452     sv_usepvn(ST(0),vmspath,strlen(vmspath));
13453     if (utf8_fl) {
13454         SvUTF8_on(ST(0));
13455     }
13456   }
13457   XSRETURN(1);
13458 }
13459
13460 void
13461 unixpath_fromperl(pTHX_ CV *cv)
13462 {
13463   dXSARGS;
13464   char *unixpath;
13465   STRLEN n_a;
13466   int utf8_fl;
13467
13468   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
13469   utf8_fl = SvUTF8(ST(0));
13470   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13471   ST(0) = sv_newmortal();
13472   if (unixpath != NULL) {
13473     sv_usepvn(ST(0),unixpath,strlen(unixpath));
13474     if (utf8_fl) {
13475         SvUTF8_on(ST(0));
13476     }
13477   }
13478   XSRETURN(1);
13479 }
13480
13481 void
13482 candelete_fromperl(pTHX_ CV *cv)
13483 {
13484   dXSARGS;
13485   char *fspec, *fsp;
13486   SV *mysv;
13487   IO *io;
13488   STRLEN n_a;
13489
13490   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
13491
13492   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13493   Newx(fspec, VMS_MAXRSS, char);
13494   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
13495   if (SvTYPE(mysv) == SVt_PVGV) {
13496     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
13497       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13498       ST(0) = &PL_sv_no;
13499       Safefree(fspec);
13500       XSRETURN(1);
13501     }
13502     fsp = fspec;
13503   }
13504   else {
13505     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
13506       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13507       ST(0) = &PL_sv_no;
13508       Safefree(fspec);
13509       XSRETURN(1);
13510     }
13511   }
13512
13513   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
13514   Safefree(fspec);
13515   XSRETURN(1);
13516 }
13517
13518 void
13519 rmscopy_fromperl(pTHX_ CV *cv)
13520 {
13521   dXSARGS;
13522   char *inspec, *outspec, *inp, *outp;
13523   int date_flag;
13524   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
13525                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13526   unsigned long int sts;
13527   SV *mysv;
13528   IO *io;
13529   STRLEN n_a;
13530
13531   if (items < 2 || items > 3)
13532     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
13533
13534   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13535   Newx(inspec, VMS_MAXRSS, char);
13536   if (SvTYPE(mysv) == SVt_PVGV) {
13537     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
13538       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13539       ST(0) = &PL_sv_no;
13540       Safefree(inspec);
13541       XSRETURN(1);
13542     }
13543     inp = inspec;
13544   }
13545   else {
13546     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
13547       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13548       ST(0) = &PL_sv_no;
13549       Safefree(inspec);
13550       XSRETURN(1);
13551     }
13552   }
13553   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
13554   Newx(outspec, VMS_MAXRSS, char);
13555   if (SvTYPE(mysv) == SVt_PVGV) {
13556     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
13557       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13558       ST(0) = &PL_sv_no;
13559       Safefree(inspec);
13560       Safefree(outspec);
13561       XSRETURN(1);
13562     }
13563     outp = outspec;
13564   }
13565   else {
13566     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
13567       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13568       ST(0) = &PL_sv_no;
13569       Safefree(inspec);
13570       Safefree(outspec);
13571       XSRETURN(1);
13572     }
13573   }
13574   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
13575
13576   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
13577   Safefree(inspec);
13578   Safefree(outspec);
13579   XSRETURN(1);
13580 }
13581
13582 /* The mod2fname is limited to shorter filenames by design, so it should
13583  * not be modified to support longer EFS pathnames
13584  */
13585 void
13586 mod2fname(pTHX_ CV *cv)
13587 {
13588   dXSARGS;
13589   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
13590        workbuff[NAM$C_MAXRSS*1 + 1];
13591   int total_namelen = 3, counter, num_entries;
13592   /* ODS-5 ups this, but we want to be consistent, so... */
13593   int max_name_len = 39;
13594   AV *in_array = (AV *)SvRV(ST(0));
13595
13596   num_entries = av_len(in_array);
13597
13598   /* All the names start with PL_. */
13599   strcpy(ultimate_name, "PL_");
13600
13601   /* Clean up our working buffer */
13602   Zero(work_name, sizeof(work_name), char);
13603
13604   /* Run through the entries and build up a working name */
13605   for(counter = 0; counter <= num_entries; counter++) {
13606     /* If it's not the first name then tack on a __ */
13607     if (counter) {
13608       strcat(work_name, "__");
13609     }
13610     strcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)));
13611   }
13612
13613   /* Check to see if we actually have to bother...*/
13614   if (strlen(work_name) + 3 <= max_name_len) {
13615     strcat(ultimate_name, work_name);
13616   } else {
13617     /* It's too darned big, so we need to go strip. We use the same */
13618     /* algorithm as xsubpp does. First, strip out doubled __ */
13619     char *source, *dest, last;
13620     dest = workbuff;
13621     last = 0;
13622     for (source = work_name; *source; source++) {
13623       if (last == *source && last == '_') {
13624         continue;
13625       }
13626       *dest++ = *source;
13627       last = *source;
13628     }
13629     /* Go put it back */
13630     strcpy(work_name, workbuff);
13631     /* Is it still too big? */
13632     if (strlen(work_name) + 3 > max_name_len) {
13633       /* Strip duplicate letters */
13634       last = 0;
13635       dest = workbuff;
13636       for (source = work_name; *source; source++) {
13637         if (last == toupper(*source)) {
13638         continue;
13639         }
13640         *dest++ = *source;
13641         last = toupper(*source);
13642       }
13643       strcpy(work_name, workbuff);
13644     }
13645
13646     /* Is it *still* too big? */
13647     if (strlen(work_name) + 3 > max_name_len) {
13648       /* Too bad, we truncate */
13649       work_name[max_name_len - 2] = 0;
13650     }
13651     strcat(ultimate_name, work_name);
13652   }
13653
13654   /* Okay, return it */
13655   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
13656   XSRETURN(1);
13657 }
13658
13659 void
13660 hushexit_fromperl(pTHX_ CV *cv)
13661 {
13662     dXSARGS;
13663
13664     if (items > 0) {
13665         VMSISH_HUSHED = SvTRUE(ST(0));
13666     }
13667     ST(0) = boolSV(VMSISH_HUSHED);
13668     XSRETURN(1);
13669 }
13670
13671
13672 PerlIO *
13673 Perl_vms_start_glob
13674    (pTHX_ SV *tmpglob,
13675     IO *io)
13676 {
13677     PerlIO *fp;
13678     struct vs_str_st *rslt;
13679     char *vmsspec;
13680     char *rstr;
13681     char *begin, *cp;
13682     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13683     PerlIO *tmpfp;
13684     STRLEN i;
13685     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13686     struct dsc$descriptor_vs rsdsc;
13687     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13688     unsigned long hasver = 0, isunix = 0;
13689     unsigned long int lff_flags = 0;
13690     int rms_sts;
13691     int vms_old_glob = 1;
13692
13693     if (!SvOK(tmpglob)) {
13694         SETERRNO(ENOENT,RMS$_FNF);
13695         return NULL;
13696     }
13697
13698     vms_old_glob = !decc_filename_unix_report;
13699
13700 #ifdef VMS_LONGNAME_SUPPORT
13701     lff_flags = LIB$M_FIL_LONG_NAMES;
13702 #endif
13703     /* The Newx macro will not allow me to assign a smaller array
13704      * to the rslt pointer, so we will assign it to the begin char pointer
13705      * and then copy the value into the rslt pointer.
13706      */
13707     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13708     rslt = (struct vs_str_st *)begin;
13709     rslt->length = 0;
13710     rstr = &rslt->str[0];
13711     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13712     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13713     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13714     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13715
13716     Newx(vmsspec, VMS_MAXRSS, char);
13717
13718         /* We could find out if there's an explicit dev/dir or version
13719            by peeking into lib$find_file's internal context at
13720            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13721            but that's unsupported, so I don't want to do it now and
13722            have it bite someone in the future. */
13723         /* Fix-me: vms_split_path() is the only way to do this, the
13724            existing method will fail with many legal EFS or UNIX specifications
13725          */
13726
13727     cp = SvPV(tmpglob,i);
13728
13729     for (; i; i--) {
13730         if (cp[i] == ';') hasver = 1;
13731         if (cp[i] == '.') {
13732             if (sts) hasver = 1;
13733             else sts = 1;
13734         }
13735         if (cp[i] == '/') {
13736             hasdir = isunix = 1;
13737             break;
13738         }
13739         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13740             hasdir = 1;
13741             break;
13742         }
13743     }
13744
13745     /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13746     if ((hasdir == 0) && decc_filename_unix_report) {
13747         isunix = 1;
13748     }
13749
13750     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13751         char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13752         int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13753         int wildstar = 0;
13754         int wildquery = 0;
13755         int found = 0;
13756         Stat_t st;
13757         int stat_sts;
13758         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13759         if (!stat_sts && S_ISDIR(st.st_mode)) {
13760             char * vms_dir;
13761             const char * fname;
13762             STRLEN fname_len;
13763
13764             /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13765             /* path delimiter of ':>]', if so, then the old behavior has */
13766             /* obviously been specificially requested */
13767
13768             fname = SvPVX_const(tmpglob);
13769             fname_len = strlen(fname);
13770             vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13771             if (vms_old_glob || (vms_dir != NULL)) {
13772                 wilddsc.dsc$a_pointer = tovmspath_utf8(
13773                                             SvPVX(tmpglob),vmsspec,NULL);
13774                 ok = (wilddsc.dsc$a_pointer != NULL);
13775                 /* maybe passed 'foo' rather than '[.foo]', thus not
13776                    detected above */
13777                 hasdir = 1;
13778             } else {
13779                 /* Operate just on the directory, the special stat/fstat for */
13780                 /* leaves the fileified  specification in the st_devnam */
13781                 /* member. */
13782                 wilddsc.dsc$a_pointer = st.st_devnam;
13783                 ok = 1;
13784             }
13785         }
13786         else {
13787             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13788             ok = (wilddsc.dsc$a_pointer != NULL);
13789         }
13790         if (ok)
13791             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13792
13793         /* If not extended character set, replace ? with % */
13794         /* With extended character set, ? is a wildcard single character */
13795         for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13796             if (*cp == '?') {
13797                 wildquery = 1;
13798                 if (!decc_efs_case_preserve)
13799                     *cp = '%';
13800             } else if (*cp == '%') {
13801                 wildquery = 1;
13802             } else if (*cp == '*') {
13803                 wildstar = 1;
13804             }
13805         }
13806
13807         if (ok) {
13808             wv_sts = vms_split_path(
13809                 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13810                 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13811                 &wvs_spec, &wvs_len);
13812         } else {
13813             wn_spec = NULL;
13814             wn_len = 0;
13815             we_spec = NULL;
13816             we_len = 0;
13817         }
13818
13819         sts = SS$_NORMAL;
13820         while (ok && $VMS_STATUS_SUCCESS(sts)) {
13821          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13822          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13823          int valid_find;
13824
13825             valid_find = 0;
13826             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13827                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
13828             if (!$VMS_STATUS_SUCCESS(sts))
13829                 break;
13830
13831             /* with varying string, 1st word of buffer contains result length */
13832             rstr[rslt->length] = '\0';
13833
13834              /* Find where all the components are */
13835              v_sts = vms_split_path
13836                        (rstr,
13837                         &v_spec,
13838                         &v_len,
13839                         &r_spec,
13840                         &r_len,
13841                         &d_spec,
13842                         &d_len,
13843                         &n_spec,
13844                         &n_len,
13845                         &e_spec,
13846                         &e_len,
13847                         &vs_spec,
13848                         &vs_len);
13849
13850             /* If no version on input, truncate the version on output */
13851             if (!hasver && (vs_len > 0)) {
13852                 *vs_spec = '\0';
13853                 vs_len = 0;
13854             }
13855
13856             if (isunix) {
13857
13858                 /* In Unix report mode, remove the ".dir;1" from the name */
13859                 /* if it is a real directory */
13860                 if (decc_filename_unix_report || decc_efs_charset) {
13861                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13862                         Stat_t statbuf;
13863                         int ret_sts;
13864
13865                         ret_sts = flex_lstat(rstr, &statbuf);
13866                         if ((ret_sts == 0) &&
13867                             S_ISDIR(statbuf.st_mode)) {
13868                             e_len = 0;
13869                             e_spec[0] = 0;
13870                         }
13871                     }
13872                 }
13873
13874                 /* No version & a null extension on UNIX handling */
13875                 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13876                     e_len = 0;
13877                     *e_spec = '\0';
13878                 }
13879             }
13880
13881             if (!decc_efs_case_preserve) {
13882                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13883             }
13884
13885             /* Find File treats a Null extension as return all extensions */
13886             /* This is contrary to Perl expectations */
13887
13888             if (wildstar || wildquery || vms_old_glob) {
13889                 /* really need to see if the returned file name matched */
13890                 /* but for now will assume that it matches */
13891                 valid_find = 1;
13892             } else {
13893                 /* Exact Match requested */
13894                 /* How are directories handled? - like a file */
13895                 if ((e_len == we_len) && (n_len == wn_len)) {
13896                     int t1;
13897                     t1 = e_len;
13898                     if (t1 > 0)
13899                         t1 = strncmp(e_spec, we_spec, e_len);
13900                     if (t1 == 0) {
13901                        t1 = n_len;
13902                        if (t1 > 0)
13903                            t1 = strncmp(n_spec, we_spec, n_len);
13904                        if (t1 == 0)
13905                            valid_find = 1;
13906                     }
13907                 }
13908             }
13909
13910             if (valid_find) {
13911                 found++;
13912
13913                 if (hasdir) {
13914                     if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13915                     begin = rstr;
13916                 }
13917                 else {
13918                     /* Start with the name */
13919                     begin = n_spec;
13920                 }
13921                 strcat(begin,"\n");
13922                 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13923             }
13924         }
13925         if (cxt) (void)lib$find_file_end(&cxt);
13926
13927         if (!found) {
13928             /* Be POSIXish: return the input pattern when no matches */
13929             strcpy(rstr,SvPVX(tmpglob));
13930             strcat(rstr,"\n");
13931             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13932         }
13933
13934         if (ok && sts != RMS$_NMF &&
13935             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13936         if (!ok) {
13937             if (!(sts & 1)) {
13938                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13939             }
13940             PerlIO_close(tmpfp);
13941             fp = NULL;
13942         }
13943         else {
13944             PerlIO_rewind(tmpfp);
13945             IoTYPE(io) = IoTYPE_RDONLY;
13946             IoIFP(io) = fp = tmpfp;
13947             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
13948         }
13949     }
13950     Safefree(vmsspec);
13951     Safefree(rslt);
13952     return fp;
13953 }
13954
13955
13956 static char *
13957 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13958                    int *utf8_fl);
13959
13960 void
13961 unixrealpath_fromperl(pTHX_ CV *cv)
13962 {
13963     dXSARGS;
13964     char *fspec, *rslt_spec, *rslt;
13965     STRLEN n_a;
13966
13967     if (!items || items != 1)
13968         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
13969
13970     fspec = SvPV(ST(0),n_a);
13971     if (!fspec || !*fspec) XSRETURN_UNDEF;
13972
13973     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13974     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13975
13976     ST(0) = sv_newmortal();
13977     if (rslt != NULL)
13978         sv_usepvn(ST(0),rslt,strlen(rslt));
13979     else
13980         Safefree(rslt_spec);
13981         XSRETURN(1);
13982 }
13983
13984 static char *
13985 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13986                    int *utf8_fl);
13987
13988 void
13989 vmsrealpath_fromperl(pTHX_ CV *cv)
13990 {
13991     dXSARGS;
13992     char *fspec, *rslt_spec, *rslt;
13993     STRLEN n_a;
13994
13995     if (!items || items != 1)
13996         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
13997
13998     fspec = SvPV(ST(0),n_a);
13999     if (!fspec || !*fspec) XSRETURN_UNDEF;
14000
14001     Newx(rslt_spec, VMS_MAXRSS + 1, char);
14002     rslt = do_vms_realname(fspec, rslt_spec, NULL);
14003
14004     ST(0) = sv_newmortal();
14005     if (rslt != NULL)
14006         sv_usepvn(ST(0),rslt,strlen(rslt));
14007     else
14008         Safefree(rslt_spec);
14009         XSRETURN(1);
14010 }
14011
14012 #ifdef HAS_SYMLINK
14013 /*
14014  * A thin wrapper around decc$symlink to make sure we follow the
14015  * standard and do not create a symlink with a zero-length name.
14016  *
14017  * Also in ODS-2 mode, existing tests assume that the link target
14018  * will be converted to UNIX format.
14019  */
14020 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
14021 int Perl_my_symlink(pTHX_ const char *contents, const char *link_name) {
14022   if (!link_name || !*link_name) {
14023     SETERRNO(ENOENT, SS$_NOSUCHFILE);
14024     return -1;
14025   }
14026
14027   if (decc_efs_charset) {
14028       return symlink(contents, link_name);
14029   } else {
14030       int sts;
14031       char * utarget;
14032
14033       /* Unless we are in ODS-5 mode, convert the symlink target to UNIX */
14034       /* because in order to work, the symlink target must be in UNIX format */
14035
14036       /* As symbolic links can hold things other than files, we will only do */
14037       /* the conversion in in ODS-2 mode */
14038
14039       Newx(utarget, VMS_MAXRSS + 1, char);
14040       if (int_tounixspec(contents, utarget, NULL) == NULL) {
14041
14042           /* This should not fail, as an untranslatable filename */
14043           /* should be passed through */
14044           utarget = (char *)contents;
14045       }
14046       sts = symlink(utarget, link_name);
14047       Safefree(utarget);
14048       return sts;
14049   }
14050
14051 }
14052 /*}}}*/
14053
14054 #endif /* HAS_SYMLINK */
14055
14056 int do_vms_case_tolerant(void);
14057
14058 void
14059 case_tolerant_process_fromperl(pTHX_ CV *cv)
14060 {
14061   dXSARGS;
14062   ST(0) = boolSV(do_vms_case_tolerant());
14063   XSRETURN(1);
14064 }
14065
14066 #ifdef USE_ITHREADS
14067
14068 void
14069 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
14070                           struct interp_intern *dst)
14071 {
14072     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
14073
14074     memcpy(dst,src,sizeof(struct interp_intern));
14075 }
14076
14077 #endif
14078
14079 void
14080 Perl_sys_intern_clear(pTHX)
14081 {
14082 }
14083
14084 void
14085 Perl_sys_intern_init(pTHX)
14086 {
14087     unsigned int ix = RAND_MAX;
14088     double x;
14089
14090     VMSISH_HUSHED = 0;
14091
14092     MY_POSIX_EXIT = vms_posix_exit;
14093
14094     x = (float)ix;
14095     MY_INV_RAND_MAX = 1./x;
14096 }
14097
14098 void
14099 init_os_extras(void)
14100 {
14101   dTHX;
14102   char* file = __FILE__;
14103   if (decc_disable_to_vms_logname_translation) {
14104     no_translate_barewords = TRUE;
14105   } else {
14106     no_translate_barewords = FALSE;
14107   }
14108
14109   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
14110   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
14111   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
14112   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
14113   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
14114   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
14115   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
14116   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
14117   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
14118   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
14119   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
14120   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
14121   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
14122   newXSproto("VMS::Filespec::case_tolerant_process",
14123       case_tolerant_process_fromperl,file,"");
14124
14125   store_pipelocs(aTHX);         /* will redo any earlier attempts */
14126
14127   return;
14128 }
14129
14130 #if __CRTL_VER == 80200000
14131 /* This missed getting in to the DECC SDK for 8.2 */
14132 char *realpath(const char *file_name, char * resolved_name, ...);
14133 #endif
14134
14135 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
14136 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
14137  * The perl fallback routine to provide realpath() is not as efficient
14138  * on OpenVMS.
14139  */
14140
14141 /* Hack, use old stat() as fastest way of getting ino_t and device */
14142 int decc$stat(const char *name, void * statbuf);
14143 #if !defined(__VAX) && __CRTL_VER >= 80200000
14144 int decc$lstat(const char *name, void * statbuf);
14145 #else
14146 #define decc$lstat decc$stat
14147 #endif
14148
14149
14150 /* Realpath is fragile.  In 8.3 it does not work if the feature
14151  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
14152  * links are implemented in RMS, not the CRTL. It also can fail if the
14153  * user does not have read/execute access to some of the directories.
14154  * So in order for Do What I Mean mode to work, if realpath() fails,
14155  * fall back to looking up the filename by the device name and FID.
14156  */
14157
14158 int vms_fid_to_name(char * outname, int outlen,
14159                     const char * name, int lstat_flag, mode_t * mode)
14160 {
14161 #pragma message save
14162 #pragma message disable MISALGNDSTRCT
14163 #pragma message disable MISALGNDMEM
14164 #pragma member_alignment save
14165 #pragma nomember_alignment
14166 struct statbuf_t {
14167     char           * st_dev;
14168     unsigned short st_ino[3];
14169     unsigned short old_st_mode;
14170     unsigned long  padl[30];  /* plenty of room */
14171 } statbuf;
14172 #pragma message restore
14173 #pragma member_alignment restore
14174
14175     int sts;
14176     struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
14177     struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
14178     char *fileified;
14179     char *temp_fspec;
14180     char *ret_spec;
14181
14182     /* Need to follow the mostly the same rules as flex_stat_int, or we may get
14183      * unexpected answers
14184      */
14185
14186     fileified = PerlMem_malloc(VMS_MAXRSS);
14187     if (fileified == NULL)
14188         _ckvmssts_noperl(SS$_INSFMEM);
14189
14190     temp_fspec = PerlMem_malloc(VMS_MAXRSS);
14191     if (temp_fspec == NULL)
14192         _ckvmssts_noperl(SS$_INSFMEM);
14193
14194     sts = -1;
14195     /* First need to try as a directory */
14196     ret_spec = int_tovmspath(name, temp_fspec, NULL);
14197     if (ret_spec != NULL) {
14198         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
14199         if (ret_spec != NULL) {
14200             if (lstat_flag == 0)
14201                 sts = decc$stat(fileified, &statbuf);
14202             else
14203                 sts = decc$lstat(fileified, &statbuf);
14204         }
14205     }
14206
14207     /* Then as a VMS file spec */
14208     if (sts != 0) {
14209         ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
14210         if (ret_spec != NULL) {
14211             if (lstat_flag == 0) {
14212                 sts = decc$stat(temp_fspec, &statbuf);
14213             } else {
14214                 sts = decc$lstat(temp_fspec, &statbuf);
14215             }
14216         }
14217     }
14218
14219     if (sts) {
14220         /* Next try - allow multiple dots with out EFS CHARSET */
14221         /* The CRTL stat() falls down hard on multi-dot filenames in unix
14222          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
14223          * enable it if it isn't already.
14224          */
14225 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14226         if (!decc_efs_charset && (decc_efs_charset_index > 0))
14227             decc$feature_set_value(decc_efs_charset_index, 1, 1);
14228 #endif
14229         ret_spec = int_tovmspath(name, temp_fspec, NULL);
14230         if (lstat_flag == 0) {
14231             sts = decc$stat(name, &statbuf);
14232         } else {
14233             sts = decc$lstat(name, &statbuf);
14234         }
14235 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14236         if (!decc_efs_charset && (decc_efs_charset_index > 0))
14237             decc$feature_set_value(decc_efs_charset_index, 1, 0);
14238 #endif
14239     }
14240
14241
14242     /* and then because the Perl Unix to VMS conversion is not perfect */
14243     /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
14244     /* characters from filenames so we need to try it as-is */
14245     if (sts) {
14246         if (lstat_flag == 0) {
14247             sts = decc$stat(name, &statbuf);
14248         } else {
14249             sts = decc$lstat(name, &statbuf);
14250         }
14251     }
14252
14253     if (sts == 0) {
14254         int vms_sts;
14255
14256         dvidsc.dsc$a_pointer=statbuf.st_dev;
14257         dvidsc.dsc$w_length=strlen(statbuf.st_dev);
14258
14259         specdsc.dsc$a_pointer = outname;
14260         specdsc.dsc$w_length = outlen-1;
14261
14262         vms_sts = lib$fid_to_name
14263             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
14264         if ($VMS_STATUS_SUCCESS(vms_sts)) {
14265             outname[specdsc.dsc$w_length] = 0;
14266
14267             /* Return the mode */
14268             if (mode) {
14269                 *mode = statbuf.old_st_mode;
14270             }
14271             return 0;
14272         }
14273     }
14274     return sts;
14275 }
14276
14277
14278
14279 static char *
14280 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
14281                    int *utf8_fl)
14282 {
14283     char * rslt = NULL;
14284
14285 #ifdef HAS_SYMLINK
14286     if (decc_posix_compliant_pathnames > 0 ) {
14287         /* realpath currently only works if posix compliant pathnames are
14288          * enabled.  It may start working when they are not, but in that
14289          * case we still want the fallback behavior for backwards compatibility
14290          */
14291         rslt = realpath(filespec, outbuf);
14292     }
14293 #endif
14294
14295     if (rslt == NULL) {
14296         char * vms_spec;
14297         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
14298         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
14299         int file_len;
14300         mode_t my_mode;
14301
14302         /* Fall back to fid_to_name */
14303
14304         Newx(vms_spec, VMS_MAXRSS + 1, char);
14305
14306         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
14307         if (sts == 0) {
14308
14309
14310             /* Now need to trim the version off */
14311             sts = vms_split_path
14312                   (vms_spec,
14313                    &v_spec,
14314                    &v_len,
14315                    &r_spec,
14316                    &r_len,
14317                    &d_spec,
14318                    &d_len,
14319                    &n_spec,
14320                    &n_len,
14321                    &e_spec,
14322                    &e_len,
14323                    &vs_spec,
14324                    &vs_len);
14325
14326
14327                 if (sts == 0) {
14328                     int haslower = 0;
14329                     const char *cp;
14330
14331                     /* Trim off the version */
14332                     int file_len = v_len + r_len + d_len + n_len + e_len;
14333                     vms_spec[file_len] = 0;
14334
14335                     /* The result is expected to be in UNIX format */
14336                     rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
14337
14338                     /* Downcase if input had any lower case letters and
14339                      * case preservation is not in effect.
14340                      */
14341                     if (!decc_efs_case_preserve) {
14342                         for (cp = filespec; *cp; cp++)
14343                             if (islower(*cp)) { haslower = 1; break; }
14344
14345                         if (haslower) __mystrtolower(rslt);
14346                     }
14347                 }
14348         } else {
14349
14350             /* Now for some hacks to deal with backwards and forward */
14351             /* compatibilty */
14352             if (!decc_efs_charset) {
14353
14354                 /* 1. ODS-2 mode wants to do a syntax only translation */
14355                 rslt = int_rmsexpand(filespec, outbuf,
14356                                     NULL, 0, NULL, utf8_fl);
14357
14358             } else {
14359                 if (decc_filename_unix_report) {
14360                     char * dir_name;
14361                     char * vms_dir_name;
14362                     char * file_name;
14363
14364                     /* 2. ODS-5 / UNIX report mode should return a failure */
14365                     /*    if the parent directory also does not exist */
14366                     /*    Otherwise, get the real path for the parent */
14367                     /*    and add the child to it.
14368
14369                     /* basename / dirname only available for VMS 7.0+ */
14370                     /* So we may need to implement them as common routines */
14371
14372                     Newx(dir_name, VMS_MAXRSS + 1, char);
14373                     Newx(vms_dir_name, VMS_MAXRSS + 1, char);
14374                     dir_name[0] = '\0';
14375                     file_name = NULL;
14376
14377                     /* First try a VMS parse */
14378                     sts = vms_split_path
14379                           (filespec,
14380                            &v_spec,
14381                            &v_len,
14382                            &r_spec,
14383                            &r_len,
14384                            &d_spec,
14385                            &d_len,
14386                            &n_spec,
14387                            &n_len,
14388                            &e_spec,
14389                            &e_len,
14390                            &vs_spec,
14391                            &vs_len);
14392
14393                     if (sts == 0) {
14394                         /* This is VMS */
14395
14396                         int dir_len = v_len + r_len + d_len + n_len;
14397                         if (dir_len > 0) {
14398                            strncpy(dir_name, filespec, dir_len);
14399                            dir_name[dir_len] = '\0';
14400                            file_name = (char *)&filespec[dir_len + 1];
14401                         }
14402                     } else {
14403                         /* This must be UNIX */
14404                         char * tchar;
14405
14406                         tchar = strrchr(filespec, '/');
14407
14408                         if (tchar != NULL) {
14409                             int dir_len = tchar - filespec;
14410                             strncpy(dir_name, filespec, dir_len);
14411                             dir_name[dir_len] = '\0';
14412                             file_name = (char *) &filespec[dir_len + 1];
14413                         }
14414                     }
14415
14416                     /* Dir name is defaulted */
14417                     if (dir_name[0] == 0) {
14418                         dir_name[0] = '.';
14419                         dir_name[1] = '\0';
14420                     }
14421
14422                     /* Need realpath for the directory */
14423                     sts = vms_fid_to_name(vms_dir_name,
14424                                           VMS_MAXRSS + 1,
14425                                           dir_name, 0, NULL);
14426
14427                     if (sts == 0) {
14428                         /* Now need to pathify it.
14429                         char *tdir = int_pathify_dirspec(vms_dir_name,
14430                                                          outbuf);
14431
14432                         /* And now add the original filespec to it */
14433                         if (file_name != NULL) {
14434                             strcat(outbuf, file_name);
14435                         }
14436                         return outbuf;
14437                     }
14438                     Safefree(vms_dir_name);
14439                     Safefree(dir_name);
14440                 }
14441             }
14442         }
14443         Safefree(vms_spec);
14444     }
14445     return rslt;
14446 }
14447
14448 static char *
14449 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
14450                    int *utf8_fl)
14451 {
14452     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
14453     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
14454     int file_len;
14455
14456     /* Fall back to fid_to_name */
14457
14458     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
14459     if (sts != 0) {
14460         return NULL;
14461     }
14462     else {
14463
14464
14465         /* Now need to trim the version off */
14466         sts = vms_split_path
14467                   (outbuf,
14468                    &v_spec,
14469                    &v_len,
14470                    &r_spec,
14471                    &r_len,
14472                    &d_spec,
14473                    &d_len,
14474                    &n_spec,
14475                    &n_len,
14476                    &e_spec,
14477                    &e_len,
14478                    &vs_spec,
14479                    &vs_len);
14480
14481
14482         if (sts == 0) {
14483             int haslower = 0;
14484             const char *cp;
14485
14486             /* Trim off the version */
14487             int file_len = v_len + r_len + d_len + n_len + e_len;
14488             outbuf[file_len] = 0;
14489
14490             /* Downcase if input had any lower case letters and
14491              * case preservation is not in effect.
14492              */
14493             if (!decc_efs_case_preserve) {
14494                 for (cp = filespec; *cp; cp++)
14495                     if (islower(*cp)) { haslower = 1; break; }
14496
14497                 if (haslower) __mystrtolower(outbuf);
14498             }
14499         }
14500     }
14501     return outbuf;
14502 }
14503
14504
14505 /*}}}*/
14506 /* External entry points */
14507 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
14508 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
14509
14510 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
14511 { return do_vms_realname(filespec, outbuf, utf8_fl); }
14512
14513 /* case_tolerant */
14514
14515 /*{{{int do_vms_case_tolerant(void)*/
14516 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
14517  * controlled by a process setting.
14518  */
14519 int do_vms_case_tolerant(void)
14520 {
14521     return vms_process_case_tolerant;
14522 }
14523 /*}}}*/
14524 /* External entry points */
14525 #if __CRTL_VER >= 70301000 && !defined(__VAX)
14526 int Perl_vms_case_tolerant(void)
14527 { return do_vms_case_tolerant(); }
14528 #else
14529 int Perl_vms_case_tolerant(void)
14530 { return vms_process_case_tolerant; }
14531 #endif
14532
14533
14534  /* Start of DECC RTL Feature handling */
14535
14536 static int sys_trnlnm
14537    (const char * logname,
14538     char * value,
14539     int value_len)
14540 {
14541     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
14542     const unsigned long attr = LNM$M_CASE_BLIND;
14543     struct dsc$descriptor_s name_dsc;
14544     int status;
14545     unsigned short result;
14546     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
14547                                 {0, 0, 0, 0}};
14548
14549     name_dsc.dsc$w_length = strlen(logname);
14550     name_dsc.dsc$a_pointer = (char *)logname;
14551     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14552     name_dsc.dsc$b_class = DSC$K_CLASS_S;
14553
14554     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
14555
14556     if ($VMS_STATUS_SUCCESS(status)) {
14557
14558          /* Null terminate and return the string */
14559         /*--------------------------------------*/
14560         value[result] = 0;
14561     }
14562
14563     return status;
14564 }
14565
14566 static int sys_crelnm
14567    (const char * logname,
14568     const char * value)
14569 {
14570     int ret_val;
14571     const char * proc_table = "LNM$PROCESS_TABLE";
14572     struct dsc$descriptor_s proc_table_dsc;
14573     struct dsc$descriptor_s logname_dsc;
14574     struct itmlst_3 item_list[2];
14575
14576     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
14577     proc_table_dsc.dsc$w_length = strlen(proc_table);
14578     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14579     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
14580
14581     logname_dsc.dsc$a_pointer = (char *) logname;
14582     logname_dsc.dsc$w_length = strlen(logname);
14583     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14584     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
14585
14586     item_list[0].buflen = strlen(value);
14587     item_list[0].itmcode = LNM$_STRING;
14588     item_list[0].bufadr = (char *)value;
14589     item_list[0].retlen = NULL;
14590
14591     item_list[1].buflen = 0;
14592     item_list[1].itmcode = 0;
14593
14594     ret_val = sys$crelnm
14595                        (NULL,
14596                         (const struct dsc$descriptor_s *)&proc_table_dsc,
14597                         (const struct dsc$descriptor_s *)&logname_dsc,
14598                         NULL,
14599                         (const struct item_list_3 *) item_list);
14600
14601     return ret_val;
14602 }
14603
14604 /* C RTL Feature settings */
14605
14606 static int set_features
14607    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
14608     int (* cli_routine)(void),  /* Not documented */
14609     void *image_info)           /* Not documented */
14610 {
14611     int status;
14612     int s;
14613     char* str;
14614     char val_str[10];
14615 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
14616     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
14617     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
14618     unsigned long case_perm;
14619     unsigned long case_image;
14620 #endif
14621
14622     /* Allow an exception to bring Perl into the VMS debugger */
14623     vms_debug_on_exception = 0;
14624     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
14625     if ($VMS_STATUS_SUCCESS(status)) {
14626        val_str[0] = _toupper(val_str[0]);
14627        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14628          vms_debug_on_exception = 1;
14629        else
14630          vms_debug_on_exception = 0;
14631     }
14632
14633     /* Debug unix/vms file translation routines */
14634     vms_debug_fileify = 0;
14635     status = sys_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
14636     if ($VMS_STATUS_SUCCESS(status)) {
14637         val_str[0] = _toupper(val_str[0]);
14638         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14639             vms_debug_fileify = 1;
14640         else
14641             vms_debug_fileify = 0;
14642     }
14643
14644
14645     /* Historically PERL has been doing vmsify / stat differently than */
14646     /* the CRTL.  In particular, under some conditions the CRTL will   */
14647     /* remove some illegal characters like spaces from filenames       */
14648     /* resulting in some differences.  The stat()/lstat() wrapper has  */
14649     /* been reporting such file names as invalid and fails to stat them */
14650     /* fixing this bug so that stat()/lstat() accept these like the     */
14651     /* CRTL does will result in several tests failing.                  */
14652     /* This should really be fixed, but for now, set up a feature to    */
14653     /* enable it so that the impact can be studied.                     */
14654     vms_bug_stat_filename = 0;
14655     status = sys_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
14656     if ($VMS_STATUS_SUCCESS(status)) {
14657         val_str[0] = _toupper(val_str[0]);
14658         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14659             vms_bug_stat_filename = 1;
14660         else
14661             vms_bug_stat_filename = 0;
14662     }
14663
14664
14665     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
14666     vms_vtf7_filenames = 0;
14667     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
14668     if ($VMS_STATUS_SUCCESS(status)) {
14669        val_str[0] = _toupper(val_str[0]);
14670        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14671          vms_vtf7_filenames = 1;
14672        else
14673          vms_vtf7_filenames = 0;
14674     }
14675
14676     /* unlink all versions on unlink() or rename() */
14677     vms_unlink_all_versions = 0;
14678     status = sys_trnlnm
14679         ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
14680     if ($VMS_STATUS_SUCCESS(status)) {
14681        val_str[0] = _toupper(val_str[0]);
14682        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14683          vms_unlink_all_versions = 1;
14684        else
14685          vms_unlink_all_versions = 0;
14686     }
14687
14688     /* Dectect running under GNV Bash or other UNIX like shell */
14689 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14690     gnv_unix_shell = 0;
14691     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
14692     if ($VMS_STATUS_SUCCESS(status)) {
14693          gnv_unix_shell = 1;
14694          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
14695          set_feature_default("DECC$EFS_CHARSET", 1);
14696          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
14697          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
14698          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
14699          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
14700          vms_unlink_all_versions = 1;
14701          vms_posix_exit = 1;
14702     }
14703 #endif
14704
14705     /* hacks to see if known bugs are still present for testing */
14706
14707     /* PCP mode requires creating /dev/null special device file */
14708     decc_bug_devnull = 0;
14709     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14710     if ($VMS_STATUS_SUCCESS(status)) {
14711        val_str[0] = _toupper(val_str[0]);
14712        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14713           decc_bug_devnull = 1;
14714        else
14715           decc_bug_devnull = 0;
14716     }
14717
14718     /* UNIX directory names with no paths are broken in a lot of places */
14719     decc_dir_barename = 1;
14720     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
14721     if ($VMS_STATUS_SUCCESS(status)) {
14722       val_str[0] = _toupper(val_str[0]);
14723       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14724         decc_dir_barename = 1;
14725       else
14726         decc_dir_barename = 0;
14727     }
14728
14729 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14730     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14731     if (s >= 0) {
14732         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14733         if (decc_disable_to_vms_logname_translation < 0)
14734             decc_disable_to_vms_logname_translation = 0;
14735     }
14736
14737     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14738     if (s >= 0) {
14739         decc_efs_case_preserve = decc$feature_get_value(s, 1);
14740         if (decc_efs_case_preserve < 0)
14741             decc_efs_case_preserve = 0;
14742     }
14743
14744     s = decc$feature_get_index("DECC$EFS_CHARSET");
14745     decc_efs_charset_index = s;
14746     if (s >= 0) {
14747         decc_efs_charset = decc$feature_get_value(s, 1);
14748         if (decc_efs_charset < 0)
14749             decc_efs_charset = 0;
14750     }
14751
14752     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14753     if (s >= 0) {
14754         decc_filename_unix_report = decc$feature_get_value(s, 1);
14755         if (decc_filename_unix_report > 0) {
14756             decc_filename_unix_report = 1;
14757             vms_posix_exit = 1;
14758         }
14759         else
14760             decc_filename_unix_report = 0;
14761     }
14762
14763     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14764     if (s >= 0) {
14765         decc_filename_unix_only = decc$feature_get_value(s, 1);
14766         if (decc_filename_unix_only > 0) {
14767             decc_filename_unix_only = 1;
14768         }
14769         else {
14770             decc_filename_unix_only = 0;
14771         }
14772     }
14773
14774     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14775     if (s >= 0) {
14776         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14777         if (decc_filename_unix_no_version < 0)
14778             decc_filename_unix_no_version = 0;
14779     }
14780
14781     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14782     if (s >= 0) {
14783         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14784         if (decc_readdir_dropdotnotype < 0)
14785             decc_readdir_dropdotnotype = 0;
14786     }
14787
14788 #if __CRTL_VER >= 80200000
14789     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14790     if (s >= 0) {
14791         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14792         if (decc_posix_compliant_pathnames < 0)
14793             decc_posix_compliant_pathnames = 0;
14794         if (decc_posix_compliant_pathnames > 4)
14795             decc_posix_compliant_pathnames = 0;
14796     }
14797
14798 #endif
14799 #else
14800     status = sys_trnlnm
14801         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
14802     if ($VMS_STATUS_SUCCESS(status)) {
14803         val_str[0] = _toupper(val_str[0]);
14804         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14805            decc_disable_to_vms_logname_translation = 1;
14806         }
14807     }
14808
14809 #ifndef __VAX
14810     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
14811     if ($VMS_STATUS_SUCCESS(status)) {
14812         val_str[0] = _toupper(val_str[0]);
14813         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14814            decc_efs_case_preserve = 1;
14815         }
14816     }
14817 #endif
14818
14819     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14820     if ($VMS_STATUS_SUCCESS(status)) {
14821         val_str[0] = _toupper(val_str[0]);
14822         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14823            decc_filename_unix_report = 1;
14824         }
14825     }
14826     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14827     if ($VMS_STATUS_SUCCESS(status)) {
14828         val_str[0] = _toupper(val_str[0]);
14829         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14830            decc_filename_unix_only = 1;
14831            decc_filename_unix_report = 1;
14832         }
14833     }
14834     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14835     if ($VMS_STATUS_SUCCESS(status)) {
14836         val_str[0] = _toupper(val_str[0]);
14837         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14838            decc_filename_unix_no_version = 1;
14839         }
14840     }
14841     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
14842     if ($VMS_STATUS_SUCCESS(status)) {
14843         val_str[0] = _toupper(val_str[0]);
14844         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14845            decc_readdir_dropdotnotype = 1;
14846         }
14847     }
14848 #endif
14849
14850 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
14851
14852      /* Report true case tolerance */
14853     /*----------------------------*/
14854     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14855     if (!$VMS_STATUS_SUCCESS(status))
14856         case_perm = PPROP$K_CASE_BLIND;
14857     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14858     if (!$VMS_STATUS_SUCCESS(status))
14859         case_image = PPROP$K_CASE_BLIND;
14860     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14861         (case_image == PPROP$K_CASE_SENSITIVE))
14862         vms_process_case_tolerant = 0;
14863
14864 #endif
14865
14866     /* USE POSIX/DCL Exit codes - Recommended, but needs to default to  */
14867     /* for strict backward compatibilty */
14868     status = sys_trnlnm
14869         ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14870     if ($VMS_STATUS_SUCCESS(status)) {
14871        val_str[0] = _toupper(val_str[0]);
14872        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14873          vms_posix_exit = 1;
14874        else
14875          vms_posix_exit = 0;
14876     }
14877
14878
14879     /* CRTL can be initialized past this point, but not before. */
14880 /*    DECC$CRTL_INIT(); */
14881
14882     return SS$_NORMAL;
14883 }
14884
14885 #ifdef __DECC
14886 #pragma nostandard
14887 #pragma extern_model save
14888 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
14889         const __align (LONGWORD) int spare[8] = {0};
14890
14891 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
14892 #if __DECC_VER >= 60560002
14893 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
14894 #else
14895 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
14896 #endif
14897 #endif /* __DECC */
14898
14899 const long vms_cc_features = (const long)set_features;
14900
14901 /*
14902 ** Force a reference to LIB$INITIALIZE to ensure it
14903 ** exists in the image.
14904 */
14905 int lib$initialize(void);
14906 #ifdef __DECC
14907 #pragma extern_model strict_refdef
14908 #endif
14909     int lib_init_ref = (int) lib$initialize;
14910
14911 #ifdef __DECC
14912 #pragma extern_model restore
14913 #pragma standard
14914 #endif
14915
14916 /*  End of vms.c */