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_tounixspec(const char *spec, char *buf, int * utf8_fl);
 306
 307 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 308 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 309
 310 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 311  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 312  * the Perl facility.
 313  */
 314 #define PERL_LNM_MAX_ITER 10
 315
 316   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 317 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 318 #define MAX_DCL_SYMBOL          (8192)
 319 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 320 #else
 321 #define MAX_DCL_SYMBOL          (1024)
 322 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 323 #endif
 324
 325 static char *__mystrtolower(char *str)
 326 {
 327   if (str) for (; *str; ++str) *str= tolower(*str);
 328   return str;
 329 }
 330
 331 static struct dsc$descriptor_s fildevdsc =
 332   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 333 static struct dsc$descriptor_s crtlenvdsc =
 334   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 335 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 336 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 337 static struct dsc$descriptor_s **env_tables = defenv;
 338 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 339
 340 /* True if we shouldn't treat barewords as logicals during directory */
 341 /* munching */
 342 static int no_translate_barewords;
 343
 344 #ifndef RTL_USES_UTC
 345 static int tz_updated = 1;
 346 #endif
 347
 348 /* DECC Features that may need to affect how Perl interprets
 349  * displays filename information
 350  */
 351 static int decc_disable_to_vms_logname_translation = 1;
 352 static int decc_disable_posix_root = 1;
 353 int decc_efs_case_preserve = 0;
 354 static int decc_efs_charset = 0;
 355 static int decc_efs_charset_index = -1;
 356 static int decc_filename_unix_no_version = 0;
 357 static int decc_filename_unix_only = 0;
 358 int decc_filename_unix_report = 0;
 359 int decc_posix_compliant_pathnames = 0;
 360 int decc_readdir_dropdotnotype = 0;
 361 static int vms_process_case_tolerant = 1;
 362 int vms_vtf7_filenames = 0;
 363 int gnv_unix_shell = 0;
 364 static int vms_unlink_all_versions = 0;
 365 static int vms_posix_exit = 0;
 366
 367 /* bug workarounds if needed */
 368 int decc_bug_devnull = 1;
 369 int decc_dir_barename = 0;
 370 int vms_bug_stat_filename = 0;
 371
 372 static int vms_debug_on_exception = 0;
 373 static int vms_debug_fileify = 0;
 374
 375 /* Simple logical name translation */
 376 static int simple_trnlnm
 377    (const char * logname,
 378     char * value,
 379     int value_len)
 380 {
 381     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
 382     const unsigned long attr = LNM$M_CASE_BLIND;
 383     struct dsc$descriptor_s name_dsc;
 384     int status;
 385     unsigned short result;
 386     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
 387                                 {0, 0, 0, 0}};
 388
 389     name_dsc.dsc$w_length = strlen(logname);
 390     name_dsc.dsc$a_pointer = (char *)logname;
 391     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
 392     name_dsc.dsc$b_class = DSC$K_CLASS_S;
 393
 394     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
 395
 396     if ($VMS_STATUS_SUCCESS(status)) {
 397
 398          /* Null terminate and return the string */
 399         /*--------------------------------------*/
 400         value[result] = 0;
 401         return result;
 402     }
 403
 404     return 0;
 405 }
 406
 407
 408 /* Is this a UNIX file specification?
 409  *   No longer a simple check with EFS file specs
 410  *   For now, not a full check, but need to
 411  *   handle POSIX ^UP^ specifications
 412  *   Fixing to handle ^/ cases would require
 413  *   changes to many other conversion routines.
 414  */
 415
 416 static int is_unix_filespec(const char *path)
 417 {
 418 int ret_val;
 419 const char * pch1;
 420
 421     ret_val = 0;
 422     if (strncmp(path,"\"^UP^",5) != 0) {
 423         pch1 = strchr(path, '/');
 424         if (pch1 != NULL)
 425             ret_val = 1;
 426         else {
 427
 428             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 429             if (decc_filename_unix_report || decc_filename_unix_only) {
 430             if (strcmp(path,".") == 0)
 431                 ret_val = 1;
 432             }
 433         }
 434     }
 435     return ret_val;
 436 }
 437
 438 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 439  */
 440
 441 static void ucs2_to_vtf7
 442    (char *outspec,
 443     unsigned long ucs2_char,
 444     int * output_cnt)
 445 {
 446 unsigned char * ucs_ptr;
 447 int hex;
 448
 449     ucs_ptr = (unsigned char *)&ucs2_char;
 450
 451     outspec[0] = '^';
 452     outspec[1] = 'U';
 453     hex = (ucs_ptr[1] >> 4) & 0xf;
 454     if (hex < 0xA)
 455         outspec[2] = hex + '0';
 456     else
 457         outspec[2] = (hex - 9) + 'A';
 458     hex = ucs_ptr[1] & 0xF;
 459     if (hex < 0xA)
 460         outspec[3] = hex + '0';
 461     else {
 462         outspec[3] = (hex - 9) + 'A';
 463     }
 464     hex = (ucs_ptr[0] >> 4) & 0xf;
 465     if (hex < 0xA)
 466         outspec[4] = hex + '0';
 467     else
 468         outspec[4] = (hex - 9) + 'A';
 469     hex = ucs_ptr[1] & 0xF;
 470     if (hex < 0xA)
 471         outspec[5] = hex + '0';
 472     else {
 473         outspec[5] = (hex - 9) + 'A';
 474     }
 475     *output_cnt = 6;
 476 }
 477
 478
 479 /* This handles the conversion of a UNIX extended character set to a ^
 480  * escaped VMS character.
 481  * in a UNIX file specification.
 482  *
 483  * The output count variable contains the number of characters added
 484  * to the output string.
 485  *
 486  * The return value is the number of characters read from the input string
 487  */
 488 static int copy_expand_unix_filename_escape
 489   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 490 {
 491 int count;
 492 int scnt;
 493 int utf8_flag;
 494
 495     utf8_flag = 0;
 496     if (utf8_fl)
 497       utf8_flag = *utf8_fl;
 498
 499     count = 0;
 500     *output_cnt = 0;
 501     if (*inspec >= 0x80) {
 502         if (utf8_fl && vms_vtf7_filenames) {
 503         unsigned long ucs_char;
 504
 505             ucs_char = 0;
 506
 507             if ((*inspec & 0xE0) == 0xC0) {
 508                 /* 2 byte Unicode */
 509                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 510                 if (ucs_char >= 0x80) {
 511                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 512                     return 2;
 513                 }
 514             } else if ((*inspec & 0xF0) == 0xE0) {
 515                 /* 3 byte Unicode */
 516                 ucs_char = ((inspec[0] & 0xF) << 12) +
 517                    ((inspec[1] & 0x3f) << 6) +
 518                    (inspec[2] & 0x3f);
 519                 if (ucs_char >= 0x800) {
 520                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 521                     return 3;
 522                 }
 523
 524 #if 0 /* I do not see longer sequences supported by OpenVMS */
 525       /* Maybe some one can fix this later */
 526             } else if ((*inspec & 0xF8) == 0xF0) {
 527                 /* 4 byte Unicode */
 528                 /* UCS-4 to UCS-2 */
 529             } else if ((*inspec & 0xFC) == 0xF8) {
 530                 /* 5 byte Unicode */
 531                 /* UCS-4 to UCS-2 */
 532             } else if ((*inspec & 0xFE) == 0xFC) {
 533                 /* 6 byte Unicode */
 534                 /* UCS-4 to UCS-2 */
 535 #endif
 536             }
 537         }
 538
 539         /* High bit set, but not a Unicode character! */
 540
 541         /* Non printing DECMCS or ISO Latin-1 character? */
 542         if (*inspec <= 0x9F) {
 543         int hex;
 544             outspec[0] = '^';
 545             outspec++;
 546             hex = (*inspec >> 4) & 0xF;
 547             if (hex < 0xA)
 548                 outspec[1] = hex + '0';
 549             else {
 550                 outspec[1] = (hex - 9) + 'A';
 551             }
 552             hex = *inspec & 0xF;
 553             if (hex < 0xA)
 554                 outspec[2] = hex + '0';
 555             else {
 556                 outspec[2] = (hex - 9) + 'A';
 557             }
 558             *output_cnt = 3;
 559             return 1;
 560         } else if (*inspec == 0xA0) {
 561             outspec[0] = '^';
 562             outspec[1] = 'A';
 563             outspec[2] = '0';
 564             *output_cnt = 3;
 565             return 1;
 566         } else if (*inspec == 0xFF) {
 567             outspec[0] = '^';
 568             outspec[1] = 'F';
 569             outspec[2] = 'F';
 570             *output_cnt = 3;
 571             return 1;
 572         }
 573         *outspec = *inspec;
 574         *output_cnt = 1;
 575         return 1;
 576     }
 577
 578     /* Is this a macro that needs to be passed through?
 579      * Macros start with $( and an alpha character, followed
 580      * by a string of alpha numeric characters ending with a )
 581      * If this does not match, then encode it as ODS-5.
 582      */
 583     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 584     int tcnt;
 585
 586         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 587             tcnt = 3;
 588             outspec[0] = inspec[0];
 589             outspec[1] = inspec[1];
 590             outspec[2] = inspec[2];
 591
 592             while(isalnum(inspec[tcnt]) ||
 593                   (inspec[2] == '.') || (inspec[2] == '_')) {
 594                 outspec[tcnt] = inspec[tcnt];
 595                 tcnt++;
 596             }
 597             if (inspec[tcnt] == ')') {
 598                 outspec[tcnt] = inspec[tcnt];
 599                 tcnt++;
 600                 *output_cnt = tcnt;
 601                 return tcnt;
 602             }
 603         }
 604     }
 605
 606     switch (*inspec) {
 607     case 0x7f:
 608         outspec[0] = '^';
 609         outspec[1] = '7';
 610         outspec[2] = 'F';
 611         *output_cnt = 3;
 612         return 1;
 613         break;
 614     case '?':
 615         if (decc_efs_charset == 0)
 616           outspec[0] = '%';
 617         else
 618           outspec[0] = '?';
 619         *output_cnt = 1;
 620         return 1;
 621         break;
 622     case '.':
 623     case '~':
 624     case '!':
 625     case '#':
 626     case '&':
 627     case '\'':
 628     case '`':
 629     case '(':
 630     case ')':
 631     case '+':
 632     case '@':
 633     case '{':
 634     case '}':
 635     case ',':
 636     case ';':
 637     case '[':
 638     case ']':
 639     case '%':
 640     case '^':
 641     case '\\':
 642         /* Don't escape again if following character is
 643          * already something we escape.
 644          */
 645         if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
 646             *outspec = *inspec;
 647             *output_cnt = 1;
 648             return 1;
 649             break;
 650         }
 651         /* But otherwise fall through and escape it. */
 652     case '=':
 653         /* Assume that this is to be escaped */
 654         outspec[0] = '^';
 655         outspec[1] = *inspec;
 656         *output_cnt = 2;
 657         return 1;
 658         break;
 659     case ' ': /* space */
 660         /* Assume that this is to be escaped */
 661         outspec[0] = '^';
 662         outspec[1] = '_';
 663         *output_cnt = 2;
 664         return 1;
 665         break;
 666     default:
 667         *outspec = *inspec;
 668         *output_cnt = 1;
 669         return 1;
 670         break;
 671     }
 672 }
 673
 674
 675 /* This handles the expansion of a '^' prefix to the proper character
 676  * in a UNIX file specification.
 677  *
 678  * The output count variable contains the number of characters added
 679  * to the output string.
 680  *
 681  * The return value is the number of characters read from the input
 682  * string
 683  */
 684 static int copy_expand_vms_filename_escape
 685   (char *outspec, const char *inspec, int *output_cnt)
 686 {
 687 int count;
 688 int scnt;
 689
 690     count = 0;
 691     *output_cnt = 0;
 692     if (*inspec == '^') {
 693         inspec++;
 694         switch (*inspec) {
 695         /* Spaces and non-trailing dots should just be passed through,
 696          * but eat the escape character.
 697          */
 698         case '.':
 699             *outspec = *inspec;
 700             count += 2;
 701             (*output_cnt)++;
 702             break;
 703         case '_': /* space */
 704             *outspec = ' ';
 705             count += 2;
 706             (*output_cnt)++;
 707             break;
 708         case '^':
 709             /* Hmm.  Better leave the escape escaped. */
 710             outspec[0] = '^';
 711             outspec[1] = '^';
 712             count += 2;
 713             (*output_cnt) += 2;
 714             break;
 715         case 'U': /* Unicode - FIX-ME this is wrong. */
 716             inspec++;
 717             count++;
 718             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 719             if (scnt == 4) {
 720                 unsigned int c1, c2;
 721                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 722                 outspec[0] == c1 & 0xff;
 723                 outspec[1] == c2 & 0xff;
 724                 if (scnt > 1) {
 725                     (*output_cnt) += 2;
 726                     count += 4;
 727                 }
 728             }
 729             else {
 730                 /* Error - do best we can to continue */
 731                 *outspec = 'U';
 732                 outspec++;
 733                 (*output_cnt++);
 734                 *outspec = *inspec;
 735                 count++;
 736                 (*output_cnt++);
 737             }
 738             break;
 739         default:
 740             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 741             if (scnt == 2) {
 742                 /* Hex encoded */
 743                 unsigned int c1;
 744                 scnt = sscanf(inspec, "%2x", &c1);
 745                 outspec[0] = c1 & 0xff;
 746                 if (scnt > 0) {
 747                     (*output_cnt++);
 748                     count += 2;
 749                 }
 750             }
 751             else {
 752                 *outspec = *inspec;
 753                 count++;
 754                 (*output_cnt++);
 755             }
 756         }
 757     }
 758     else {
 759         *outspec = *inspec;
 760         count++;
 761         (*output_cnt)++;
 762     }
 763     return count;
 764 }
 765
 766 #ifdef sys$filescan
 767 #undef sys$filescan
 768 int sys$filescan
 769    (const struct dsc$descriptor_s * srcstr,
 770     struct filescan_itmlst_2 * valuelist,
 771     unsigned long * fldflags,
 772     struct dsc$descriptor_s *auxout,
 773     unsigned short * retlen);
 774 #endif
 775
 776 /* vms_split_path - Verify that the input file specification is a
 777  * VMS format file specification, and provide pointers to the components of
 778  * it.  With EFS format filenames, this is virtually the only way to
 779  * parse a VMS path specification into components.
 780  *
 781  * If the sum of the components do not add up to the length of the
 782  * string, then the passed file specification is probably a UNIX style
 783  * path.
 784  */
 785 static int vms_split_path
 786    (const char * path,
 787     char * * volume,
 788     int * vol_len,
 789     char * * root,
 790     int * root_len,
 791     char * * dir,
 792     int * dir_len,
 793     char * * name,
 794     int * name_len,
 795     char * * ext,
 796     int * ext_len,
 797     char * * version,
 798     int * ver_len)
 799 {
 800 struct dsc$descriptor path_desc;
 801 int status;
 802 unsigned long flags;
 803 int ret_stat;
 804 struct filescan_itmlst_2 item_list[9];
 805 const int filespec = 0;
 806 const int nodespec = 1;
 807 const int devspec = 2;
 808 const int rootspec = 3;
 809 const int dirspec = 4;
 810 const int namespec = 5;
 811 const int typespec = 6;
 812 const int verspec = 7;
 813
 814     /* Assume the worst for an easy exit */
 815     ret_stat = -1;
 816     *volume = NULL;
 817     *vol_len = 0;
 818     *root = NULL;
 819     *root_len = 0;
 820     *dir = NULL;
 821     *dir_len;
 822     *name = NULL;
 823     *name_len = 0;
 824     *ext = NULL;
 825     *ext_len = 0;
 826     *version = NULL;
 827     *ver_len = 0;
 828
 829     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 830     path_desc.dsc$w_length = strlen(path);
 831     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 832     path_desc.dsc$b_class = DSC$K_CLASS_S;
 833
 834     /* Get the total length, if it is shorter than the string passed
 835      * then this was probably not a VMS formatted file specification
 836      */
 837     item_list[filespec].itmcode = FSCN$_FILESPEC;
 838     item_list[filespec].length = 0;
 839     item_list[filespec].component = NULL;
 840
 841     /* If the node is present, then it gets considered as part of the
 842      * volume name to hopefully make things simple.
 843      */
 844     item_list[nodespec].itmcode = FSCN$_NODE;
 845     item_list[nodespec].length = 0;
 846     item_list[nodespec].component = NULL;
 847
 848     item_list[devspec].itmcode = FSCN$_DEVICE;
 849     item_list[devspec].length = 0;
 850     item_list[devspec].component = NULL;
 851
 852     /* root is a special case,  adding it to either the directory or
 853      * the device components will probalby complicate things for the
 854      * callers of this routine, so leave it separate.
 855      */
 856     item_list[rootspec].itmcode = FSCN$_ROOT;
 857     item_list[rootspec].length = 0;
 858     item_list[rootspec].component = NULL;
 859
 860     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 861     item_list[dirspec].length = 0;
 862     item_list[dirspec].component = NULL;
 863
 864     item_list[namespec].itmcode = FSCN$_NAME;
 865     item_list[namespec].length = 0;
 866     item_list[namespec].component = NULL;
 867
 868     item_list[typespec].itmcode = FSCN$_TYPE;
 869     item_list[typespec].length = 0;
 870     item_list[typespec].component = NULL;
 871
 872     item_list[verspec].itmcode = FSCN$_VERSION;
 873     item_list[verspec].length = 0;
 874     item_list[verspec].component = NULL;
 875
 876     item_list[8].itmcode = 0;
 877     item_list[8].length = 0;
 878     item_list[8].component = NULL;
 879
 880     status = sys$filescan
 881        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 882         &flags, NULL, NULL);
 883     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 884
 885     /* If we parsed it successfully these two lengths should be the same */
 886     if (path_desc.dsc$w_length != item_list[filespec].length)
 887         return ret_stat;
 888
 889     /* If we got here, then it is a VMS file specification */
 890     ret_stat = 0;
 891
 892     /* set the volume name */
 893     if (item_list[nodespec].length > 0) {
 894         *volume = item_list[nodespec].component;
 895         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 896     }
 897     else {
 898         *volume = item_list[devspec].component;
 899         *vol_len = item_list[devspec].length;
 900     }
 901
 902     *root = item_list[rootspec].component;
 903     *root_len = item_list[rootspec].length;
 904
 905     *dir = item_list[dirspec].component;
 906     *dir_len = item_list[dirspec].length;
 907
 908     /* Now fun with versions and EFS file specifications
 909      * The parser can not tell the difference when a "." is a version
 910      * delimiter or a part of the file specification.
 911      */
 912     if ((decc_efs_charset) &&
 913         (item_list[verspec].length > 0) &&
 914         (item_list[verspec].component[0] == '.')) {
 915         *name = item_list[namespec].component;
 916         *name_len = item_list[namespec].length + item_list[typespec].length;
 917         *ext = item_list[verspec].component;
 918         *ext_len = item_list[verspec].length;
 919         *version = NULL;
 920         *ver_len = 0;
 921     }
 922     else {
 923         *name = item_list[namespec].component;
 924         *name_len = item_list[namespec].length;
 925         *ext = item_list[typespec].component;
 926         *ext_len = item_list[typespec].length;
 927         *version = item_list[verspec].component;
 928         *ver_len = item_list[verspec].length;
 929     }
 930     return ret_stat;
 931 }
 932
 933 /* Routine to determine if the file specification ends with .dir */
 934 static int is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len) {
 935
 936     /* e_len must be 4, and version must be <= 2 characters */
 937     if (e_len != 4 || vs_len > 2)
 938         return 0;
 939
 940     /* If a version number is present, it needs to be one */
 941     if ((vs_len == 2) && (vs_spec[1] != '1'))
 942         return 0;
 943
 944     /* Look for the DIR on the extension */
 945     if (vms_process_case_tolerant) {
 946         if ((toupper(e_spec[1]) == 'D') &&
 947             (toupper(e_spec[2]) == 'I') &&
 948             (toupper(e_spec[3]) == 'R')) {
 949             return 1;
 950         }
 951     } else {
 952         /* Directory extensions are supposed to be in upper case only */
 953         /* I would not be surprised if this rule can not be enforced */
 954         /* if and when someone fully debugs the case sensitive mode */
 955         if ((e_spec[1] == 'D') &&
 956             (e_spec[2] == 'I') &&
 957             (e_spec[3] == 'R')) {
 958             return 1;
 959         }
 960     }
 961     return 0;
 962 }
 963
 964
 965 /* my_maxidx
 966  * Routine to retrieve the maximum equivalence index for an input
 967  * logical name.  Some calls to this routine have no knowledge if
 968  * the variable is a logical or not.  So on error we return a max
 969  * index of zero.
 970  */
 971 /*{{{int my_maxidx(const char *lnm) */
 972 static int
 973 my_maxidx(const char *lnm)
 974 {
 975     int status;
 976     int midx;
 977     int attr = LNM$M_CASE_BLIND;
 978     struct dsc$descriptor lnmdsc;
 979     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 980                                 {0, 0, 0, 0}};
 981
 982     lnmdsc.dsc$w_length = strlen(lnm);
 983     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 984     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 985     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 986
 987     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 988     if ((status & 1) == 0)
 989        midx = 0;
 990
 991     return (midx);
 992 }
 993 /*}}}*/
 994
 995 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 996 int
 997 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 998   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 999 {
1000     const char *cp1;
1001     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
1002     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
1003     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
1004     int midx;
1005     unsigned char acmode;
1006     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1007                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1008     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
1009                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
1010                                  {0, 0, 0, 0}};
1011     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1012 #if defined(PERL_IMPLICIT_CONTEXT)
1013     pTHX = NULL;
1014     if (PL_curinterp) {
1015       aTHX = PERL_GET_INTERP;
1016     } else {
1017       aTHX = NULL;
1018     }
1019 #endif
1020
1021     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
1022       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
1023     }
1024     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1025       *cp2 = _toupper(*cp1);
1026       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1027         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1028         return 0;
1029       }
1030     }
1031     lnmdsc.dsc$w_length = cp1 - lnm;
1032     lnmdsc.dsc$a_pointer = uplnm;
1033     uplnm[lnmdsc.dsc$w_length] = '\0';
1034     secure = flags & PERL__TRNENV_SECURE;
1035     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
1036     if (!tabvec || !*tabvec) tabvec = env_tables;
1037
1038     for (curtab = 0; tabvec[curtab]; curtab++) {
1039       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1040         if (!ivenv && !secure) {
1041           char *eq, *end;
1042           int i;
1043           if (!environ) {
1044             ivenv = 1;
1045 #if defined(PERL_IMPLICIT_CONTEXT)
1046             if (aTHX == NULL) {
1047                 fprintf(stderr,
1048                     "%%PERL-W-VMS_INIT Can't read CRTL environ\n");
1049             } else
1050 #endif
1051                 Perl_warn(aTHX_ "Can't read CRTL environ\n");
1052             continue;
1053           }
1054           retsts = SS$_NOLOGNAM;
1055           for (i = 0; environ[i]; i++) {
1056             if ((eq = strchr(environ[i],'=')) &&
1057                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
1058                 !strncmp(environ[i],uplnm,eq - environ[i])) {
1059               eq++;
1060               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
1061               if (!eqvlen) continue;
1062               retsts = SS$_NORMAL;
1063               break;
1064             }
1065           }
1066           if (retsts != SS$_NOLOGNAM) break;
1067         }
1068       }
1069       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1070                !str$case_blind_compare(&tmpdsc,&clisym)) {
1071         if (!ivsym && !secure) {
1072           unsigned short int deflen = LNM$C_NAMLENGTH;
1073           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1074           /* dynamic dsc to accomodate possible long value */
1075           _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
1076           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
1077           if (retsts & 1) {
1078             if (eqvlen > MAX_DCL_SYMBOL) {
1079               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
1080               eqvlen = MAX_DCL_SYMBOL;
1081               /* Special hack--we might be called before the interpreter's */
1082               /* fully initialized, in which case either thr or PL_curcop */
1083               /* might be bogus. We have to check, since ckWARN needs them */
1084               /* both to be valid if running threaded */
1085 #if defined(PERL_IMPLICIT_CONTEXT)
1086               if (aTHX == NULL) {
1087                   fprintf(stderr,
1088                      "%Perl-VMS-Init, Value of CLI symbol \"%s\" too long",lnm);
1089               } else
1090 #endif
1091                 if (ckWARN(WARN_MISC)) {
1092                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
1093                 }
1094             }
1095             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
1096           }
1097           _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
1098           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1099           if (retsts == LIB$_NOSUCHSYM) continue;
1100           break;
1101         }
1102       }
1103       else if (!ivlnm) {
1104         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
1105           midx = my_maxidx(lnm);
1106           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1107             lnmlst[1].bufadr = cp2;
1108             eqvlen = 0;
1109             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1110             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1111             if (retsts == SS$_NOLOGNAM) break;
1112             /* PPFs have a prefix */
1113             if (
1114 #if INTSIZE == 4
1115                  *((int *)uplnm) == *((int *)"SYS$")                    &&
1116 #endif
1117                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
1118                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
1119                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
1120                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
1121                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
1122               memmove(eqv,eqv+4,eqvlen-4);
1123               eqvlen -= 4;
1124             }
1125             cp2 += eqvlen;
1126             *cp2 = '\0';
1127           }
1128           if ((retsts == SS$_IVLOGNAM) ||
1129               (retsts == SS$_NOLOGNAM)) { continue; }
1130         }
1131         else {
1132           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1133           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1134           if (retsts == SS$_NOLOGNAM) continue;
1135           eqv[eqvlen] = '\0';
1136         }
1137         eqvlen = strlen(eqv);
1138         break;
1139       }
1140     }
1141     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1142     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1143              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
1144              retsts == SS$_NOLOGNAM) {
1145       set_errno(EINVAL);  set_vaxc_errno(retsts);
1146     }
1147     else _ckvmssts_noperl(retsts);
1148     return 0;
1149 }  /* end of vmstrnenv */
1150 /*}}}*/
1151
1152 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1153 /* Define as a function so we can access statics. */
1154 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1155 {
1156     int flags = 0;
1157
1158 #if defined(PERL_IMPLICIT_CONTEXT)
1159     if (aTHX != NULL)
1160 #endif
1161 #ifdef SECURE_INTERNAL_GETENV
1162         flags = (PL_curinterp ? PL_tainting : will_taint) ?
1163                  PERL__TRNENV_SECURE : 0;
1164 #endif
1165
1166     return vmstrnenv(lnm, eqv, idx, fildev, flags);
1167 }
1168 /*}}}*/
1169
1170 /* my_getenv
1171  * Note: Uses Perl temp to store result so char * can be returned to
1172  * caller; this pointer will be invalidated at next Perl statement
1173  * transition.
1174  * We define this as a function rather than a macro in terms of my_getenv_len()
1175  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1176  * allocate SVs).
1177  */
1178 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1179 char *
1180 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1181 {
1182     const char *cp1;
1183     static char *__my_getenv_eqv = NULL;
1184     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1185     unsigned long int idx = 0;
1186     int trnsuccess, success, secure, saverr, savvmserr;
1187     int midx, flags;
1188     SV *tmpsv;
1189
1190     midx = my_maxidx(lnm) + 1;
1191
1192     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1193       /* Set up a temporary buffer for the return value; Perl will
1194        * clean it up at the next statement transition */
1195       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1196       if (!tmpsv) return NULL;
1197       eqv = SvPVX(tmpsv);
1198     }
1199     else {
1200       /* Assume no interpreter ==> single thread */
1201       if (__my_getenv_eqv != NULL) {
1202         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1203       }
1204       else {
1205         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1206       }
1207       eqv = __my_getenv_eqv;
1208     }
1209
1210     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1211     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1212       int len;
1213       getcwd(eqv,LNM$C_NAMLENGTH);
1214
1215       len = strlen(eqv);
1216
1217       /* Get rid of "000000/ in rooted filespecs */
1218       if (len > 7) {
1219         char * zeros;
1220         zeros = strstr(eqv, "/000000/");
1221         if (zeros != NULL) {
1222           int mlen;
1223           mlen = len - (zeros - eqv) - 7;
1224           memmove(zeros, &zeros[7], mlen);
1225           len = len - 7;
1226           eqv[len] = '\0';
1227         }
1228       }
1229       return eqv;
1230     }
1231     else {
1232       /* Impose security constraints only if tainting */
1233       if (sys) {
1234         /* Impose security constraints only if tainting */
1235         secure = PL_curinterp ? PL_tainting : will_taint;
1236         saverr = errno;  savvmserr = vaxc$errno;
1237       }
1238       else {
1239         secure = 0;
1240       }
1241
1242       flags =
1243 #ifdef SECURE_INTERNAL_GETENV
1244               secure ? PERL__TRNENV_SECURE : 0
1245 #else
1246               0
1247 #endif
1248       ;
1249
1250       /* For the getenv interface we combine all the equivalence names
1251        * of a search list logical into one value to acquire a maximum
1252        * value length of 255*128 (assuming %ENV is using logicals).
1253        */
1254       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1255
1256       /* If the name contains a semicolon-delimited index, parse it
1257        * off and make sure we only retrieve the equivalence name for
1258        * that index.  */
1259       if ((cp2 = strchr(lnm,';')) != NULL) {
1260         strcpy(uplnm,lnm);
1261         uplnm[cp2-lnm] = '\0';
1262         idx = strtoul(cp2+1,NULL,0);
1263         lnm = uplnm;
1264         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1265       }
1266
1267       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1268
1269       /* Discard NOLOGNAM on internal calls since we're often looking
1270        * for an optional name, and this "error" often shows up as the
1271        * (bogus) exit status for a die() call later on.  */
1272       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1273       return success ? eqv : NULL;
1274     }
1275
1276 }  /* end of my_getenv() */
1277 /*}}}*/
1278
1279
1280 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1281 char *
1282 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1283 {
1284     const char *cp1;
1285     char *buf, *cp2;
1286     unsigned long idx = 0;
1287     int midx, flags;
1288     static char *__my_getenv_len_eqv = NULL;
1289     int secure, saverr, savvmserr;
1290     SV *tmpsv;
1291
1292     midx = my_maxidx(lnm) + 1;
1293
1294     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1295       /* Set up a temporary buffer for the return value; Perl will
1296        * clean it up at the next statement transition */
1297       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1298       if (!tmpsv) return NULL;
1299       buf = SvPVX(tmpsv);
1300     }
1301     else {
1302       /* Assume no interpreter ==> single thread */
1303       if (__my_getenv_len_eqv != NULL) {
1304         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1305       }
1306       else {
1307         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1308       }
1309       buf = __my_getenv_len_eqv;
1310     }
1311
1312     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1313     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1314     char * zeros;
1315
1316       getcwd(buf,LNM$C_NAMLENGTH);
1317       *len = strlen(buf);
1318
1319       /* Get rid of "000000/ in rooted filespecs */
1320       if (*len > 7) {
1321       zeros = strstr(buf, "/000000/");
1322       if (zeros != NULL) {
1323         int mlen;
1324         mlen = *len - (zeros - buf) - 7;
1325         memmove(zeros, &zeros[7], mlen);
1326         *len = *len - 7;
1327         buf[*len] = '\0';
1328         }
1329       }
1330       return buf;
1331     }
1332     else {
1333       if (sys) {
1334         /* Impose security constraints only if tainting */
1335         secure = PL_curinterp ? PL_tainting : will_taint;
1336         saverr = errno;  savvmserr = vaxc$errno;
1337       }
1338       else {
1339         secure = 0;
1340       }
1341
1342       flags =
1343 #ifdef SECURE_INTERNAL_GETENV
1344               secure ? PERL__TRNENV_SECURE : 0
1345 #else
1346               0
1347 #endif
1348       ;
1349
1350       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1351
1352       if ((cp2 = strchr(lnm,';')) != NULL) {
1353         strcpy(buf,lnm);
1354         buf[cp2-lnm] = '\0';
1355         idx = strtoul(cp2+1,NULL,0);
1356         lnm = buf;
1357         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1358       }
1359
1360       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1361
1362       /* Get rid of "000000/ in rooted filespecs */
1363       if (*len > 7) {
1364       char * zeros;
1365         zeros = strstr(buf, "/000000/");
1366         if (zeros != NULL) {
1367           int mlen;
1368           mlen = *len - (zeros - buf) - 7;
1369           memmove(zeros, &zeros[7], mlen);
1370           *len = *len - 7;
1371           buf[*len] = '\0';
1372         }
1373       }
1374
1375       /* Discard NOLOGNAM on internal calls since we're often looking
1376        * for an optional name, and this "error" often shows up as the
1377        * (bogus) exit status for a die() call later on.  */
1378       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1379       return *len ? buf : NULL;
1380     }
1381
1382 }  /* end of my_getenv_len() */
1383 /*}}}*/
1384
1385 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
1386
1387 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1388
1389 /*{{{ void prime_env_iter() */
1390 void
1391 prime_env_iter(void)
1392 /* Fill the %ENV associative array with all logical names we can
1393  * find, in preparation for iterating over it.
1394  */
1395 {
1396   static int primed = 0;
1397   HV *seenhv = NULL, *envhv;
1398   SV *sv = NULL;
1399   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1400   unsigned short int chan;
1401 #ifndef CLI$M_TRUSTED
1402 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1403 #endif
1404   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1405   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1406   long int i;
1407   bool have_sym = FALSE, have_lnm = FALSE;
1408   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1409   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1410   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1411   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1412   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1413 #if defined(PERL_IMPLICIT_CONTEXT)
1414   pTHX;
1415 #endif
1416 #if defined(USE_ITHREADS)
1417   static perl_mutex primenv_mutex;
1418   MUTEX_INIT(&primenv_mutex);
1419 #endif
1420
1421 #if defined(PERL_IMPLICIT_CONTEXT)
1422     /* We jump through these hoops because we can be called at */
1423     /* platform-specific initialization time, which is before anything is */
1424     /* set up--we can't even do a plain dTHX since that relies on the */
1425     /* interpreter structure to be initialized */
1426     if (PL_curinterp) {
1427       aTHX = PERL_GET_INTERP;
1428     } else {
1429       /* we never get here because the NULL pointer will cause the */
1430       /* several of the routines called by this routine to access violate */
1431
1432       /* This routine is only called by hv.c/hv_iterinit which has a */
1433       /* context, so the real fix may be to pass it through instead of */
1434       /* the hoops above */
1435       aTHX = NULL;
1436     }
1437 #endif
1438
1439   if (primed || !PL_envgv) return;
1440   MUTEX_LOCK(&primenv_mutex);
1441   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1442   envhv = GvHVn(PL_envgv);
1443   /* Perform a dummy fetch as an lval to insure that the hash table is
1444    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1445   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1446
1447   for (i = 0; env_tables[i]; i++) {
1448      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1449          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1450      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1451   }
1452   if (have_sym || have_lnm) {
1453     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1454     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1455     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1456     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1457   }
1458
1459   for (i--; i >= 0; i--) {
1460     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1461       char *start;
1462       int j;
1463       for (j = 0; environ[j]; j++) {
1464         if (!(start = strchr(environ[j],'='))) {
1465           if (ckWARN(WARN_INTERNAL))
1466             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1467         }
1468         else {
1469           start++;
1470           sv = newSVpv(start,0);
1471           SvTAINTED_on(sv);
1472           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1473         }
1474       }
1475       continue;
1476     }
1477     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1478              !str$case_blind_compare(&tmpdsc,&clisym)) {
1479       strcpy(cmd,"Show Symbol/Global *");
1480       cmddsc.dsc$w_length = 20;
1481       if (env_tables[i]->dsc$w_length == 12 &&
1482           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1483           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1484       flags = defflags | CLI$M_NOLOGNAM;
1485     }
1486     else {
1487       strcpy(cmd,"Show Logical *");
1488       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1489         strcat(cmd," /Table=");
1490         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1491         cmddsc.dsc$w_length = strlen(cmd);
1492       }
1493       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1494       flags = defflags | CLI$M_NOCLISYM;
1495     }
1496
1497     /* Create a new subprocess to execute each command, to exclude the
1498      * remote possibility that someone could subvert a mbx or file used
1499      * to write multiple commands to a single subprocess.
1500      */
1501     do {
1502       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1503                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1504       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1505       defflags &= ~CLI$M_TRUSTED;
1506     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1507     _ckvmssts(retsts);
1508     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1509     if (seenhv) SvREFCNT_dec(seenhv);
1510     seenhv = newHV();
1511     while (1) {
1512       char *cp1, *cp2, *key;
1513       unsigned long int sts, iosb[2], retlen, keylen;
1514       register U32 hash;
1515
1516       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1517       if (sts & 1) sts = iosb[0] & 0xffff;
1518       if (sts == SS$_ENDOFFILE) {
1519         int wakect = 0;
1520         while (substs == 0) { sys$hiber(); wakect++;}
1521         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1522         _ckvmssts(substs);
1523         break;
1524       }
1525       _ckvmssts(sts);
1526       retlen = iosb[0] >> 16;
1527       if (!retlen) continue;  /* blank line */
1528       buf[retlen] = '\0';
1529       if (iosb[1] != subpid) {
1530         if (iosb[1]) {
1531           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1532         }
1533         continue;
1534       }
1535       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1536         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1537
1538       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1539       if (*cp1 == '(' || /* Logical name table name */
1540           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1541       if (*cp1 == '"') cp1++;
1542       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1543       key = cp1;  keylen = cp2 - cp1;
1544       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1545       while (*cp2 && *cp2 != '=') cp2++;
1546       while (*cp2 && *cp2 == '=') cp2++;
1547       while (*cp2 && *cp2 == ' ') cp2++;
1548       if (*cp2 == '"') {  /* String translation; may embed "" */
1549         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1550         cp2++;  cp1--; /* Skip "" surrounding translation */
1551       }
1552       else {  /* Numeric translation */
1553         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1554         cp1--;  /* stop on last non-space char */
1555       }
1556       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1557         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1558         continue;
1559       }
1560       PERL_HASH(hash,key,keylen);
1561
1562       if (cp1 == cp2 && *cp2 == '.') {
1563         /* A single dot usually means an unprintable character, such as a null
1564          * to indicate a zero-length value.  Get the actual value to make sure.
1565          */
1566         char lnm[LNM$C_NAMLENGTH+1];
1567         char eqv[MAX_DCL_SYMBOL+1];
1568         int trnlen;
1569         strncpy(lnm, key, keylen);
1570         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1571         sv = newSVpvn(eqv, strlen(eqv));
1572       }
1573       else {
1574         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1575       }
1576
1577       SvTAINTED_on(sv);
1578       hv_store(envhv,key,keylen,sv,hash);
1579       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1580     }
1581     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1582       /* get the PPFs for this process, not the subprocess */
1583       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1584       char eqv[LNM$C_NAMLENGTH+1];
1585       int trnlen, i;
1586       for (i = 0; ppfs[i]; i++) {
1587         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1588         sv = newSVpv(eqv,trnlen);
1589         SvTAINTED_on(sv);
1590         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1591       }
1592     }
1593   }
1594   primed = 1;
1595   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1596   if (buf) Safefree(buf);
1597   if (seenhv) SvREFCNT_dec(seenhv);
1598   MUTEX_UNLOCK(&primenv_mutex);
1599   return;
1600
1601 }  /* end of prime_env_iter */
1602 /*}}}*/
1603
1604
1605 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1606 /* Define or delete an element in the same "environment" as
1607  * vmstrnenv().  If an element is to be deleted, it's removed from
1608  * the first place it's found.  If it's to be set, it's set in the
1609  * place designated by the first element of the table vector.
1610  * Like setenv() returns 0 for success, non-zero on error.
1611  */
1612 int
1613 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1614 {
1615     const char *cp1;
1616     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1617     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1618     int nseg = 0, j;
1619     unsigned long int retsts, usermode = PSL$C_USER;
1620     struct itmlst_3 *ile, *ilist;
1621     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1622                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1623                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1624     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1625     $DESCRIPTOR(local,"_LOCAL");
1626
1627     if (!lnm) {
1628         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1629         return SS$_IVLOGNAM;
1630     }
1631
1632     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1633       *cp2 = _toupper(*cp1);
1634       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1635         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1636         return SS$_IVLOGNAM;
1637       }
1638     }
1639     lnmdsc.dsc$w_length = cp1 - lnm;
1640     if (!tabvec || !*tabvec) tabvec = env_tables;
1641
1642     if (!eqv) {  /* we're deleting n element */
1643       for (curtab = 0; tabvec[curtab]; curtab++) {
1644         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1645         int i;
1646           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1647             if ((cp1 = strchr(environ[i],'=')) &&
1648                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1649                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1650 #ifdef HAS_SETENV
1651               return setenv(lnm,"",1) ? vaxc$errno : 0;
1652             }
1653           }
1654           ivenv = 1; retsts = SS$_NOLOGNAM;
1655 #else
1656               if (ckWARN(WARN_INTERNAL))
1657                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1658               ivenv = 1; retsts = SS$_NOSUCHPGM;
1659               break;
1660             }
1661           }
1662 #endif
1663         }
1664         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1665                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1666           unsigned int symtype;
1667           if (tabvec[curtab]->dsc$w_length == 12 &&
1668               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1669               !str$case_blind_compare(&tmpdsc,&local))
1670             symtype = LIB$K_CLI_LOCAL_SYM;
1671           else symtype = LIB$K_CLI_GLOBAL_SYM;
1672           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1673           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1674           if (retsts == LIB$_NOSUCHSYM) continue;
1675           break;
1676         }
1677         else if (!ivlnm) {
1678           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1679           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1680           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1681           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1682           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1683         }
1684       }
1685     }
1686     else {  /* we're defining a value */
1687       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1688 #ifdef HAS_SETENV
1689         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1690 #else
1691         if (ckWARN(WARN_INTERNAL))
1692           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1693         retsts = SS$_NOSUCHPGM;
1694 #endif
1695       }
1696       else {
1697         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1698         eqvdsc.dsc$w_length  = strlen(eqv);
1699         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1700             !str$case_blind_compare(&tmpdsc,&clisym)) {
1701           unsigned int symtype;
1702           if (tabvec[0]->dsc$w_length == 12 &&
1703               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1704                !str$case_blind_compare(&tmpdsc,&local))
1705             symtype = LIB$K_CLI_LOCAL_SYM;
1706           else symtype = LIB$K_CLI_GLOBAL_SYM;
1707           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1708         }
1709         else {
1710           if (!*eqv) eqvdsc.dsc$w_length = 1;
1711           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1712
1713             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1714             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1715               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1716                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1717               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1718               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1719             }
1720
1721             Newx(ilist,nseg+1,struct itmlst_3);
1722             ile = ilist;
1723             if (!ile) {
1724               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1725               return SS$_INSFMEM;
1726             }
1727             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1728
1729             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1730               ile->itmcode = LNM$_STRING;
1731               ile->bufadr = c;
1732               if ((j+1) == nseg) {
1733                 ile->buflen = strlen(c);
1734                 /* in case we are truncating one that's too long */
1735                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1736               }
1737               else {
1738                 ile->buflen = LNM$C_NAMLENGTH;
1739               }
1740             }
1741
1742             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1743             Safefree (ilist);
1744           }
1745           else {
1746             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1747           }
1748         }
1749       }
1750     }
1751     if (!(retsts & 1)) {
1752       switch (retsts) {
1753         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1754         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1755           set_errno(EVMSERR); break;
1756         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1757         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1758           set_errno(EINVAL); break;
1759         case SS$_NOPRIV:
1760           set_errno(EACCES); break;
1761         default:
1762           _ckvmssts(retsts);
1763           set_errno(EVMSERR);
1764        }
1765        set_vaxc_errno(retsts);
1766        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1767     }
1768     else {
1769       /* We reset error values on success because Perl does an hv_fetch()
1770        * before each hv_store(), and if the thing we're setting didn't
1771        * previously exist, we've got a leftover error message.  (Of course,
1772        * this fails in the face of
1773        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1774        * in that the error reported in $! isn't spurious,
1775        * but it's right more often than not.)
1776        */
1777       set_errno(0); set_vaxc_errno(retsts);
1778       return 0;
1779     }
1780
1781 }  /* end of vmssetenv() */
1782 /*}}}*/
1783
1784 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1785 /* This has to be a function since there's a prototype for it in proto.h */
1786 void
1787 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1788 {
1789     if (lnm && *lnm) {
1790       int len = strlen(lnm);
1791       if  (len == 7) {
1792         char uplnm[8];
1793         int i;
1794         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1795         if (!strcmp(uplnm,"DEFAULT")) {
1796           if (eqv && *eqv) my_chdir(eqv);
1797           return;
1798         }
1799     }
1800 #ifndef RTL_USES_UTC
1801     if (len == 6 || len == 2) {
1802       char uplnm[7];
1803       int i;
1804       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1805       uplnm[len] = '\0';
1806       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1807       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1808     }
1809 #endif
1810   }
1811   (void) vmssetenv(lnm,eqv,NULL);
1812 }
1813 /*}}}*/
1814
1815 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1816 /*  vmssetuserlnm
1817  *  sets a user-mode logical in the process logical name table
1818  *  used for redirection of sys$error
1819  */
1820 void
1821 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1822 {
1823     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1824     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1825     unsigned long int iss, attr = LNM$M_CONFINE;
1826     unsigned char acmode = PSL$C_USER;
1827     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1828                                  {0, 0, 0, 0}};
1829     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1830     d_name.dsc$w_length = strlen(name);
1831
1832     lnmlst[0].buflen = strlen(eqv);
1833     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1834
1835     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1836     if (!(iss&1)) lib$signal(iss);
1837 }
1838 /*}}}*/
1839
1840
1841 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1842 /* my_crypt - VMS password hashing
1843  * my_crypt() provides an interface compatible with the Unix crypt()
1844  * C library function, and uses sys$hash_password() to perform VMS
1845  * password hashing.  The quadword hashed password value is returned
1846  * as a NUL-terminated 8 character string.  my_crypt() does not change
1847  * the case of its string arguments; in order to match the behavior
1848  * of LOGINOUT et al., alphabetic characters in both arguments must
1849  *  be upcased by the caller.
1850  *
1851  * - fix me to call ACM services when available
1852  */
1853 char *
1854 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1855 {
1856 #   ifndef UAI$C_PREFERRED_ALGORITHM
1857 #     define UAI$C_PREFERRED_ALGORITHM 127
1858 #   endif
1859     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1860     unsigned short int salt = 0;
1861     unsigned long int sts;
1862     struct const_dsc {
1863         unsigned short int dsc$w_length;
1864         unsigned char      dsc$b_type;
1865         unsigned char      dsc$b_class;
1866         const char *       dsc$a_pointer;
1867     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1868        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1869     struct itmlst_3 uailst[3] = {
1870         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1871         { sizeof salt, UAI$_SALT,    &salt, 0},
1872         { 0,           0,            NULL,  NULL}};
1873     static char hash[9];
1874
1875     usrdsc.dsc$w_length = strlen(usrname);
1876     usrdsc.dsc$a_pointer = usrname;
1877     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1878       switch (sts) {
1879         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1880           set_errno(EACCES);
1881           break;
1882         case RMS$_RNF:
1883           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1884           break;
1885         default:
1886           set_errno(EVMSERR);
1887       }
1888       set_vaxc_errno(sts);
1889       if (sts != RMS$_RNF) return NULL;
1890     }
1891
1892     txtdsc.dsc$w_length = strlen(textpasswd);
1893     txtdsc.dsc$a_pointer = textpasswd;
1894     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1895       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1896     }
1897
1898     return (char *) hash;
1899
1900 }  /* end of my_crypt() */
1901 /*}}}*/
1902
1903
1904 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1905 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1906 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1907
1908 /* fixup barenames that are directories for internal use.
1909  * There have been problems with the consistent handling of UNIX
1910  * style directory names when routines are presented with a name that
1911  * has no directory delimitors at all.  So this routine will eventually
1912  * fix the issue.
1913  */
1914 static char * fixup_bare_dirnames(const char * name)
1915 {
1916   if (decc_disable_to_vms_logname_translation) {
1917 /* fix me */
1918   }
1919   return NULL;
1920 }
1921
1922 /* 8.3, remove() is now broken on symbolic links */
1923 static int rms_erase(const char * vmsname);
1924
1925
1926 /* mp_do_kill_file
1927  * A little hack to get around a bug in some implemenation of remove()
1928  * that do not know how to delete a directory
1929  *
1930  * Delete any file to which user has control access, regardless of whether
1931  * delete access is explicitly allowed.
1932  * Limitations: User must have write access to parent directory.
1933  *              Does not block signals or ASTs; if interrupted in midstream
1934  *              may leave file with an altered ACL.
1935  * HANDLE WITH CARE!
1936  */
1937 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1938 static int
1939 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1940 {
1941     char *vmsname;
1942     char *rslt;
1943     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1944     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1945     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1946     struct myacedef {
1947       unsigned char myace$b_length;
1948       unsigned char myace$b_type;
1949       unsigned short int myace$w_flags;
1950       unsigned long int myace$l_access;
1951       unsigned long int myace$l_ident;
1952     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1953                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1954       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1955      struct itmlst_3
1956        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1957                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1958        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1959        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1960        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1961        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1962
1963     /* Expand the input spec using RMS, since the CRTL remove() and
1964      * system services won't do this by themselves, so we may miss
1965      * a file "hiding" behind a logical name or search list. */
1966     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1967     if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1968
1969     rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
1970     if (rslt == NULL) {
1971         PerlMem_free(vmsname);
1972         return -1;
1973       }
1974
1975     /* Erase the file */
1976     rmsts = rms_erase(vmsname);
1977
1978     /* Did it succeed */
1979     if ($VMS_STATUS_SUCCESS(rmsts)) {
1980         PerlMem_free(vmsname);
1981         return 0;
1982       }
1983
1984     /* If not, can changing protections help? */
1985     if (rmsts != RMS$_PRV) {
1986       set_vaxc_errno(rmsts);
1987       PerlMem_free(vmsname);
1988       return -1;
1989     }
1990
1991     /* No, so we get our own UIC to use as a rights identifier,
1992      * and the insert an ACE at the head of the ACL which allows us
1993      * to delete the file.
1994      */
1995     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1996     fildsc.dsc$w_length = strlen(vmsname);
1997     fildsc.dsc$a_pointer = vmsname;
1998     cxt = 0;
1999     newace.myace$l_ident = oldace.myace$l_ident;
2000     rmsts = -1;
2001     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
2002       switch (aclsts) {
2003         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
2004           set_errno(ENOENT); break;
2005         case RMS$_DIR:
2006           set_errno(ENOTDIR); break;
2007         case RMS$_DEV:
2008           set_errno(ENODEV); break;
2009         case RMS$_SYN: case SS$_INVFILFOROP:
2010           set_errno(EINVAL); break;
2011         case RMS$_PRV:
2012           set_errno(EACCES); break;
2013         default:
2014           _ckvmssts_noperl(aclsts);
2015       }
2016       set_vaxc_errno(aclsts);
2017       PerlMem_free(vmsname);
2018       return -1;
2019     }
2020     /* Grab any existing ACEs with this identifier in case we fail */
2021     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
2022     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
2023                     || fndsts == SS$_NOMOREACE ) {
2024       /* Add the new ACE . . . */
2025       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
2026         goto yourroom;
2027
2028       rmsts = rms_erase(vmsname);
2029       if ($VMS_STATUS_SUCCESS(rmsts)) {
2030         rmsts = 0;
2031         }
2032         else {
2033         rmsts = -1;
2034         /* We blew it - dir with files in it, no write priv for
2035          * parent directory, etc.  Put things back the way they were. */
2036         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
2037           goto yourroom;
2038         if (fndsts & 1) {
2039           addlst[0].bufadr = &oldace;
2040           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2041             goto yourroom;
2042         }
2043       }
2044     }
2045
2046     yourroom:
2047     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2048     /* We just deleted it, so of course it's not there.  Some versions of
2049      * VMS seem to return success on the unlock operation anyhow (after all
2050      * the unlock is successful), but others don't.
2051      */
2052     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2053     if (aclsts & 1) aclsts = fndsts;
2054     if (!(aclsts & 1)) {
2055       set_errno(EVMSERR);
2056       set_vaxc_errno(aclsts);
2057     }
2058
2059     PerlMem_free(vmsname);
2060     return rmsts;
2061
2062 }  /* end of kill_file() */
2063 /*}}}*/
2064
2065
2066 /*{{{int do_rmdir(char *name)*/
2067 int
2068 Perl_do_rmdir(pTHX_ const char *name)
2069 {
2070     char * dirfile;
2071     int retval;
2072     Stat_t st;
2073
2074     dirfile = PerlMem_malloc(VMS_MAXRSS + 1);
2075     if (dirfile == NULL)
2076         _ckvmssts(SS$_INSFMEM);
2077
2078     /* Force to a directory specification */
2079     if (do_fileify_dirspec(name, dirfile, 0, NULL) == NULL) {
2080         PerlMem_free(dirfile);
2081         return -1;
2082     }
2083     if (Perl_flex_lstat(aTHX_ dirfile, &st) || !S_ISDIR(st.st_mode)) {
2084         errno = ENOTDIR;
2085         retval = -1;
2086     }
2087     else
2088         retval = mp_do_kill_file(aTHX_ dirfile, 1);
2089
2090     PerlMem_free(dirfile);
2091     return retval;
2092
2093 }  /* end of do_rmdir */
2094 /*}}}*/
2095
2096 /* kill_file
2097  * Delete any file to which user has control access, regardless of whether
2098  * delete access is explicitly allowed.
2099  * Limitations: User must have write access to parent directory.
2100  *              Does not block signals or ASTs; if interrupted in midstream
2101  *              may leave file with an altered ACL.
2102  * HANDLE WITH CARE!
2103  */
2104 /*{{{int kill_file(char *name)*/
2105 int
2106 Perl_kill_file(pTHX_ const char *name)
2107 {
2108     char rspec[NAM$C_MAXRSS+1];
2109     char *tspec;
2110     Stat_t st;
2111     int rmsts;
2112
2113    /* Remove() is allowed to delete directories, according to the X/Open
2114     * specifications.
2115     * This may need special handling to work with the ACL hacks.
2116      */
2117    if ((flex_lstat(name, &st) == 0) && S_ISDIR(st.st_mode)) {
2118         rmsts = Perl_do_rmdir(aTHX_ name);
2119         return rmsts;
2120     }
2121
2122    rmsts = mp_do_kill_file(aTHX_ name, 0);
2123
2124     return rmsts;
2125
2126 }  /* end of kill_file() */
2127 /*}}}*/
2128
2129
2130 /*{{{int my_mkdir(char *,Mode_t)*/
2131 int
2132 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2133 {
2134   STRLEN dirlen = strlen(dir);
2135
2136   /* zero length string sometimes gives ACCVIO */
2137   if (dirlen == 0) return -1;
2138
2139   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2140    * null file name/type.  However, it's commonplace under Unix,
2141    * so we'll allow it for a gain in portability.
2142    */
2143   if (dir[dirlen-1] == '/') {
2144     char *newdir = savepvn(dir,dirlen-1);
2145     int ret = mkdir(newdir,mode);
2146     Safefree(newdir);
2147     return ret;
2148   }
2149   else return mkdir(dir,mode);
2150 }  /* end of my_mkdir */
2151 /*}}}*/
2152
2153 /*{{{int my_chdir(char *)*/
2154 int
2155 Perl_my_chdir(pTHX_ const char *dir)
2156 {
2157   STRLEN dirlen = strlen(dir);
2158
2159   /* zero length string sometimes gives ACCVIO */
2160   if (dirlen == 0) return -1;
2161   const char *dir1;
2162
2163   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2164    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2165    * so that existing scripts do not need to be changed.
2166    */
2167   dir1 = dir;
2168   while ((dirlen > 0) && (*dir1 == ' ')) {
2169     dir1++;
2170     dirlen--;
2171   }
2172
2173   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2174    * that implies
2175    * null file name/type.  However, it's commonplace under Unix,
2176    * so we'll allow it for a gain in portability.
2177    *
2178    * - Preview- '/' will be valid soon on VMS
2179    */
2180   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2181     char *newdir = savepvn(dir1,dirlen-1);
2182     int ret = chdir(newdir);
2183     Safefree(newdir);
2184     return ret;
2185   }
2186   else return chdir(dir1);
2187 }  /* end of my_chdir */
2188 /*}}}*/
2189
2190
2191 /*{{{int my_chmod(char *, mode_t)*/
2192 int
2193 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2194 {
2195   STRLEN speclen = strlen(file_spec);
2196
2197   /* zero length string sometimes gives ACCVIO */
2198   if (speclen == 0) return -1;
2199
2200   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2201    * that implies null file name/type.  However, it's commonplace under Unix,
2202    * so we'll allow it for a gain in portability.
2203    *
2204    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2205    * in VMS file.dir notation.
2206    */
2207   if ((speclen > 1) && (file_spec[speclen-1] == '/')) {
2208     char *vms_src, *vms_dir, *rslt;
2209     int ret = -1;
2210     errno = EIO;
2211
2212     /* First convert this to a VMS format specification */
2213     vms_src = PerlMem_malloc(VMS_MAXRSS);
2214     if (vms_src == NULL)
2215         _ckvmssts_noperl(SS$_INSFMEM);
2216
2217     rslt = do_tovmsspec(file_spec, vms_src, 0, NULL);
2218     if (rslt == NULL) {
2219         /* If we fail, then not a file specification */
2220         PerlMem_free(vms_src);
2221         errno = EIO;
2222         return -1;
2223     }
2224
2225     /* Now make it a directory spec so chmod is happy */
2226     vms_dir = PerlMem_malloc(VMS_MAXRSS + 1);
2227     if (vms_dir == NULL)
2228         _ckvmssts_noperl(SS$_INSFMEM);
2229     rslt = do_fileify_dirspec(vms_src, vms_dir, 0, NULL);
2230     PerlMem_free(vms_src);
2231
2232     /* Now do it */
2233     if (rslt != NULL) {
2234         ret = chmod(vms_dir, mode);
2235     } else {
2236         errno = EIO;
2237     }
2238     PerlMem_free(vms_dir);
2239     return ret;
2240   }
2241   else return chmod(file_spec, mode);
2242 }  /* end of my_chmod */
2243 /*}}}*/
2244
2245
2246 /*{{{FILE *my_tmpfile()*/
2247 FILE *
2248 my_tmpfile(void)
2249 {
2250   FILE *fp;
2251   char *cp;
2252
2253   if ((fp = tmpfile())) return fp;
2254
2255   cp = PerlMem_malloc(L_tmpnam+24);
2256   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2257
2258   if (decc_filename_unix_only == 0)
2259     strcpy(cp,"Sys$Scratch:");
2260   else
2261     strcpy(cp,"/tmp/");
2262   tmpnam(cp+strlen(cp));
2263   strcat(cp,".Perltmp");
2264   fp = fopen(cp,"w+","fop=dlt");
2265   PerlMem_free(cp);
2266   return fp;
2267 }
2268 /*}}}*/
2269
2270
2271 #ifndef HOMEGROWN_POSIX_SIGNALS
2272 /*
2273  * The C RTL's sigaction fails to check for invalid signal numbers so we
2274  * help it out a bit.  The docs are correct, but the actual routine doesn't
2275  * do what the docs say it will.
2276  */
2277 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2278 int
2279 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2280                    struct sigaction* oact)
2281 {
2282   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2283         SETERRNO(EINVAL, SS$_INVARG);
2284         return -1;
2285   }
2286   return sigaction(sig, act, oact);
2287 }
2288 /*}}}*/
2289 #endif
2290
2291 #ifdef KILL_BY_SIGPRC
2292 #include <errnodef.h>
2293
2294 /* We implement our own kill() using the undocumented system service
2295    sys$sigprc for one of two reasons:
2296
2297    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2298    target process to do a sys$exit, which usually can't be handled
2299    gracefully...certainly not by Perl and the %SIG{} mechanism.
2300
2301    2.) If the kill() in the CRTL can't be called from a signal
2302    handler without disappearing into the ether, i.e., the signal
2303    it purportedly sends is never trapped. Still true as of VMS 7.3.
2304
2305    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2306    in the target process rather than calling sys$exit.
2307
2308    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2309    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2310    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2311    with condition codes C$_SIG0+nsig*8, catching the exception on the
2312    target process and resignaling with appropriate arguments.
2313
2314    But we don't have that VMS 7.0+ exception handler, so if you
2315    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2316
2317    Also note that SIGTERM is listed in the docs as being "unimplemented",
2318    yet always seems to be signaled with a VMS condition code of 4 (and
2319    correctly handled for that code).  So we hardwire it in.
2320
2321    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2322    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2323    than signalling with an unrecognized (and unhandled by CRTL) code.
2324 */
2325
2326 #define _MY_SIG_MAX 28
2327
2328 static unsigned int
2329 Perl_sig_to_vmscondition_int(int sig)
2330 {
2331     static unsigned int sig_code[_MY_SIG_MAX+1] =
2332     {
2333         0,                  /*  0 ZERO     */
2334         SS$_HANGUP,         /*  1 SIGHUP   */
2335         SS$_CONTROLC,       /*  2 SIGINT   */
2336         SS$_CONTROLY,       /*  3 SIGQUIT  */
2337         SS$_RADRMOD,        /*  4 SIGILL   */
2338         SS$_BREAK,          /*  5 SIGTRAP  */
2339         SS$_OPCCUS,         /*  6 SIGABRT  */
2340         SS$_COMPAT,         /*  7 SIGEMT   */
2341 #ifdef __VAX
2342         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2343 #else
2344         SS$_HPARITH,        /*  8 SIGFPE AXP */
2345 #endif
2346         SS$_ABORT,          /*  9 SIGKILL  */
2347         SS$_ACCVIO,         /* 10 SIGBUS   */
2348         SS$_ACCVIO,         /* 11 SIGSEGV  */
2349         SS$_BADPARAM,       /* 12 SIGSYS   */
2350         SS$_NOMBX,          /* 13 SIGPIPE  */
2351         SS$_ASTFLT,         /* 14 SIGALRM  */
2352         4,                  /* 15 SIGTERM  */
2353         0,                  /* 16 SIGUSR1  */
2354         0,                  /* 17 SIGUSR2  */
2355         0,                  /* 18 */
2356         0,                  /* 19 */
2357         0,                  /* 20 SIGCHLD  */
2358         0,                  /* 21 SIGCONT  */
2359         0,                  /* 22 SIGSTOP  */
2360         0,                  /* 23 SIGTSTP  */
2361         0,                  /* 24 SIGTTIN  */
2362         0,                  /* 25 SIGTTOU  */
2363         0,                  /* 26 */
2364         0,                  /* 27 */
2365         0                   /* 28 SIGWINCH  */
2366     };
2367
2368 #if __VMS_VER >= 60200000
2369     static int initted = 0;
2370     if (!initted) {
2371         initted = 1;
2372         sig_code[16] = C$_SIGUSR1;
2373         sig_code[17] = C$_SIGUSR2;
2374 #if __CRTL_VER >= 70000000
2375         sig_code[20] = C$_SIGCHLD;
2376 #endif
2377 #if __CRTL_VER >= 70300000
2378         sig_code[28] = C$_SIGWINCH;
2379 #endif
2380     }
2381 #endif
2382
2383     if (sig < _SIG_MIN) return 0;
2384     if (sig > _MY_SIG_MAX) return 0;
2385     return sig_code[sig];
2386 }
2387
2388 unsigned int
2389 Perl_sig_to_vmscondition(int sig)
2390 {
2391 #ifdef SS$_DEBUG
2392     if (vms_debug_on_exception != 0)
2393         lib$signal(SS$_DEBUG);
2394 #endif
2395     return Perl_sig_to_vmscondition_int(sig);
2396 }
2397
2398
2399 int
2400 Perl_my_kill(int pid, int sig)
2401 {
2402     dTHX;
2403     int iss;
2404     unsigned int code;
2405     int sys$sigprc(unsigned int *pidadr,
2406                      struct dsc$descriptor_s *prcname,
2407                      unsigned int code);
2408
2409      /* sig 0 means validate the PID */
2410     /*------------------------------*/
2411     if (sig == 0) {
2412         const unsigned long int jpicode = JPI$_PID;
2413         pid_t ret_pid;
2414         int status;
2415         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2416         if ($VMS_STATUS_SUCCESS(status))
2417            return 0;
2418         switch (status) {
2419         case SS$_NOSUCHNODE:
2420         case SS$_UNREACHABLE:
2421         case SS$_NONEXPR:
2422            errno = ESRCH;
2423            break;
2424         case SS$_NOPRIV:
2425            errno = EPERM;
2426            break;
2427         default:
2428            errno = EVMSERR;
2429         }
2430         vaxc$errno=status;
2431         return -1;
2432     }
2433
2434     code = Perl_sig_to_vmscondition_int(sig);
2435
2436     if (!code) {
2437         SETERRNO(EINVAL, SS$_BADPARAM);
2438         return -1;
2439     }
2440
2441     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2442      * signals are to be sent to multiple processes.
2443      *  pid = 0 - all processes in group except ones that the system exempts
2444      *  pid = -1 - all processes except ones that the system exempts
2445      *  pid = -n - all processes in group (abs(n)) except ...
2446      * For now, just report as not supported.
2447      */
2448
2449     if (pid <= 0) {
2450         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2451         return -1;
2452     }
2453
2454     iss = sys$sigprc((unsigned int *)&pid,0,code);
2455     if (iss&1) return 0;
2456
2457     switch (iss) {
2458       case SS$_NOPRIV:
2459         set_errno(EPERM);  break;
2460       case SS$_NONEXPR:
2461       case SS$_NOSUCHNODE:
2462       case SS$_UNREACHABLE:
2463         set_errno(ESRCH);  break;
2464       case SS$_INSFMEM:
2465         set_errno(ENOMEM); break;
2466       default:
2467         _ckvmssts_noperl(iss);
2468         set_errno(EVMSERR);
2469     }
2470     set_vaxc_errno(iss);
2471
2472     return -1;
2473 }
2474 #endif
2475
2476 /* Routine to convert a VMS status code to a UNIX status code.
2477 ** More tricky than it appears because of conflicting conventions with
2478 ** existing code.
2479 **
2480 ** VMS status codes are a bit mask, with the least significant bit set for
2481 ** success.
2482 **
2483 ** Special UNIX status of EVMSERR indicates that no translation is currently
2484 ** available, and programs should check the VMS status code.
2485 **
2486 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2487 ** decoding.
2488 */
2489
2490 #ifndef C_FACILITY_NO
2491 #define C_FACILITY_NO 0x350000
2492 #endif
2493 #ifndef DCL_IVVERB
2494 #define DCL_IVVERB 0x38090
2495 #endif
2496
2497 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2498 {
2499 int facility;
2500 int fac_sp;
2501 int msg_no;
2502 int msg_status;
2503 int unix_status;
2504
2505   /* Assume the best or the worst */
2506   if (vms_status & STS$M_SUCCESS)
2507     unix_status = 0;
2508   else
2509     unix_status = EVMSERR;
2510
2511   msg_status = vms_status & ~STS$M_CONTROL;
2512
2513   facility = vms_status & STS$M_FAC_NO;
2514   fac_sp = vms_status & STS$M_FAC_SP;
2515   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2516
2517   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2518     switch(msg_no) {
2519     case SS$_NORMAL:
2520         unix_status = 0;
2521         break;
2522     case SS$_ACCVIO:
2523         unix_status = EFAULT;
2524         break;
2525     case SS$_DEVOFFLINE:
2526         unix_status = EBUSY;
2527         break;
2528     case SS$_CLEARED:
2529         unix_status = ENOTCONN;
2530         break;
2531     case SS$_IVCHAN:
2532     case SS$_IVLOGNAM:
2533     case SS$_BADPARAM:
2534     case SS$_IVLOGTAB:
2535     case SS$_NOLOGNAM:
2536     case SS$_NOLOGTAB:
2537     case SS$_INVFILFOROP:
2538     case SS$_INVARG:
2539     case SS$_NOSUCHID:
2540     case SS$_IVIDENT:
2541         unix_status = EINVAL;
2542         break;
2543     case SS$_UNSUPPORTED:
2544         unix_status = ENOTSUP;
2545         break;
2546     case SS$_FILACCERR:
2547     case SS$_NOGRPPRV:
2548     case SS$_NOSYSPRV:
2549         unix_status = EACCES;
2550         break;
2551     case SS$_DEVICEFULL:
2552         unix_status = ENOSPC;
2553         break;
2554     case SS$_NOSUCHDEV:
2555         unix_status = ENODEV;
2556         break;
2557     case SS$_NOSUCHFILE:
2558     case SS$_NOSUCHOBJECT:
2559         unix_status = ENOENT;
2560         break;
2561     case SS$_ABORT:                                 /* Fatal case */
2562     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2563     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2564         unix_status = EINTR;
2565         break;
2566     case SS$_BUFFEROVF:
2567         unix_status = E2BIG;
2568         break;
2569     case SS$_INSFMEM:
2570         unix_status = ENOMEM;
2571         break;
2572     case SS$_NOPRIV:
2573         unix_status = EPERM;
2574         break;
2575     case SS$_NOSUCHNODE:
2576     case SS$_UNREACHABLE:
2577         unix_status = ESRCH;
2578         break;
2579     case SS$_NONEXPR:
2580         unix_status = ECHILD;
2581         break;
2582     default:
2583         if ((facility == 0) && (msg_no < 8)) {
2584           /* These are not real VMS status codes so assume that they are
2585           ** already UNIX status codes
2586           */
2587           unix_status = msg_no;
2588           break;
2589         }
2590     }
2591   }
2592   else {
2593     /* Translate a POSIX exit code to a UNIX exit code */
2594     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2595         unix_status = (msg_no & 0x07F8) >> 3;
2596     }
2597     else {
2598
2599          /* Documented traditional behavior for handling VMS child exits */
2600         /*--------------------------------------------------------------*/
2601         if (child_flag != 0) {
2602
2603              /* Success / Informational return 0 */
2604             /*----------------------------------*/
2605             if (msg_no & STS$K_SUCCESS)
2606                 return 0;
2607
2608              /* Warning returns 1 */
2609             /*-------------------*/
2610             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2611                 return 1;
2612
2613              /* Everything else pass through the severity bits */
2614             /*------------------------------------------------*/
2615             return (msg_no & STS$M_SEVERITY);
2616         }
2617
2618          /* Normal VMS status to ERRNO mapping attempt */
2619         /*--------------------------------------------*/
2620         switch(msg_status) {
2621         /* case RMS$_EOF: */ /* End of File */
2622         case RMS$_FNF:  /* File Not Found */
2623         case RMS$_DNF:  /* Dir Not Found */
2624                 unix_status = ENOENT;
2625                 break;
2626         case RMS$_RNF:  /* Record Not Found */
2627                 unix_status = ESRCH;
2628                 break;
2629         case RMS$_DIR:
2630                 unix_status = ENOTDIR;
2631                 break;
2632         case RMS$_DEV:
2633                 unix_status = ENODEV;
2634                 break;
2635         case RMS$_IFI:
2636         case RMS$_FAC:
2637         case RMS$_ISI:
2638                 unix_status = EBADF;
2639                 break;
2640         case RMS$_FEX:
2641                 unix_status = EEXIST;
2642                 break;
2643         case RMS$_SYN:
2644         case RMS$_FNM:
2645         case LIB$_INVSTRDES:
2646         case LIB$_INVARG:
2647         case LIB$_NOSUCHSYM:
2648         case LIB$_INVSYMNAM:
2649         case DCL_IVVERB:
2650                 unix_status = EINVAL;
2651                 break;
2652         case CLI$_BUFOVF:
2653         case RMS$_RTB:
2654         case CLI$_TKNOVF:
2655         case CLI$_RSLOVF:
2656                 unix_status = E2BIG;
2657                 break;
2658         case RMS$_PRV:  /* No privilege */
2659         case RMS$_ACC:  /* ACP file access failed */
2660         case RMS$_WLK:  /* Device write locked */
2661                 unix_status = EACCES;
2662                 break;
2663         case RMS$_MKD:  /* Failed to mark for delete */
2664                 unix_status = EPERM;
2665                 break;
2666         /* case RMS$_NMF: */  /* No more files */
2667         }
2668     }
2669   }
2670
2671   return unix_status;
2672 }
2673
2674 /* Try to guess at what VMS error status should go with a UNIX errno
2675  * value.  This is hard to do as there could be many possible VMS
2676  * error statuses that caused the errno value to be set.
2677  */
2678
2679 int Perl_unix_status_to_vms(int unix_status)
2680 {
2681 int test_unix_status;
2682
2683      /* Trivial cases first */
2684     /*---------------------*/
2685     if (unix_status == EVMSERR)
2686         return vaxc$errno;
2687
2688      /* Is vaxc$errno sane? */
2689     /*---------------------*/
2690     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2691     if (test_unix_status == unix_status)
2692         return vaxc$errno;
2693
2694      /* If way out of range, must be VMS code already */
2695     /*-----------------------------------------------*/
2696     if (unix_status > EVMSERR)
2697         return unix_status;
2698
2699      /* If out of range, punt */
2700     /*-----------------------*/
2701     if (unix_status > __ERRNO_MAX)
2702         return SS$_ABORT;
2703
2704
2705      /* Ok, now we have to do it the hard way. */
2706     /*----------------------------------------*/
2707     switch(unix_status) {
2708     case 0:     return SS$_NORMAL;
2709     case EPERM: return SS$_NOPRIV;
2710     case ENOENT: return SS$_NOSUCHOBJECT;
2711     case ESRCH: return SS$_UNREACHABLE;
2712     case EINTR: return SS$_ABORT;
2713     /* case EIO: */
2714     /* case ENXIO:  */
2715     case E2BIG: return SS$_BUFFEROVF;
2716     /* case ENOEXEC */
2717     case EBADF: return RMS$_IFI;
2718     case ECHILD: return SS$_NONEXPR;
2719     /* case EAGAIN */
2720     case ENOMEM: return SS$_INSFMEM;
2721     case EACCES: return SS$_FILACCERR;
2722     case EFAULT: return SS$_ACCVIO;
2723     /* case ENOTBLK */
2724     case EBUSY: return SS$_DEVOFFLINE;
2725     case EEXIST: return RMS$_FEX;
2726     /* case EXDEV */
2727     case ENODEV: return SS$_NOSUCHDEV;
2728     case ENOTDIR: return RMS$_DIR;
2729     /* case EISDIR */
2730     case EINVAL: return SS$_INVARG;
2731     /* case ENFILE */
2732     /* case EMFILE */
2733     /* case ENOTTY */
2734     /* case ETXTBSY */
2735     /* case EFBIG */
2736     case ENOSPC: return SS$_DEVICEFULL;
2737     case ESPIPE: return LIB$_INVARG;
2738     /* case EROFS: */
2739     /* case EMLINK: */
2740     /* case EPIPE: */
2741     /* case EDOM */
2742     case ERANGE: return LIB$_INVARG;
2743     /* case EWOULDBLOCK */
2744     /* case EINPROGRESS */
2745     /* case EALREADY */
2746     /* case ENOTSOCK */
2747     /* case EDESTADDRREQ */
2748     /* case EMSGSIZE */
2749     /* case EPROTOTYPE */
2750     /* case ENOPROTOOPT */
2751     /* case EPROTONOSUPPORT */
2752     /* case ESOCKTNOSUPPORT */
2753     /* case EOPNOTSUPP */
2754     /* case EPFNOSUPPORT */
2755     /* case EAFNOSUPPORT */
2756     /* case EADDRINUSE */
2757     /* case EADDRNOTAVAIL */
2758     /* case ENETDOWN */
2759     /* case ENETUNREACH */
2760     /* case ENETRESET */
2761     /* case ECONNABORTED */
2762     /* case ECONNRESET */
2763     /* case ENOBUFS */
2764     /* case EISCONN */
2765     case ENOTCONN: return SS$_CLEARED;
2766     /* case ESHUTDOWN */
2767     /* case ETOOMANYREFS */
2768     /* case ETIMEDOUT */
2769     /* case ECONNREFUSED */
2770     /* case ELOOP */
2771     /* case ENAMETOOLONG */
2772     /* case EHOSTDOWN */
2773     /* case EHOSTUNREACH */
2774     /* case ENOTEMPTY */
2775     /* case EPROCLIM */
2776     /* case EUSERS  */
2777     /* case EDQUOT  */
2778     /* case ENOMSG  */
2779     /* case EIDRM */
2780     /* case EALIGN */
2781     /* case ESTALE */
2782     /* case EREMOTE */
2783     /* case ENOLCK */
2784     /* case ENOSYS */
2785     /* case EFTYPE */
2786     /* case ECANCELED */
2787     /* case EFAIL */
2788     /* case EINPROG */
2789     case ENOTSUP:
2790         return SS$_UNSUPPORTED;
2791     /* case EDEADLK */
2792     /* case ENWAIT */
2793     /* case EILSEQ */
2794     /* case EBADCAT */
2795     /* case EBADMSG */
2796     /* case EABANDONED */
2797     default:
2798         return SS$_ABORT; /* punt */
2799     }
2800
2801   return SS$_ABORT; /* Should not get here */
2802 }
2803
2804
2805 /* default piping mailbox size */
2806 #define PERL_BUFSIZ        512
2807
2808
2809 static void
2810 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2811 {
2812   unsigned long int mbxbufsiz;
2813   static unsigned long int syssize = 0;
2814   unsigned long int dviitm = DVI$_DEVNAM;
2815   char csize[LNM$C_NAMLENGTH+1];
2816   int sts;
2817
2818   if (!syssize) {
2819     unsigned long syiitm = SYI$_MAXBUF;
2820     /*
2821      * Get the SYSGEN parameter MAXBUF
2822      *
2823      * If the logical 'PERL_MBX_SIZE' is defined
2824      * use the value of the logical instead of PERL_BUFSIZ, but
2825      * keep the size between 128 and MAXBUF.
2826      *
2827      */
2828     _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2829   }
2830
2831   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2832       mbxbufsiz = atoi(csize);
2833   } else {
2834       mbxbufsiz = PERL_BUFSIZ;
2835   }
2836   if (mbxbufsiz < 128) mbxbufsiz = 128;
2837   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2838
2839   _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2840
2841   sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2842   _ckvmssts_noperl(sts);
2843   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2844
2845 }  /* end of create_mbx() */
2846
2847
2848 /*{{{  my_popen and my_pclose*/
2849
2850 typedef struct _iosb           IOSB;
2851 typedef struct _iosb*         pIOSB;
2852 typedef struct _pipe           Pipe;
2853 typedef struct _pipe*         pPipe;
2854 typedef struct pipe_details    Info;
2855 typedef struct pipe_details*  pInfo;
2856 typedef struct _srqp            RQE;
2857 typedef struct _srqp*          pRQE;
2858 typedef struct _tochildbuf      CBuf;
2859 typedef struct _tochildbuf*    pCBuf;
2860
2861 struct _iosb {
2862     unsigned short status;
2863     unsigned short count;
2864     unsigned long  dvispec;
2865 };
2866
2867 #pragma member_alignment save
2868 #pragma nomember_alignment quadword
2869 struct _srqp {          /* VMS self-relative queue entry */
2870     unsigned long qptr[2];
2871 };
2872 #pragma member_alignment restore
2873 static RQE  RQE_ZERO = {0,0};
2874
2875 struct _tochildbuf {
2876     RQE             q;
2877     int             eof;
2878     unsigned short  size;
2879     char            *buf;
2880 };
2881
2882 struct _pipe {
2883     RQE            free;
2884     RQE            wait;
2885     int            fd_out;
2886     unsigned short chan_in;
2887     unsigned short chan_out;
2888     char          *buf;
2889     unsigned int   bufsize;
2890     IOSB           iosb;
2891     IOSB           iosb2;
2892     int           *pipe_done;
2893     int            retry;
2894     int            type;
2895     int            shut_on_empty;
2896     int            need_wake;
2897     pPipe         *home;
2898     pInfo          info;
2899     pCBuf          curr;
2900     pCBuf          curr2;
2901 #if defined(PERL_IMPLICIT_CONTEXT)
2902     void            *thx;           /* Either a thread or an interpreter */
2903                                     /* pointer, depending on how we're built */
2904 #endif
2905 };
2906
2907
2908 struct pipe_details
2909 {
2910     pInfo           next;
2911     PerlIO *fp;  /* file pointer to pipe mailbox */
2912     int useFILE; /* using stdio, not perlio */
2913     int pid;   /* PID of subprocess */
2914     int mode;  /* == 'r' if pipe open for reading */
2915     int done;  /* subprocess has completed */
2916     int waiting; /* waiting for completion/closure */
2917     int             closing;        /* my_pclose is closing this pipe */
2918     unsigned long   completion;     /* termination status of subprocess */
2919     pPipe           in;             /* pipe in to sub */
2920     pPipe           out;            /* pipe out of sub */
2921     pPipe           err;            /* pipe of sub's sys$error */
2922     int             in_done;        /* true when in pipe finished */
2923     int             out_done;
2924     int             err_done;
2925     unsigned short  xchan;          /* channel to debug xterm */
2926     unsigned short  xchan_valid;    /* channel is assigned */
2927 };
2928
2929 struct exit_control_block
2930 {
2931     struct exit_control_block *flink;
2932     unsigned long int   (*exit_routine)();
2933     unsigned long int arg_count;
2934     unsigned long int *status_address;
2935     unsigned long int exit_status;
2936 };
2937
2938 typedef struct _closed_pipes    Xpipe;
2939 typedef struct _closed_pipes*  pXpipe;
2940
2941 struct _closed_pipes {
2942     int             pid;            /* PID of subprocess */
2943     unsigned long   completion;     /* termination status of subprocess */
2944 };
2945 #define NKEEPCLOSED 50
2946 static Xpipe closed_list[NKEEPCLOSED];
2947 static int   closed_index = 0;
2948 static int   closed_num = 0;
2949
2950 #define RETRY_DELAY     "0 ::0.20"
2951 #define MAX_RETRY              50
2952
2953 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2954 static unsigned long mypid;
2955 static unsigned long delaytime[2];
2956
2957 static pInfo open_pipes = NULL;
2958 static $DESCRIPTOR(nl_desc, "NL:");
2959
2960 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2961
2962
2963
2964 static unsigned long int
2965 pipe_exit_routine()
2966 {
2967     pInfo info;
2968     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2969     int sts, did_stuff, need_eof, j;
2970
2971    /*
2972     * Flush any pending i/o, but since we are in process run-down, be
2973     * careful about referencing PerlIO structures that may already have
2974     * been deallocated.  We may not even have an interpreter anymore.
2975     */
2976     info = open_pipes;
2977     while (info) {
2978         if (info->fp) {
2979 #if defined(PERL_IMPLICIT_CONTEXT)
2980            /* We need to use the Perl context of the thread that created */
2981            /* the pipe. */
2982            pTHX;
2983            if (info->err)
2984                aTHX = info->err->thx;
2985            else if (info->out)
2986                aTHX = info->out->thx;
2987            else if (info->in)
2988                aTHX = info->in->thx;
2989 #endif
2990            if (!info->useFILE
2991 #if defined(USE_ITHREADS)
2992              && my_perl
2993 #endif
2994              && PL_perlio_fd_refcnt)
2995                PerlIO_flush(info->fp);
2996            else
2997                fflush((FILE *)info->fp);
2998         }
2999         info = info->next;
3000     }
3001
3002     /*
3003      next we try sending an EOF...ignore if doesn't work, make sure we
3004      don't hang
3005     */
3006     did_stuff = 0;
3007     info = open_pipes;
3008
3009     while (info) {
3010       int need_eof;
3011       _ckvmssts_noperl(sys$setast(0));
3012       if (info->in && !info->in->shut_on_empty) {
3013         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3014                                  0, 0, 0, 0, 0, 0));
3015         info->waiting = 1;
3016         did_stuff = 1;
3017       }
3018       _ckvmssts_noperl(sys$setast(1));
3019       info = info->next;
3020     }
3021
3022     /* wait for EOF to have effect, up to ~ 30 sec [default] */
3023
3024     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3025         int nwait = 0;
3026
3027         info = open_pipes;
3028         while (info) {
3029           _ckvmssts_noperl(sys$setast(0));
3030           if (info->waiting && info->done)
3031                 info->waiting = 0;
3032           nwait += info->waiting;
3033           _ckvmssts_noperl(sys$setast(1));
3034           info = info->next;
3035         }
3036         if (!nwait) break;
3037         sleep(1);
3038     }
3039
3040     did_stuff = 0;
3041     info = open_pipes;
3042     while (info) {
3043       _ckvmssts_noperl(sys$setast(0));
3044       if (!info->done) { /* Tap them gently on the shoulder . . .*/
3045         sts = sys$forcex(&info->pid,0,&abort);
3046         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3047         did_stuff = 1;
3048       }
3049       _ckvmssts_noperl(sys$setast(1));
3050       info = info->next;
3051     }
3052
3053     /* again, wait for effect */
3054
3055     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3056         int nwait = 0;
3057
3058         info = open_pipes;
3059         while (info) {
3060           _ckvmssts_noperl(sys$setast(0));
3061           if (info->waiting && info->done)
3062                 info->waiting = 0;
3063           nwait += info->waiting;
3064           _ckvmssts_noperl(sys$setast(1));
3065           info = info->next;
3066         }
3067         if (!nwait) break;
3068         sleep(1);
3069     }
3070
3071     info = open_pipes;
3072     while (info) {
3073       _ckvmssts_noperl(sys$setast(0));
3074       if (!info->done) {  /* We tried to be nice . . . */
3075         sts = sys$delprc(&info->pid,0);
3076         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3077         info->done = 1;  /* sys$delprc is as done as we're going to get. */
3078       }
3079       _ckvmssts_noperl(sys$setast(1));
3080       info = info->next;
3081     }
3082
3083     while(open_pipes) {
3084
3085 #if defined(PERL_IMPLICIT_CONTEXT)
3086       /* We need to use the Perl context of the thread that created */
3087       /* the pipe. */
3088       pTHX;
3089       if (open_pipes->err)
3090           aTHX = open_pipes->err->thx;
3091       else if (open_pipes->out)
3092           aTHX = open_pipes->out->thx;
3093       else if (open_pipes->in)
3094           aTHX = open_pipes->in->thx;
3095 #endif
3096       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3097       else if (!(sts & 1)) retsts = sts;
3098     }
3099     return retsts;
3100 }
3101
3102 static struct exit_control_block pipe_exitblock =
3103        {(struct exit_control_block *) 0,
3104         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3105
3106 static void pipe_mbxtofd_ast(pPipe p);
3107 static void pipe_tochild1_ast(pPipe p);
3108 static void pipe_tochild2_ast(pPipe p);
3109
3110 static void
3111 popen_completion_ast(pInfo info)
3112 {
3113   pInfo i = open_pipes;
3114   int iss;
3115   int sts;
3116   pXpipe x;
3117
3118   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3119   closed_list[closed_index].pid = info->pid;
3120   closed_list[closed_index].completion = info->completion;
3121   closed_index++;
3122   if (closed_index == NKEEPCLOSED)
3123     closed_index = 0;
3124   closed_num++;
3125
3126   while (i) {
3127     if (i == info) break;
3128     i = i->next;
3129   }
3130   if (!i) return;       /* unlinked, probably freed too */
3131
3132   info->done = TRUE;
3133
3134 /*
3135     Writing to subprocess ...
3136             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3137
3138             chan_out may be waiting for "done" flag, or hung waiting
3139             for i/o completion to child...cancel the i/o.  This will
3140             put it into "snarf mode" (done but no EOF yet) that discards
3141             input.
3142
3143     Output from subprocess (stdout, stderr) needs to be flushed and
3144     shut down.   We try sending an EOF, but if the mbx is full the pipe
3145     routine should still catch the "shut_on_empty" flag, telling it to
3146     use immediate-style reads so that "mbx empty" -> EOF.
3147
3148
3149 */
3150   if (info->in && !info->in_done) {               /* only for mode=w */
3151         if (info->in->shut_on_empty && info->in->need_wake) {
3152             info->in->need_wake = FALSE;
3153             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3154         } else {
3155             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3156         }
3157   }
3158
3159   if (info->out && !info->out_done) {             /* were we also piping output? */
3160       info->out->shut_on_empty = TRUE;
3161       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3162       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3163       _ckvmssts_noperl(iss);
3164   }
3165
3166   if (info->err && !info->err_done) {        /* we were piping stderr */
3167         info->err->shut_on_empty = TRUE;
3168         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3169         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3170         _ckvmssts_noperl(iss);
3171   }
3172   _ckvmssts_noperl(sys$setef(pipe_ef));
3173
3174 }
3175
3176 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3177 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3178
3179 /*
3180     we actually differ from vmstrnenv since we use this to
3181     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3182     are pointing to the same thing
3183 */
3184
3185 static unsigned short
3186 popen_translate(pTHX_ char *logical, char *result)
3187 {
3188     int iss;
3189     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3190     $DESCRIPTOR(d_log,"");
3191     struct _il3 {
3192         unsigned short length;
3193         unsigned short code;
3194         char *         buffer_addr;
3195         unsigned short *retlenaddr;
3196     } itmlst[2];
3197     unsigned short l, ifi;
3198
3199     d_log.dsc$a_pointer = logical;
3200     d_log.dsc$w_length  = strlen(logical);
3201
3202     itmlst[0].code = LNM$_STRING;
3203     itmlst[0].length = 255;
3204     itmlst[0].buffer_addr = result;
3205     itmlst[0].retlenaddr = &l;
3206
3207     itmlst[1].code = 0;
3208     itmlst[1].length = 0;
3209     itmlst[1].buffer_addr = 0;
3210     itmlst[1].retlenaddr = 0;
3211
3212     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3213     if (iss == SS$_NOLOGNAM) {
3214         iss = SS$_NORMAL;
3215         l = 0;
3216     }
3217     if (!(iss&1)) lib$signal(iss);
3218     result[l] = '\0';
3219 /*
3220     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
3221     strip it off and return the ifi, if any
3222 */
3223     ifi  = 0;
3224     if (result[0] == 0x1b && result[1] == 0x00) {
3225         memmove(&ifi,result+2,2);
3226         strcpy(result,result+4);
3227     }
3228     return ifi;     /* this is the RMS internal file id */
3229 }
3230
3231 static void pipe_infromchild_ast(pPipe p);
3232
3233 /*
3234     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3235     inside an AST routine without worrying about reentrancy and which Perl
3236     memory allocator is being used.
3237
3238     We read data and queue up the buffers, then spit them out one at a
3239     time to the output mailbox when the output mailbox is ready for one.
3240
3241 */
3242 #define INITIAL_TOCHILDQUEUE  2
3243
3244 static pPipe
3245 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3246 {
3247     pPipe p;
3248     pCBuf b;
3249     char mbx1[64], mbx2[64];
3250     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3251                                       DSC$K_CLASS_S, mbx1},
3252                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3253                                       DSC$K_CLASS_S, mbx2};
3254     unsigned int dviitm = DVI$_DEVBUFSIZ;
3255     int j, n;
3256
3257     n = sizeof(Pipe);
3258     _ckvmssts_noperl(lib$get_vm(&n, &p));
3259
3260     create_mbx(&p->chan_in , &d_mbx1);
3261     create_mbx(&p->chan_out, &d_mbx2);
3262     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3263
3264     p->buf           = 0;
3265     p->shut_on_empty = FALSE;
3266     p->need_wake     = FALSE;
3267     p->type          = 0;
3268     p->retry         = 0;
3269     p->iosb.status   = SS$_NORMAL;
3270     p->iosb2.status  = SS$_NORMAL;
3271     p->free          = RQE_ZERO;
3272     p->wait          = RQE_ZERO;
3273     p->curr          = 0;
3274     p->curr2         = 0;
3275     p->info          = 0;
3276 #ifdef PERL_IMPLICIT_CONTEXT
3277     p->thx           = aTHX;
3278 #endif
3279
3280     n = sizeof(CBuf) + p->bufsize;
3281
3282     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3283         _ckvmssts_noperl(lib$get_vm(&n, &b));
3284         b->buf = (char *) b + sizeof(CBuf);
3285         _ckvmssts_noperl(lib$insqhi(b, &p->free));
3286     }
3287
3288     pipe_tochild2_ast(p);
3289     pipe_tochild1_ast(p);
3290     strcpy(wmbx, mbx1);
3291     strcpy(rmbx, mbx2);
3292     return p;
3293 }
3294
3295 /*  reads the MBX Perl is writing, and queues */
3296
3297 static void
3298 pipe_tochild1_ast(pPipe p)
3299 {
3300     pCBuf b = p->curr;
3301     int iss = p->iosb.status;
3302     int eof = (iss == SS$_ENDOFFILE);
3303     int sts;
3304 #ifdef PERL_IMPLICIT_CONTEXT
3305     pTHX = p->thx;
3306 #endif
3307
3308     if (p->retry) {
3309         if (eof) {
3310             p->shut_on_empty = TRUE;
3311             b->eof     = TRUE;
3312             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3313         } else  {
3314             _ckvmssts_noperl(iss);
3315         }
3316
3317         b->eof  = eof;
3318         b->size = p->iosb.count;
3319         _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3320         if (p->need_wake) {
3321             p->need_wake = FALSE;
3322             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3323         }
3324     } else {
3325         p->retry = 1;   /* initial call */
3326     }
3327
3328     if (eof) {                  /* flush the free queue, return when done */
3329         int n = sizeof(CBuf) + p->bufsize;
3330         while (1) {
3331             iss = lib$remqti(&p->free, &b);
3332             if (iss == LIB$_QUEWASEMP) return;
3333             _ckvmssts_noperl(iss);
3334             _ckvmssts_noperl(lib$free_vm(&n, &b));
3335         }
3336     }
3337
3338     iss = lib$remqti(&p->free, &b);
3339     if (iss == LIB$_QUEWASEMP) {
3340         int n = sizeof(CBuf) + p->bufsize;
3341         _ckvmssts_noperl(lib$get_vm(&n, &b));
3342         b->buf = (char *) b + sizeof(CBuf);
3343     } else {
3344        _ckvmssts_noperl(iss);
3345     }
3346
3347     p->curr = b;
3348     iss = sys$qio(0,p->chan_in,
3349              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3350              &p->iosb,
3351              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3352     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3353     _ckvmssts_noperl(iss);
3354 }
3355
3356
3357 /* writes queued buffers to output, waits for each to complete before
3358    doing the next */
3359
3360 static void
3361 pipe_tochild2_ast(pPipe p)
3362 {
3363     pCBuf b = p->curr2;
3364     int iss = p->iosb2.status;
3365     int n = sizeof(CBuf) + p->bufsize;
3366     int done = (p->info && p->info->done) ||
3367               iss == SS$_CANCEL || iss == SS$_ABORT;
3368 #if defined(PERL_IMPLICIT_CONTEXT)
3369     pTHX = p->thx;
3370 #endif
3371
3372     do {
3373         if (p->type) {         /* type=1 has old buffer, dispose */
3374             if (p->shut_on_empty) {
3375                 _ckvmssts_noperl(lib$free_vm(&n, &b));
3376             } else {
3377                 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3378             }
3379             p->type = 0;
3380         }
3381
3382         iss = lib$remqti(&p->wait, &b);
3383         if (iss == LIB$_QUEWASEMP) {
3384             if (p->shut_on_empty) {
3385                 if (done) {
3386                     _ckvmssts_noperl(sys$dassgn(p->chan_out));
3387                     *p->pipe_done = TRUE;
3388                     _ckvmssts_noperl(sys$setef(pipe_ef));
3389                 } else {
3390                     _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3391                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3392                 }
3393                 return;
3394             }
3395             p->need_wake = TRUE;
3396             return;
3397         }
3398         _ckvmssts_noperl(iss);
3399         p->type = 1;
3400     } while (done);
3401
3402
3403     p->curr2 = b;
3404     if (b->eof) {
3405         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3406             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3407     } else {
3408         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3409             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3410     }
3411
3412     return;
3413
3414 }
3415
3416
3417 static pPipe
3418 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3419 {
3420     pPipe p;
3421     char mbx1[64], mbx2[64];
3422     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3423                                       DSC$K_CLASS_S, mbx1},
3424                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3425                                       DSC$K_CLASS_S, mbx2};
3426     unsigned int dviitm = DVI$_DEVBUFSIZ;
3427
3428     int n = sizeof(Pipe);
3429     _ckvmssts_noperl(lib$get_vm(&n, &p));
3430     create_mbx(&p->chan_in , &d_mbx1);
3431     create_mbx(&p->chan_out, &d_mbx2);
3432
3433     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3434     n = p->bufsize * sizeof(char);
3435     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3436     p->shut_on_empty = FALSE;
3437     p->info   = 0;
3438     p->type   = 0;
3439     p->iosb.status = SS$_NORMAL;
3440 #if defined(PERL_IMPLICIT_CONTEXT)
3441     p->thx = aTHX;
3442 #endif
3443     pipe_infromchild_ast(p);
3444
3445     strcpy(wmbx, mbx1);
3446     strcpy(rmbx, mbx2);
3447     return p;
3448 }
3449
3450 static void
3451 pipe_infromchild_ast(pPipe p)
3452 {
3453     int iss = p->iosb.status;
3454     int eof = (iss == SS$_ENDOFFILE);
3455     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3456     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3457 #if defined(PERL_IMPLICIT_CONTEXT)
3458     pTHX = p->thx;
3459 #endif
3460
3461     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3462         _ckvmssts_noperl(sys$dassgn(p->chan_out));
3463         p->chan_out = 0;
3464     }
3465
3466     /* read completed:
3467             input shutdown if EOF from self (done or shut_on_empty)
3468             output shutdown if closing flag set (my_pclose)
3469             send data/eof from child or eof from self
3470             otherwise, re-read (snarf of data from child)
3471     */
3472
3473     if (p->type == 1) {
3474         p->type = 0;
3475         if (myeof && p->chan_in) {                  /* input shutdown */
3476             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3477             p->chan_in = 0;
3478         }
3479
3480         if (p->chan_out) {
3481             if (myeof || kideof) {      /* pass EOF to parent */
3482                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3483                                          pipe_infromchild_ast, p,
3484                                          0, 0, 0, 0, 0, 0));
3485                 return;
3486             } else if (eof) {       /* eat EOF --- fall through to read*/
3487
3488             } else {                /* transmit data */
3489                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3490                                          pipe_infromchild_ast,p,
3491                                          p->buf, p->iosb.count, 0, 0, 0, 0));
3492                 return;
3493             }
3494         }
3495     }
3496
3497     /*  everything shut? flag as done */
3498
3499     if (!p->chan_in && !p->chan_out) {
3500         *p->pipe_done = TRUE;
3501         _ckvmssts_noperl(sys$setef(pipe_ef));
3502         return;
3503     }
3504
3505     /* write completed (or read, if snarfing from child)
3506             if still have input active,
3507                queue read...immediate mode if shut_on_empty so we get EOF if empty
3508             otherwise,
3509                check if Perl reading, generate EOFs as needed
3510     */
3511
3512     if (p->type == 0) {
3513         p->type = 1;
3514         if (p->chan_in) {
3515             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3516                           pipe_infromchild_ast,p,
3517                           p->buf, p->bufsize, 0, 0, 0, 0);
3518             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3519             _ckvmssts_noperl(iss);
3520         } else {           /* send EOFs for extra reads */
3521             p->iosb.status = SS$_ENDOFFILE;
3522             p->iosb.dvispec = 0;
3523             _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3524                                      0, 0, 0,
3525                                      pipe_infromchild_ast, p, 0, 0, 0, 0));
3526         }
3527     }
3528 }
3529
3530 static pPipe
3531 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3532 {
3533     pPipe p;
3534     char mbx[64];
3535     unsigned long dviitm = DVI$_DEVBUFSIZ;
3536     struct stat s;
3537     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3538                                       DSC$K_CLASS_S, mbx};
3539     int n = sizeof(Pipe);
3540
3541     /* things like terminals and mbx's don't need this filter */
3542     if (fd && fstat(fd,&s) == 0) {
3543         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3544         char device[65];
3545         unsigned short dev_len;
3546         struct dsc$descriptor_s d_dev;
3547         char * cptr;
3548         struct item_list_3 items[3];
3549         int status;
3550         unsigned short dvi_iosb[4];
3551
3552         cptr = getname(fd, out, 1);
3553         if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3554         d_dev.dsc$a_pointer = out;
3555         d_dev.dsc$w_length = strlen(out);
3556         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3557         d_dev.dsc$b_class = DSC$K_CLASS_S;
3558
3559         items[0].len = 4;
3560         items[0].code = DVI$_DEVCHAR;
3561         items[0].bufadr = &devchar;
3562         items[0].retadr = NULL;
3563         items[1].len = 64;
3564         items[1].code = DVI$_FULLDEVNAM;
3565         items[1].bufadr = device;
3566         items[1].retadr = &dev_len;
3567         items[2].len = 0;
3568         items[2].code = 0;
3569
3570         status = sys$getdviw
3571                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3572         _ckvmssts_noperl(status);
3573         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3574             device[dev_len] = 0;
3575
3576             if (!(devchar & DEV$M_DIR)) {
3577                 strcpy(out, device);
3578                 return 0;
3579             }
3580         }
3581     }
3582
3583     _ckvmssts_noperl(lib$get_vm(&n, &p));
3584     p->fd_out = dup(fd);
3585     create_mbx(&p->chan_in, &d_mbx);
3586     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3587     n = (p->bufsize+1) * sizeof(char);
3588     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3589     p->shut_on_empty = FALSE;
3590     p->retry = 0;
3591     p->info  = 0;
3592     strcpy(out, mbx);
3593
3594     _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3595                              pipe_mbxtofd_ast, p,
3596                              p->buf, p->bufsize, 0, 0, 0, 0));
3597
3598     return p;
3599 }
3600
3601 static void
3602 pipe_mbxtofd_ast(pPipe p)
3603 {
3604     int iss = p->iosb.status;
3605     int done = p->info->done;
3606     int iss2;
3607     int eof = (iss == SS$_ENDOFFILE);
3608     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3609     int err = !(iss&1) && !eof;
3610 #if defined(PERL_IMPLICIT_CONTEXT)
3611     pTHX = p->thx;
3612 #endif
3613
3614     if (done && myeof) {               /* end piping */
3615         close(p->fd_out);
3616         sys$dassgn(p->chan_in);
3617         *p->pipe_done = TRUE;
3618         _ckvmssts_noperl(sys$setef(pipe_ef));
3619         return;
3620     }
3621
3622     if (!err && !eof) {             /* good data to send to file */
3623         p->buf[p->iosb.count] = '\n';
3624         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3625         if (iss2 < 0) {
3626             p->retry++;
3627             if (p->retry < MAX_RETRY) {
3628                 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3629                 return;
3630             }
3631         }
3632         p->retry = 0;
3633     } else if (err) {
3634         _ckvmssts_noperl(iss);
3635     }
3636
3637
3638     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3639           pipe_mbxtofd_ast, p,
3640           p->buf, p->bufsize, 0, 0, 0, 0);
3641     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3642     _ckvmssts_noperl(iss);
3643 }
3644
3645
3646 typedef struct _pipeloc     PLOC;
3647 typedef struct _pipeloc*   pPLOC;
3648
3649 struct _pipeloc {
3650     pPLOC   next;
3651     char    dir[NAM$C_MAXRSS+1];
3652 };
3653 static pPLOC  head_PLOC = 0;
3654
3655 void
3656 free_pipelocs(pTHX_ void *head)
3657 {
3658     pPLOC p, pnext;
3659     pPLOC *pHead = (pPLOC *)head;
3660
3661     p = *pHead;
3662     while (p) {
3663         pnext = p->next;
3664         PerlMem_free(p);
3665         p = pnext;
3666     }
3667     *pHead = 0;
3668 }
3669
3670 static void
3671 store_pipelocs(pTHX)
3672 {
3673     int    i;
3674     pPLOC  p;
3675     AV    *av = 0;
3676     SV    *dirsv;
3677     GV    *gv;
3678     char  *dir, *x;
3679     char  *unixdir;
3680     char  temp[NAM$C_MAXRSS+1];
3681     STRLEN n_a;
3682
3683     if (head_PLOC)
3684         free_pipelocs(aTHX_ &head_PLOC);
3685
3686 /*  the . directory from @INC comes last */
3687
3688     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3689     if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3690     p->next = head_PLOC;
3691     head_PLOC = p;
3692     strcpy(p->dir,"./");
3693
3694 /*  get the directory from $^X */
3695
3696     unixdir = PerlMem_malloc(VMS_MAXRSS);
3697     if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3698
3699 #ifdef PERL_IMPLICIT_CONTEXT
3700     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3701 #else
3702     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3703 #endif
3704         strcpy(temp, PL_origargv[0]);
3705         x = strrchr(temp,']');
3706         if (x == NULL) {
3707         x = strrchr(temp,'>');
3708           if (x == NULL) {
3709             /* It could be a UNIX path */
3710             x = strrchr(temp,'/');
3711           }
3712         }
3713         if (x)
3714           x[1] = '\0';
3715         else {
3716           /* Got a bare name, so use default directory */
3717           temp[0] = '.';
3718           temp[1] = '\0';
3719         }
3720
3721         if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3722             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3723             if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3724             p->next = head_PLOC;
3725             head_PLOC = p;
3726             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3727             p->dir[NAM$C_MAXRSS] = '\0';
3728         }
3729     }
3730
3731 /*  reverse order of @INC entries, skip "." since entered above */
3732
3733 #ifdef PERL_IMPLICIT_CONTEXT
3734     if (aTHX)
3735 #endif
3736     if (PL_incgv) av = GvAVn(PL_incgv);
3737
3738     for (i = 0; av && i <= AvFILL(av); i++) {
3739         dirsv = *av_fetch(av,i,TRUE);
3740
3741         if (SvROK(dirsv)) continue;
3742         dir = SvPVx(dirsv,n_a);
3743         if (strcmp(dir,".") == 0) continue;
3744         if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3745             continue;
3746
3747         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3748         p->next = head_PLOC;
3749         head_PLOC = p;
3750         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3751         p->dir[NAM$C_MAXRSS] = '\0';
3752     }
3753
3754 /* most likely spot (ARCHLIB) put first in the list */
3755
3756 #ifdef ARCHLIB_EXP
3757     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3758         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3759         if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3760         p->next = head_PLOC;
3761         head_PLOC = p;
3762         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3763         p->dir[NAM$C_MAXRSS] = '\0';
3764     }
3765 #endif
3766     PerlMem_free(unixdir);
3767 }
3768
3769 static I32
3770 Perl_cando_by_name_int
3771    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3772 #if !defined(PERL_IMPLICIT_CONTEXT)
3773 #define cando_by_name_int               Perl_cando_by_name_int
3774 #else
3775 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3776 #endif
3777
3778 static char *
3779 find_vmspipe(pTHX)
3780 {
3781     static int   vmspipe_file_status = 0;
3782     static char  vmspipe_file[NAM$C_MAXRSS+1];
3783
3784     /* already found? Check and use ... need read+execute permission */
3785
3786     if (vmspipe_file_status == 1) {
3787         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3788          && cando_by_name_int
3789            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3790             return vmspipe_file;
3791         }
3792         vmspipe_file_status = 0;
3793     }
3794
3795     /* scan through stored @INC, $^X */
3796
3797     if (vmspipe_file_status == 0) {
3798         char file[NAM$C_MAXRSS+1];
3799         pPLOC  p = head_PLOC;
3800
3801         while (p) {
3802             char * exp_res;
3803             int dirlen;
3804             strcpy(file, p->dir);
3805             dirlen = strlen(file);
3806             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3807             file[NAM$C_MAXRSS] = '\0';
3808             p = p->next;
3809
3810             exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3811             if (!exp_res) continue;
3812
3813             if (cando_by_name_int
3814                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3815              && cando_by_name_int
3816                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3817                 vmspipe_file_status = 1;
3818                 return vmspipe_file;
3819             }
3820         }
3821         vmspipe_file_status = -1;   /* failed, use tempfiles */
3822     }
3823
3824     return 0;
3825 }
3826
3827 static FILE *
3828 vmspipe_tempfile(pTHX)
3829 {
3830     char file[NAM$C_MAXRSS+1];
3831     FILE *fp;
3832     static int index = 0;
3833     Stat_t s0, s1;
3834     int cmp_result;
3835
3836     /* create a tempfile */
3837
3838     /* we can't go from   W, shr=get to  R, shr=get without
3839        an intermediate vulnerable state, so don't bother trying...
3840
3841        and lib$spawn doesn't shr=put, so have to close the write
3842
3843        So... match up the creation date/time and the FID to
3844        make sure we're dealing with the same file
3845
3846     */
3847
3848     index++;
3849     if (!decc_filename_unix_only) {
3850       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3851       fp = fopen(file,"w");
3852       if (!fp) {
3853         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3854         fp = fopen(file,"w");
3855         if (!fp) {
3856             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3857             fp = fopen(file,"w");
3858         }
3859       }
3860      }
3861      else {
3862       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3863       fp = fopen(file,"w");
3864       if (!fp) {
3865         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3866         fp = fopen(file,"w");
3867         if (!fp) {
3868           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3869           fp = fopen(file,"w");
3870         }
3871       }
3872     }
3873     if (!fp) return 0;  /* we're hosed */
3874
3875     fprintf(fp,"$! 'f$verify(0)'\n");
3876     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3877     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3878     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3879     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3880     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3881     fprintf(fp,"$ perl_del    = \"delete\"\n");
3882     fprintf(fp,"$ pif         = \"if\"\n");
3883     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3884     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3885     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3886     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3887     fprintf(fp,"$!  --- build command line to get max possible length\n");
3888     fprintf(fp,"$c=perl_popen_cmd0\n");
3889     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3890     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3891     fprintf(fp,"$x=perl_popen_cmd3\n");
3892     fprintf(fp,"$c=c+x\n");
3893     fprintf(fp,"$ perl_on\n");
3894     fprintf(fp,"$ 'c'\n");
3895     fprintf(fp,"$ perl_status = $STATUS\n");
3896     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3897     fprintf(fp,"$ perl_exit 'perl_status'\n");
3898     fsync(fileno(fp));
3899
3900     fgetname(fp, file, 1);
3901     fstat(fileno(fp), (struct stat *)&s0);
3902     fclose(fp);
3903
3904     if (decc_filename_unix_only)
3905         int_tounixspec(file, file, NULL);
3906     fp = fopen(file,"r","shr=get");
3907     if (!fp) return 0;
3908     fstat(fileno(fp), (struct stat *)&s1);
3909
3910     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3911     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3912         fclose(fp);
3913         return 0;
3914     }
3915
3916     return fp;
3917 }
3918
3919
3920 static int vms_is_syscommand_xterm(void)
3921 {
3922     const static struct dsc$descriptor_s syscommand_dsc =
3923       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3924
3925     const static struct dsc$descriptor_s decwdisplay_dsc =
3926       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3927
3928     struct item_list_3 items[2];
3929     unsigned short dvi_iosb[4];
3930     unsigned long devchar;
3931     unsigned long devclass;
3932     int status;
3933
3934     /* Very simple check to guess if sys$command is a decterm? */
3935     /* First see if the DECW$DISPLAY: device exists */
3936     items[0].len = 4;
3937     items[0].code = DVI$_DEVCHAR;
3938     items[0].bufadr = &devchar;
3939     items[0].retadr = NULL;
3940     items[1].len = 0;
3941     items[1].code = 0;
3942
3943     status = sys$getdviw
3944         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3945
3946     if ($VMS_STATUS_SUCCESS(status)) {
3947         status = dvi_iosb[0];
3948     }
3949
3950     if (!$VMS_STATUS_SUCCESS(status)) {
3951         SETERRNO(EVMSERR, status);
3952         return -1;
3953     }
3954
3955     /* If it does, then for now assume that we are on a workstation */
3956     /* Now verify that SYS$COMMAND is a terminal */
3957     /* for creating the debugger DECTerm */
3958
3959     items[0].len = 4;
3960     items[0].code = DVI$_DEVCLASS;
3961     items[0].bufadr = &devclass;
3962     items[0].retadr = NULL;
3963     items[1].len = 0;
3964     items[1].code = 0;
3965
3966     status = sys$getdviw
3967         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3968
3969     if ($VMS_STATUS_SUCCESS(status)) {
3970         status = dvi_iosb[0];
3971     }
3972
3973     if (!$VMS_STATUS_SUCCESS(status)) {
3974         SETERRNO(EVMSERR, status);
3975         return -1;
3976     }
3977     else {
3978         if (devclass == DC$_TERM) {
3979             return 0;
3980         }
3981     }
3982     return -1;
3983 }
3984
3985 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3986 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3987 {
3988     int status;
3989     int ret_stat;
3990     char * ret_char;
3991     char device_name[65];
3992     unsigned short device_name_len;
3993     struct dsc$descriptor_s customization_dsc;
3994     struct dsc$descriptor_s device_name_dsc;
3995     const char * cptr;
3996     char * tptr;
3997     char customization[200];
3998     char title[40];
3999     pInfo info = NULL;
4000     char mbx1[64];
4001     unsigned short p_chan;
4002     int n;
4003     unsigned short iosb[4];
4004     struct item_list_3 items[2];
4005     const char * cust_str =
4006         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
4007     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
4008                                           DSC$K_CLASS_S, mbx1};
4009
4010      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
4011     /*---------------------------------------*/
4012     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
4013
4014
4015     /* Make sure that this is from the Perl debugger */
4016     ret_char = strstr(cmd," xterm ");
4017     if (ret_char == NULL)
4018         return NULL;
4019     cptr = ret_char + 7;
4020     ret_char = strstr(cmd,"tty");
4021     if (ret_char == NULL)
4022         return NULL;
4023     ret_char = strstr(cmd,"sleep");
4024     if (ret_char == NULL)
4025         return NULL;
4026
4027     if (decw_term_port == 0) {
4028         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
4029         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
4030         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
4031
4032        status = lib$find_image_symbol
4033                                (&filename1_dsc,
4034                                 &decw_term_port_dsc,
4035                                 (void *)&decw_term_port,
4036                                 NULL,
4037                                 0);
4038
4039         /* Try again with the other image name */
4040         if (!$VMS_STATUS_SUCCESS(status)) {
4041
4042            status = lib$find_image_symbol
4043                                (&filename2_dsc,
4044                                 &decw_term_port_dsc,
4045                                 (void *)&decw_term_port,
4046                                 NULL,
4047                                 0);
4048
4049         }
4050
4051     }
4052
4053
4054     /* No decw$term_port, give it up */
4055     if (!$VMS_STATUS_SUCCESS(status))
4056         return NULL;
4057
4058     /* Are we on a workstation? */
4059     /* to do: capture the rows / columns and pass their properties */
4060     ret_stat = vms_is_syscommand_xterm();
4061     if (ret_stat < 0)
4062         return NULL;
4063
4064     /* Make the title: */
4065     ret_char = strstr(cptr,"-title");
4066     if (ret_char != NULL) {
4067         while ((*cptr != 0) && (*cptr != '\"')) {
4068             cptr++;
4069         }
4070         if (*cptr == '\"')
4071             cptr++;
4072         n = 0;
4073         while ((*cptr != 0) && (*cptr != '\"')) {
4074             title[n] = *cptr;
4075             n++;
4076             if (n == 39) {
4077                 title[39] == 0;
4078                 break;
4079             }
4080             cptr++;
4081         }
4082         title[n] = 0;
4083     }
4084     else {
4085             /* Default title */
4086             strcpy(title,"Perl Debug DECTerm");
4087     }
4088     sprintf(customization, cust_str, title);
4089
4090     customization_dsc.dsc$a_pointer = customization;
4091     customization_dsc.dsc$w_length = strlen(customization);
4092     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4093     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
4094
4095     device_name_dsc.dsc$a_pointer = device_name;
4096     device_name_dsc.dsc$w_length = sizeof device_name -1;
4097     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4098     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
4099
4100     device_name_len = 0;
4101
4102     /* Try to create the window */
4103      status = (*decw_term_port)
4104        (NULL,
4105         NULL,
4106         &customization_dsc,
4107         &device_name_dsc,
4108         &device_name_len,
4109         NULL,
4110         NULL,
4111         NULL);
4112     if (!$VMS_STATUS_SUCCESS(status)) {
4113         SETERRNO(EVMSERR, status);
4114         return NULL;
4115     }
4116
4117     device_name[device_name_len] = '\0';
4118
4119     /* Need to set this up to look like a pipe for cleanup */
4120     n = sizeof(Info);
4121     status = lib$get_vm(&n, &info);
4122     if (!$VMS_STATUS_SUCCESS(status)) {
4123         SETERRNO(ENOMEM, status);
4124         return NULL;
4125     }
4126
4127     info->mode = *mode;
4128     info->done = FALSE;
4129     info->completion = 0;
4130     info->closing    = FALSE;
4131     info->in         = 0;
4132     info->out        = 0;
4133     info->err        = 0;
4134     info->fp         = NULL;
4135     info->useFILE    = 0;
4136     info->waiting    = 0;
4137     info->in_done    = TRUE;
4138     info->out_done   = TRUE;
4139     info->err_done   = TRUE;
4140
4141     /* Assign a channel on this so that it will persist, and not login */
4142     /* We stash this channel in the info structure for reference. */
4143     /* The created xterm self destructs when the last channel is removed */
4144     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4145     /* So leave this assigned. */
4146     device_name_dsc.dsc$w_length = device_name_len;
4147     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4148     if (!$VMS_STATUS_SUCCESS(status)) {
4149         SETERRNO(EVMSERR, status);
4150         return NULL;
4151     }
4152     info->xchan_valid = 1;
4153
4154     /* Now create a mailbox to be read by the application */
4155
4156     create_mbx(&p_chan, &d_mbx1);
4157
4158     /* write the name of the created terminal to the mailbox */
4159     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4160             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4161
4162     if (!$VMS_STATUS_SUCCESS(status)) {
4163         SETERRNO(EVMSERR, status);
4164         return NULL;
4165     }
4166
4167     info->fp  = PerlIO_open(mbx1, mode);
4168
4169     /* Done with this channel */
4170     sys$dassgn(p_chan);
4171
4172     /* If any errors, then clean up */
4173     if (!info->fp) {
4174         n = sizeof(Info);
4175         _ckvmssts_noperl(lib$free_vm(&n, &info));
4176         return NULL;
4177         }
4178
4179     /* All done */
4180     return info->fp;
4181 }
4182
4183 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4184
4185 static PerlIO *
4186 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4187 {
4188     static int handler_set_up = FALSE;
4189     PerlIO * ret_fp;
4190     unsigned long int sts, flags = CLI$M_NOWAIT;
4191     /* The use of a GLOBAL table (as was done previously) rendered
4192      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4193      * environment.  Hence we've switched to LOCAL symbol table.
4194      */
4195     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4196     int j, wait = 0, n;
4197     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4198     char *in, *out, *err, mbx[512];
4199     FILE *tpipe = 0;
4200     char tfilebuf[NAM$C_MAXRSS+1];
4201     pInfo info = NULL;
4202     char cmd_sym_name[20];
4203     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4204                                       DSC$K_CLASS_S, symbol};
4205     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4206                                       DSC$K_CLASS_S, 0};
4207     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4208                                       DSC$K_CLASS_S, cmd_sym_name};
4209     struct dsc$descriptor_s *vmscmd;
4210     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4211     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4212     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4213
4214     /* Check here for Xterm create request.  This means looking for
4215      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4216      *  is possible to create an xterm.
4217      */
4218     if (*in_mode == 'r') {
4219         PerlIO * xterm_fd;
4220
4221         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4222         if (xterm_fd != NULL)
4223             return xterm_fd;
4224     }
4225
4226     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4227
4228     /* once-per-program initialization...
4229        note that the SETAST calls and the dual test of pipe_ef
4230        makes sure that only the FIRST thread through here does
4231        the initialization...all other threads wait until it's
4232        done.
4233
4234        Yeah, uglier than a pthread call, it's got all the stuff inline
4235        rather than in a separate routine.
4236     */
4237
4238     if (!pipe_ef) {
4239         _ckvmssts_noperl(sys$setast(0));
4240         if (!pipe_ef) {
4241             unsigned long int pidcode = JPI$_PID;
4242             $DESCRIPTOR(d_delay, RETRY_DELAY);
4243             _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4244             _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4245             _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4246         }
4247         if (!handler_set_up) {
4248           _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4249           handler_set_up = TRUE;
4250         }
4251         _ckvmssts_noperl(sys$setast(1));
4252     }
4253
4254     /* see if we can find a VMSPIPE.COM */
4255
4256     tfilebuf[0] = '@';
4257     vmspipe = find_vmspipe(aTHX);
4258     if (vmspipe) {
4259         strcpy(tfilebuf+1,vmspipe);
4260     } else {        /* uh, oh...we're in tempfile hell */
4261         tpipe = vmspipe_tempfile(aTHX);
4262         if (!tpipe) {       /* a fish popular in Boston */
4263             if (ckWARN(WARN_PIPE)) {
4264                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4265             }
4266         return NULL;
4267         }
4268         fgetname(tpipe,tfilebuf+1,1);
4269     }
4270     vmspipedsc.dsc$a_pointer = tfilebuf;
4271     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4272
4273     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4274     if (!(sts & 1)) {
4275       switch (sts) {
4276         case RMS$_FNF:  case RMS$_DNF:
4277           set_errno(ENOENT); break;
4278         case RMS$_DIR:
4279           set_errno(ENOTDIR); break;
4280         case RMS$_DEV:
4281           set_errno(ENODEV); break;
4282         case RMS$_PRV:
4283           set_errno(EACCES); break;
4284         case RMS$_SYN:
4285           set_errno(EINVAL); break;
4286         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4287           set_errno(E2BIG); break;
4288         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4289           _ckvmssts_noperl(sts); /* fall through */
4290         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4291           set_errno(EVMSERR);
4292       }
4293       set_vaxc_errno(sts);
4294       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4295         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4296       }
4297       *psts = sts;
4298       return NULL;
4299     }
4300     n = sizeof(Info);
4301     _ckvmssts_noperl(lib$get_vm(&n, &info));
4302
4303     strcpy(mode,in_mode);
4304     info->mode = *mode;
4305     info->done = FALSE;
4306     info->completion = 0;
4307     info->closing    = FALSE;
4308     info->in         = 0;
4309     info->out        = 0;
4310     info->err        = 0;
4311     info->fp         = NULL;
4312     info->useFILE    = 0;
4313     info->waiting    = 0;
4314     info->in_done    = TRUE;
4315     info->out_done   = TRUE;
4316     info->err_done   = TRUE;
4317     info->xchan      = 0;
4318     info->xchan_valid = 0;
4319
4320     in = PerlMem_malloc(VMS_MAXRSS);
4321     if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4322     out = PerlMem_malloc(VMS_MAXRSS);
4323     if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4324     err = PerlMem_malloc(VMS_MAXRSS);
4325     if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4326
4327     in[0] = out[0] = err[0] = '\0';
4328
4329     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4330         info->useFILE = 1;
4331         strcpy(p,p+1);
4332     }
4333     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4334         wait = 1;
4335         strcpy(p,p+1);
4336     }
4337
4338     if (*mode == 'r') {             /* piping from subroutine */
4339
4340         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4341         if (info->out) {
4342             info->out->pipe_done = &info->out_done;
4343             info->out_done = FALSE;
4344             info->out->info = info;
4345         }
4346         if (!info->useFILE) {
4347             info->fp  = PerlIO_open(mbx, mode);
4348         } else {
4349             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4350             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4351         }
4352
4353         if (!info->fp && info->out) {
4354             sys$cancel(info->out->chan_out);
4355
4356             while (!info->out_done) {
4357                 int done;
4358                 _ckvmssts_noperl(sys$setast(0));
4359                 done = info->out_done;
4360                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4361                 _ckvmssts_noperl(sys$setast(1));
4362                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4363             }
4364
4365             if (info->out->buf) {
4366                 n = info->out->bufsize * sizeof(char);
4367                 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4368             }
4369             n = sizeof(Pipe);
4370             _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4371             n = sizeof(Info);
4372             _ckvmssts_noperl(lib$free_vm(&n, &info));
4373             *psts = RMS$_FNF;
4374             return NULL;
4375         }
4376
4377         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4378         if (info->err) {
4379             info->err->pipe_done = &info->err_done;
4380             info->err_done = FALSE;
4381             info->err->info = info;
4382         }
4383
4384     } else if (*mode == 'w') {      /* piping to subroutine */
4385
4386         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4387         if (info->out) {
4388             info->out->pipe_done = &info->out_done;
4389             info->out_done = FALSE;
4390             info->out->info = info;
4391         }
4392
4393         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4394         if (info->err) {
4395             info->err->pipe_done = &info->err_done;
4396             info->err_done = FALSE;
4397             info->err->info = info;
4398         }
4399
4400         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4401         if (!info->useFILE) {
4402             info->fp  = PerlIO_open(mbx, mode);
4403         } else {
4404             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4405             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4406         }
4407
4408         if (info->in) {
4409             info->in->pipe_done = &info->in_done;
4410             info->in_done = FALSE;
4411             info->in->info = info;
4412         }
4413
4414         /* error cleanup */
4415         if (!info->fp && info->in) {
4416             info->done = TRUE;
4417             _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4418                                       0, 0, 0, 0, 0, 0, 0, 0));
4419
4420             while (!info->in_done) {
4421                 int done;
4422                 _ckvmssts_noperl(sys$setast(0));
4423                 done = info->in_done;
4424                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4425                 _ckvmssts_noperl(sys$setast(1));
4426                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4427             }
4428
4429             if (info->in->buf) {
4430                 n = info->in->bufsize * sizeof(char);
4431                 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4432             }
4433             n = sizeof(Pipe);
4434             _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4435             n = sizeof(Info);
4436             _ckvmssts_noperl(lib$free_vm(&n, &info));
4437             *psts = RMS$_FNF;
4438             return NULL;
4439         }
4440
4441
4442     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4443         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4444         if (info->out) {
4445             info->out->pipe_done = &info->out_done;
4446             info->out_done = FALSE;
4447             info->out->info = info;
4448         }
4449
4450         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4451         if (info->err) {
4452             info->err->pipe_done = &info->err_done;
4453             info->err_done = FALSE;
4454             info->err->info = info;
4455         }
4456     }
4457
4458     symbol[MAX_DCL_SYMBOL] = '\0';
4459
4460     strncpy(symbol, in, MAX_DCL_SYMBOL);
4461     d_symbol.dsc$w_length = strlen(symbol);
4462     _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4463
4464     strncpy(symbol, err, MAX_DCL_SYMBOL);
4465     d_symbol.dsc$w_length = strlen(symbol);
4466     _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4467
4468     strncpy(symbol, out, MAX_DCL_SYMBOL);
4469     d_symbol.dsc$w_length = strlen(symbol);
4470     _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4471
4472     /* Done with the names for the pipes */
4473     PerlMem_free(err);
4474     PerlMem_free(out);
4475     PerlMem_free(in);
4476
4477     p = vmscmd->dsc$a_pointer;
4478     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4479     if (*p == '$') p++;                         /* remove leading $ */
4480     while (*p == ' ' || *p == '\t') p++;
4481
4482     for (j = 0; j < 4; j++) {
4483         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4484         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4485
4486     strncpy(symbol, p, MAX_DCL_SYMBOL);
4487     d_symbol.dsc$w_length = strlen(symbol);
4488     _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4489
4490         if (strlen(p) > MAX_DCL_SYMBOL) {
4491             p += MAX_DCL_SYMBOL;
4492         } else {
4493             p += strlen(p);
4494         }
4495     }
4496     _ckvmssts_noperl(sys$setast(0));
4497     info->next=open_pipes;  /* prepend to list */
4498     open_pipes=info;
4499     _ckvmssts_noperl(sys$setast(1));
4500     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4501      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4502      * have SYS$COMMAND if we need it.
4503      */
4504     _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4505                       0, &info->pid, &info->completion,
4506                       0, popen_completion_ast,info,0,0,0));
4507
4508     /* if we were using a tempfile, close it now */
4509
4510     if (tpipe) fclose(tpipe);
4511
4512     /* once the subprocess is spawned, it has copied the symbols and
4513        we can get rid of ours */
4514
4515     for (j = 0; j < 4; j++) {
4516         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4517         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4518     _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4519     }
4520     _ckvmssts_noperl(lib$delete_symbol(&d_sym_in,  &table));
4521     _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4522     _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4523     vms_execfree(vmscmd);
4524
4525 #ifdef PERL_IMPLICIT_CONTEXT
4526     if (aTHX)
4527 #endif
4528     PL_forkprocess = info->pid;
4529
4530     ret_fp = info->fp;
4531     if (wait) {
4532          dSAVEDERRNO;
4533          int done = 0;
4534          while (!done) {
4535              _ckvmssts_noperl(sys$setast(0));
4536              done = info->done;
4537              if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4538              _ckvmssts_noperl(sys$setast(1));
4539              if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4540          }
4541         *psts = info->completion;
4542 /* Caller thinks it is open and tries to close it. */
4543 /* This causes some problems, as it changes the error status */
4544 /*        my_pclose(info->fp); */
4545
4546          /* If we did not have a file pointer open, then we have to */
4547          /* clean up here or eventually we will run out of something */
4548          SAVE_ERRNO;
4549          if (info->fp == NULL) {
4550              my_pclose_pinfo(aTHX_ info);
4551          }
4552          RESTORE_ERRNO;
4553
4554     } else {
4555         *psts = info->pid;
4556     }
4557     return ret_fp;
4558 }  /* end of safe_popen */
4559
4560
4561 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4562 PerlIO *
4563 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4564 {
4565     int sts;
4566     TAINT_ENV();
4567     TAINT_PROPER("popen");
4568     PERL_FLUSHALL_FOR_CHILD;
4569     return safe_popen(aTHX_ cmd,mode,&sts);
4570 }
4571
4572 /*}}}*/
4573
4574
4575 /* Routine to close and cleanup a pipe info structure */
4576
4577 static I32 my_pclose_pinfo(pTHX_ pInfo info) {
4578
4579     unsigned long int retsts;
4580     int done, iss, n;
4581     int status;
4582     pInfo next, last;
4583
4584     /* If we were writing to a subprocess, insure that someone reading from
4585      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4586      * produce an EOF record in the mailbox.
4587      *
4588      *  well, at least sometimes it *does*, so we have to watch out for
4589      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4590      */
4591      if (info->fp) {
4592         if (!info->useFILE
4593 #if defined(USE_ITHREADS)
4594           && my_perl
4595 #endif
4596           && PL_perlio_fd_refcnt)
4597             PerlIO_flush(info->fp);
4598         else
4599             fflush((FILE *)info->fp);
4600     }
4601
4602     _ckvmssts(sys$setast(0));
4603      info->closing = TRUE;
4604      done = info->done && info->in_done && info->out_done && info->err_done;
4605      /* hanging on write to Perl's input? cancel it */
4606      if (info->mode == 'r' && info->out && !info->out_done) {
4607         if (info->out->chan_out) {
4608             _ckvmssts(sys$cancel(info->out->chan_out));
4609             if (!info->out->chan_in) {   /* EOF generation, need AST */
4610                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4611             }
4612         }
4613      }
4614      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4615          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4616                            0, 0, 0, 0, 0, 0));
4617     _ckvmssts(sys$setast(1));
4618     if (info->fp) {
4619      if (!info->useFILE
4620 #if defined(USE_ITHREADS)
4621          && my_perl
4622 #endif
4623          && PL_perlio_fd_refcnt)
4624         PerlIO_close(info->fp);
4625      else
4626         fclose((FILE *)info->fp);
4627     }
4628      /*
4629         we have to wait until subprocess completes, but ALSO wait until all
4630         the i/o completes...otherwise we'll be freeing the "info" structure
4631         that the i/o ASTs could still be using...
4632      */
4633
4634      while (!done) {
4635          _ckvmssts(sys$setast(0));
4636          done = info->done && info->in_done && info->out_done && info->err_done;
4637          if (!done) _ckvmssts(sys$clref(pipe_ef));
4638          _ckvmssts(sys$setast(1));
4639          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4640      }
4641      retsts = info->completion;
4642
4643     /* remove from list of open pipes */
4644     _ckvmssts(sys$setast(0));
4645     last = NULL;
4646     for (next = open_pipes; next != NULL; last = next, next = next->next) {
4647         if (next == info)
4648             break;
4649     }
4650
4651     if (last)
4652         last->next = info->next;
4653     else
4654         open_pipes = info->next;
4655     _ckvmssts(sys$setast(1));
4656
4657     /* free buffers and structures */
4658
4659     if (info->in) {
4660         if (info->in->buf) {
4661             n = info->in->bufsize * sizeof(char);
4662             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4663         }
4664         n = sizeof(Pipe);
4665         _ckvmssts(lib$free_vm(&n, &info->in));
4666     }
4667     if (info->out) {
4668         if (info->out->buf) {
4669             n = info->out->bufsize * sizeof(char);
4670             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4671         }
4672         n = sizeof(Pipe);
4673         _ckvmssts(lib$free_vm(&n, &info->out));
4674     }
4675     if (info->err) {
4676         if (info->err->buf) {
4677             n = info->err->bufsize * sizeof(char);
4678             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4679         }
4680         n = sizeof(Pipe);
4681         _ckvmssts(lib$free_vm(&n, &info->err));
4682     }
4683     n = sizeof(Info);
4684     _ckvmssts(lib$free_vm(&n, &info));
4685
4686     return retsts;
4687 }
4688
4689
4690 /*{{{  I32 my_pclose(PerlIO *fp)*/
4691 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4692 {
4693     pInfo info, last = NULL;
4694     I32 ret_status;
4695
4696     /* Fixme - need ast and mutex protection here */
4697     for (info = open_pipes; info != NULL; last = info, info = info->next)
4698         if (info->fp == fp) break;
4699
4700     if (info == NULL) {  /* no such pipe open */
4701       set_errno(ECHILD); /* quoth POSIX */
4702       set_vaxc_errno(SS$_NONEXPR);
4703       return -1;
4704     }
4705
4706     ret_status = my_pclose_pinfo(aTHX_ info);
4707
4708     return ret_status;
4709
4710 }  /* end of my_pclose() */
4711
4712 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4713   /* Roll our own prototype because we want this regardless of whether
4714    * _VMS_WAIT is defined.
4715    */
4716   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4717 #endif
4718 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4719    created with popen(); otherwise partially emulate waitpid() unless
4720    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4721    Also check processes not considered by the CRTL waitpid().
4722  */
4723 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4724 Pid_t
4725 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4726 {
4727     pInfo info;
4728     int done;
4729     int sts;
4730     int j;
4731
4732     if (statusp) *statusp = 0;
4733
4734     for (info = open_pipes; info != NULL; info = info->next)
4735         if (info->pid == pid) break;
4736
4737     if (info != NULL) {  /* we know about this child */
4738       while (!info->done) {
4739           _ckvmssts(sys$setast(0));
4740           done = info->done;
4741           if (!done) _ckvmssts(sys$clref(pipe_ef));
4742           _ckvmssts(sys$setast(1));
4743           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4744       }
4745
4746       if (statusp) *statusp = info->completion;
4747       return pid;
4748     }
4749
4750     /* child that already terminated? */
4751
4752     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4753         if (closed_list[j].pid == pid) {
4754             if (statusp) *statusp = closed_list[j].completion;
4755             return pid;
4756         }
4757     }
4758
4759     /* fall through if this child is not one of our own pipe children */
4760
4761 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4762
4763       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4764        * in 7.2 did we get a version that fills in the VMS completion
4765        * status as Perl has always tried to do.
4766        */
4767
4768       sts = __vms_waitpid( pid, statusp, flags );
4769
4770       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4771          return sts;
4772
4773       /* If the real waitpid tells us the child does not exist, we
4774        * fall through here to implement waiting for a child that
4775        * was created by some means other than exec() (say, spawned
4776        * from DCL) or to wait for a process that is not a subprocess
4777        * of the current process.
4778        */
4779
4780 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4781
4782     {
4783       $DESCRIPTOR(intdsc,"0 00:00:01");
4784       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4785       unsigned long int pidcode = JPI$_PID, mypid;
4786       unsigned long int interval[2];
4787       unsigned int jpi_iosb[2];
4788       struct itmlst_3 jpilist[2] = {
4789           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4790           {                      0,         0,                 0, 0}
4791       };
4792
4793       if (pid <= 0) {
4794         /* Sorry folks, we don't presently implement rooting around for
4795            the first child we can find, and we definitely don't want to
4796            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4797          */
4798         set_errno(ENOTSUP);
4799         return -1;
4800       }
4801
4802       /* Get the owner of the child so I can warn if it's not mine. If the
4803        * process doesn't exist or I don't have the privs to look at it,
4804        * I can go home early.
4805        */
4806       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4807       if (sts & 1) sts = jpi_iosb[0];
4808       if (!(sts & 1)) {
4809         switch (sts) {
4810             case SS$_NONEXPR:
4811                 set_errno(ECHILD);
4812                 break;
4813             case SS$_NOPRIV:
4814                 set_errno(EACCES);
4815                 break;
4816             default:
4817                 _ckvmssts(sts);
4818         }
4819         set_vaxc_errno(sts);
4820         return -1;
4821       }
4822
4823       if (ckWARN(WARN_EXEC)) {
4824         /* remind folks they are asking for non-standard waitpid behavior */
4825         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4826         if (ownerpid != mypid)
4827           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4828                       "waitpid: process %x is not a child of process %x",
4829                       pid,mypid);
4830       }
4831
4832       /* simply check on it once a second until it's not there anymore. */
4833
4834       _ckvmssts(sys$bintim(&intdsc,interval));
4835       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4836             _ckvmssts(sys$schdwk(0,0,interval,0));
4837             _ckvmssts(sys$hiber());
4838       }
4839       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4840
4841       _ckvmssts(sts);
4842       return pid;
4843     }
4844 }  /* end of waitpid() */
4845 /*}}}*/
4846 /*}}}*/
4847 /*}}}*/
4848
4849 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4850 char *
4851 my_gconvert(double val, int ndig, int trail, char *buf)
4852 {
4853   static char __gcvtbuf[DBL_DIG+1];
4854   char *loc;
4855
4856   loc = buf ? buf : __gcvtbuf;
4857
4858 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4859   if (val < 1) {
4860     sprintf(loc,"%.*g",ndig,val);
4861     return loc;
4862   }
4863 #endif
4864
4865   if (val) {
4866     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4867     return gcvt(val,ndig,loc);
4868   }
4869   else {
4870     loc[0] = '0'; loc[1] = '\0';
4871     return loc;
4872   }
4873
4874 }
4875 /*}}}*/
4876
4877 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4878 static int rms_free_search_context(struct FAB * fab)
4879 {
4880 struct NAM * nam;
4881
4882     nam = fab->fab$l_nam;
4883     nam->nam$b_nop |= NAM$M_SYNCHK;
4884     nam->nam$l_rlf = NULL;
4885     fab->fab$b_dns = 0;
4886     return sys$parse(fab, NULL, NULL);
4887 }
4888
4889 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4890 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4891 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4892 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4893 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4894 #define rms_nam_esll(nam) nam.nam$b_esl
4895 #define rms_nam_esl(nam) nam.nam$b_esl
4896 #define rms_nam_name(nam) nam.nam$l_name
4897 #define rms_nam_namel(nam) nam.nam$l_name
4898 #define rms_nam_type(nam) nam.nam$l_type
4899 #define rms_nam_typel(nam) nam.nam$l_type
4900 #define rms_nam_ver(nam) nam.nam$l_ver
4901 #define rms_nam_verl(nam) nam.nam$l_ver
4902 #define rms_nam_rsll(nam) nam.nam$b_rsl
4903 #define rms_nam_rsl(nam) nam.nam$b_rsl
4904 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4905 #define rms_set_fna(fab, nam, name, size) \
4906         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4907 #define rms_get_fna(fab, nam) fab.fab$l_fna
4908 #define rms_set_dna(fab, nam, name, size) \
4909         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4910 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4911 #define rms_set_esa(nam, name, size) \
4912         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4913 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4914         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4915 #define rms_set_rsa(nam, name, size) \
4916         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4917 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4918         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4919 #define rms_nam_name_type_l_size(nam) \
4920         (nam.nam$b_name + nam.nam$b_type)
4921 #else
4922 static int rms_free_search_context(struct FAB * fab)
4923 {
4924 struct NAML * nam;
4925
4926     nam = fab->fab$l_naml;
4927     nam->naml$b_nop |= NAM$M_SYNCHK;
4928     nam->naml$l_rlf = NULL;
4929     nam->naml$l_long_defname_size = 0;
4930
4931     fab->fab$b_dns = 0;
4932     return sys$parse(fab, NULL, NULL);
4933 }
4934
4935 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4936 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4937 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4938 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4939 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4940 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4941 #define rms_nam_esl(nam) nam.naml$b_esl
4942 #define rms_nam_name(nam) nam.naml$l_name
4943 #define rms_nam_namel(nam) nam.naml$l_long_name
4944 #define rms_nam_type(nam) nam.naml$l_type
4945 #define rms_nam_typel(nam) nam.naml$l_long_type
4946 #define rms_nam_ver(nam) nam.naml$l_ver
4947 #define rms_nam_verl(nam) nam.naml$l_long_ver
4948 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4949 #define rms_nam_rsl(nam) nam.naml$b_rsl
4950 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4951 #define rms_set_fna(fab, nam, name, size) \
4952         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4953         nam.naml$l_long_filename_size = size; \
4954         nam.naml$l_long_filename = name;}
4955 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4956 #define rms_set_dna(fab, nam, name, size) \
4957         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4958         nam.naml$l_long_defname_size = size; \
4959         nam.naml$l_long_defname = name; }
4960 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4961 #define rms_set_esa(nam, name, size) \
4962         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4963         nam.naml$l_long_expand_alloc = size; \
4964         nam.naml$l_long_expand = name; }
4965 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4966         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4967         nam.naml$l_long_expand = l_name; \
4968         nam.naml$l_long_expand_alloc = l_size; }
4969 #define rms_set_rsa(nam, name, size) \
4970         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4971         nam.naml$l_long_result = name; \
4972         nam.naml$l_long_result_alloc = size; }
4973 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4974         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4975         nam.naml$l_long_result = l_name; \
4976         nam.naml$l_long_result_alloc = l_size; }
4977 #define rms_nam_name_type_l_size(nam) \
4978         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4979 #endif
4980
4981
4982 /* rms_erase
4983  * The CRTL for 8.3 and later can create symbolic links in any mode,
4984  * however in 8.3 the unlink/remove/delete routines will only properly handle
4985  * them if one of the PCP modes is active.
4986  */
4987 static int rms_erase(const char * vmsname)
4988 {
4989   int status;
4990   struct FAB myfab = cc$rms_fab;
4991   rms_setup_nam(mynam);
4992
4993   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4994   rms_bind_fab_nam(myfab, mynam);
4995
4996   /* Are we removing all versions? */
4997   if (vms_unlink_all_versions == 1) {
4998     const char * defspec = ";*";
4999     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
5000   }
5001
5002 #ifdef NAML$M_OPEN_SPECIAL
5003   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5004 #endif
5005
5006   status = sys$erase(&myfab, 0, 0);
5007
5008   return status;
5009 }
5010
5011
5012 static int
5013 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
5014                     const struct dsc$descriptor_s * vms_dst_dsc,
5015                     unsigned long flags)
5016 {
5017     /*  VMS and UNIX handle file permissions differently and the
5018      * the same ACL trick may be needed for renaming files,
5019      * especially if they are directories.
5020      */
5021
5022    /* todo: get kill_file and rename to share common code */
5023    /* I can not find online documentation for $change_acl
5024     * it appears to be replaced by $set_security some time ago */
5025
5026 const unsigned int access_mode = 0;
5027 $DESCRIPTOR(obj_file_dsc,"FILE");
5028 char *vmsname;
5029 char *rslt;
5030 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
5031 int aclsts, fndsts, rnsts = -1;
5032 unsigned int ctx = 0;
5033 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5034 struct dsc$descriptor_s * clean_dsc;
5035
5036 struct myacedef {
5037     unsigned char myace$b_length;
5038     unsigned char myace$b_type;
5039     unsigned short int myace$w_flags;
5040     unsigned long int myace$l_access;
5041     unsigned long int myace$l_ident;
5042 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
5043              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
5044              0},
5045              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
5046
5047 struct item_list_3
5048         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
5049                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
5050                       {0,0,0,0}},
5051         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
5052         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
5053                      {0,0,0,0}};
5054
5055
5056     /* Expand the input spec using RMS, since we do not want to put
5057      * ACLs on the target of a symbolic link */
5058     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
5059     if (vmsname == NULL)
5060         return SS$_INSFMEM;
5061
5062     rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
5063                         vmsname,
5064                         PERL_RMSEXPAND_M_SYMLINK);
5065     if (rslt == NULL) {
5066         PerlMem_free(vmsname);
5067         return SS$_INSFMEM;
5068     }
5069
5070     /* So we get our own UIC to use as a rights identifier,
5071      * and the insert an ACE at the head of the ACL which allows us
5072      * to delete the file.
5073      */
5074     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
5075
5076     fildsc.dsc$w_length = strlen(vmsname);
5077     fildsc.dsc$a_pointer = vmsname;
5078     ctx = 0;
5079     newace.myace$l_ident = oldace.myace$l_ident;
5080     rnsts = SS$_ABORT;
5081
5082     /* Grab any existing ACEs with this identifier in case we fail */
5083     clean_dsc = &fildsc;
5084     aclsts = fndsts = sys$get_security(&obj_file_dsc,
5085                                &fildsc,
5086                                NULL,
5087                                OSS$M_WLOCK,
5088                                findlst,
5089                                &ctx,
5090                                &access_mode);
5091
5092     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
5093         /* Add the new ACE . . . */
5094
5095         /* if the sys$get_security succeeded, then ctx is valid, and the
5096          * object/file descriptors will be ignored.  But otherwise they
5097          * are needed
5098          */
5099         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
5100                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
5101         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5102             set_errno(EVMSERR);
5103             set_vaxc_errno(aclsts);
5104             PerlMem_free(vmsname);
5105             return aclsts;
5106         }
5107
5108         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5109                                 NULL, NULL,
5110                                 &flags,
5111                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5112
5113         if ($VMS_STATUS_SUCCESS(rnsts)) {
5114             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5115         }
5116
5117         /* Put things back the way they were. */
5118         ctx = 0;
5119         aclsts = sys$get_security(&obj_file_dsc,
5120                                   clean_dsc,
5121                                   NULL,
5122                                   OSS$M_WLOCK,
5123                                   findlst,
5124                                   &ctx,
5125                                   &access_mode);
5126
5127         if ($VMS_STATUS_SUCCESS(aclsts)) {
5128         int sec_flags;
5129
5130             sec_flags = 0;
5131             if (!$VMS_STATUS_SUCCESS(fndsts))
5132                 sec_flags = OSS$M_RELCTX;
5133
5134             /* Get rid of the new ACE */
5135             aclsts = sys$set_security(NULL, NULL, NULL,
5136                                   sec_flags, dellst, &ctx, &access_mode);
5137
5138             /* If there was an old ACE, put it back */
5139             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5140                 addlst[0].bufadr = &oldace;
5141                 aclsts = sys$set_security(NULL, NULL, NULL,
5142                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
5143                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5144                     set_errno(EVMSERR);
5145                     set_vaxc_errno(aclsts);
5146                     rnsts = aclsts;
5147                 }
5148             } else {
5149             int aclsts2;
5150
5151                 /* Try to clear the lock on the ACL list */
5152                 aclsts2 = sys$set_security(NULL, NULL, NULL,
5153                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
5154
5155                 /* Rename errors are most important */
5156                 if (!$VMS_STATUS_SUCCESS(rnsts))
5157                     aclsts = rnsts;
5158                 set_errno(EVMSERR);
5159                 set_vaxc_errno(aclsts);
5160                 rnsts = aclsts;
5161             }
5162         }
5163         else {
5164             if (aclsts != SS$_ACLEMPTY)
5165                 rnsts = aclsts;
5166         }
5167     }
5168     else
5169         rnsts = fndsts;
5170
5171     PerlMem_free(vmsname);
5172     return rnsts;
5173 }
5174
5175
5176 /*{{{int rename(const char *, const char * */
5177 /* Not exactly what X/Open says to do, but doing it absolutely right
5178  * and efficiently would require a lot more work.  This should be close
5179  * enough to pass all but the most strict X/Open compliance test.
5180  */
5181 int
5182 Perl_rename(pTHX_ const char *src, const char * dst)
5183 {
5184 int retval;
5185 int pre_delete = 0;
5186 int src_sts;
5187 int dst_sts;
5188 Stat_t src_st;
5189 Stat_t dst_st;
5190
5191     /* Validate the source file */
5192     src_sts = flex_lstat(src, &src_st);
5193     if (src_sts != 0) {
5194
5195         /* No source file or other problem */
5196         return src_sts;
5197     }
5198
5199     dst_sts = flex_lstat(dst, &dst_st);
5200     if (dst_sts == 0) {
5201
5202         if (dst_st.st_dev != src_st.st_dev) {
5203             /* Must be on the same device */
5204             errno = EXDEV;
5205             return -1;
5206         }
5207
5208         /* VMS_INO_T_COMPARE is true if the inodes are different
5209          * to match the output of memcmp
5210          */
5211
5212         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5213             /* That was easy, the files are the same! */
5214             return 0;
5215         }
5216
5217         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5218             /* If source is a directory, so must be dest */
5219                 errno = EISDIR;
5220                 return -1;
5221         }
5222
5223     }
5224
5225
5226     if ((dst_sts == 0) &&
5227         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5228
5229         /* We have issues here if vms_unlink_all_versions is set
5230          * If the destination exists, and is not a directory, then
5231          * we must delete in advance.
5232          *
5233          * If the src is a directory, then we must always pre-delete
5234          * the destination.
5235          *
5236          * If we successfully delete the dst in advance, and the rename fails
5237          * X/Open requires that errno be EIO.
5238          *
5239          */
5240
5241         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5242             int d_sts;
5243             d_sts = mp_do_kill_file(aTHX_ dst, S_ISDIR(dst_st.st_mode));
5244             if (d_sts != 0)
5245                 return d_sts;
5246
5247             /* We killed the destination, so only errno now is EIO */
5248             pre_delete = 1;
5249         }
5250     }
5251
5252     /* Originally the idea was to call the CRTL rename() and only
5253      * try the lib$rename_file if it failed.
5254      * It turns out that there are too many variants in what the
5255      * the CRTL rename might do, so only use lib$rename_file
5256      */
5257     retval = -1;
5258
5259     {
5260         /* Is the source and dest both in VMS format */
5261         /* if the source is a directory, then need to fileify */
5262         /*  and dest must be a directory or non-existant. */
5263
5264         char * vms_src;
5265         char * vms_dst;
5266         int sts;
5267         char * ret_str;
5268         unsigned long flags;
5269         struct dsc$descriptor_s old_file_dsc;
5270         struct dsc$descriptor_s new_file_dsc;
5271
5272         /* We need to modify the src and dst depending
5273          * on if one or more of them are directories.
5274          */
5275
5276         vms_src = PerlMem_malloc(VMS_MAXRSS);
5277         if (vms_src == NULL)
5278             _ckvmssts_noperl(SS$_INSFMEM);
5279
5280         /* Source is always a VMS format file */
5281         ret_str = do_tovmsspec(src, vms_src, 0, NULL);
5282         if (ret_str == NULL) {
5283             PerlMem_free(vms_src);
5284             errno = EIO;
5285             return -1;
5286         }
5287
5288         vms_dst = PerlMem_malloc(VMS_MAXRSS);
5289         if (vms_dst == NULL)
5290             _ckvmssts_noperl(SS$_INSFMEM);
5291
5292         if (S_ISDIR(src_st.st_mode)) {
5293         char * ret_str;
5294         char * vms_dir_file;
5295
5296             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5297             if (vms_dir_file == NULL)
5298                 _ckvmssts_noperl(SS$_INSFMEM);
5299
5300             /* The source must be a file specification */
5301             ret_str = do_fileify_dirspec(vms_src, vms_dir_file, 0, NULL);
5302             if (ret_str == NULL) {
5303                 PerlMem_free(vms_src);
5304                 PerlMem_free(vms_dst);
5305                 PerlMem_free(vms_dir_file);
5306                 errno = EIO;
5307                 return -1;
5308             }
5309             PerlMem_free(vms_src);
5310             vms_src = vms_dir_file;
5311
5312             /* If the dest is a directory, we must remove it
5313             if (dst_sts == 0) {
5314                 int d_sts;
5315                 d_sts = mp_do_kill_file(aTHX_ dst, 1);
5316                 if (d_sts != 0) {
5317                     PerlMem_free(vms_src);
5318                     PerlMem_free(vms_dst);
5319                     errno = EIO;
5320                     return sts;
5321                 }
5322
5323                 pre_delete = 1;
5324             }
5325
5326            /* The dest must be a VMS file specification */
5327            ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5328            if (ret_str == NULL) {
5329                 PerlMem_free(vms_src);
5330                 PerlMem_free(vms_dst);
5331                 errno = EIO;
5332                 return -1;
5333            }
5334
5335             /* The source must be a file specification */
5336             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5337             if (vms_dir_file == NULL)
5338                 _ckvmssts_noperl(SS$_INSFMEM);
5339
5340             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5341             if (ret_str == NULL) {
5342                 PerlMem_free(vms_src);
5343                 PerlMem_free(vms_dst);
5344                 PerlMem_free(vms_dir_file);
5345                 errno = EIO;
5346                 return -1;
5347             }
5348             PerlMem_free(vms_dst);
5349             vms_dst = vms_dir_file;
5350
5351         } else {
5352             /* File to file or file to new dir */
5353
5354             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5355                 /* VMS pathify a dir target */
5356                 ret_str = do_tovmspath(dst, vms_dst, 0, NULL);
5357                 if (ret_str == NULL) {
5358                     PerlMem_free(vms_src);
5359                     PerlMem_free(vms_dst);
5360                     errno = EIO;
5361                     return -1;
5362                 }
5363             } else {
5364
5365                 /* fileify a target VMS file specification */
5366                 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5367                 if (ret_str == NULL) {
5368                     PerlMem_free(vms_src);
5369                     PerlMem_free(vms_dst);
5370                     errno = EIO;
5371                     return -1;
5372                 }
5373             }
5374         }
5375
5376         old_file_dsc.dsc$a_pointer = vms_src;
5377         old_file_dsc.dsc$w_length = strlen(vms_src);
5378         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5379         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5380
5381         new_file_dsc.dsc$a_pointer = vms_dst;
5382         new_file_dsc.dsc$w_length = strlen(vms_dst);
5383         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5384         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5385
5386         flags = 0;
5387 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5388         flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5389 #endif
5390
5391         sts = lib$rename_file(&old_file_dsc,
5392                               &new_file_dsc,
5393                               NULL, NULL,
5394                               &flags,
5395                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5396         if (!$VMS_STATUS_SUCCESS(sts)) {
5397
5398            /* We could have failed because VMS style permissions do not
5399             * permit renames that UNIX will allow.  Just like the hack
5400             * in for kill_file.
5401             */
5402            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5403         }
5404
5405         PerlMem_free(vms_src);
5406         PerlMem_free(vms_dst);
5407         if (!$VMS_STATUS_SUCCESS(sts)) {
5408             errno = EIO;
5409             return -1;
5410         }
5411         retval = 0;
5412     }
5413
5414     if (vms_unlink_all_versions) {
5415         /* Now get rid of any previous versions of the source file that
5416          * might still exist
5417          */
5418         int save_errno;
5419         save_errno = errno;
5420         src_sts = mp_do_kill_file(aTHX_ src, S_ISDIR(src_st.st_mode));
5421         errno = save_errno;
5422     }
5423
5424     /* We deleted the destination, so must force the error to be EIO */
5425     if ((retval != 0) && (pre_delete != 0))
5426         errno = EIO;
5427
5428     return retval;
5429 }
5430 /*}}}*/
5431
5432
5433 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5434 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5435  * to expand file specification.  Allows for a single default file
5436  * specification and a simple mask of options.  If outbuf is non-NULL,
5437  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5438  * the resultant file specification is placed.  If outbuf is NULL, the
5439  * resultant file specification is placed into a static buffer.
5440  * The third argument, if non-NULL, is taken to be a default file
5441  * specification string.  The fourth argument is unused at present.
5442  * rmesexpand() returns the address of the resultant string if
5443  * successful, and NULL on error.
5444  *
5445  * New functionality for previously unused opts value:
5446  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5447  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5448  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5449  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5450  */
5451 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5452
5453 static char *
5454 int_rmsexpand
5455    (const char *filespec,
5456     char *outbuf,
5457     const char *defspec,
5458     unsigned opts,
5459     int * fs_utf8,
5460     int * dfs_utf8)
5461 {
5462   char * ret_spec;
5463   const char * in_spec;
5464   char * spec_buf;
5465   const char * def_spec;
5466   char * vmsfspec, *vmsdefspec;
5467   char * esa;
5468   char * esal = NULL;
5469   char * outbufl;
5470   struct FAB myfab = cc$rms_fab;
5471   rms_setup_nam(mynam);
5472   STRLEN speclen;
5473   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5474   int sts;
5475
5476   /* temp hack until UTF8 is actually implemented */
5477   if (fs_utf8 != NULL)
5478     *fs_utf8 = 0;
5479
5480   if (!filespec || !*filespec) {
5481     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5482     return NULL;
5483   }
5484
5485   vmsfspec = NULL;
5486   vmsdefspec = NULL;
5487   outbufl = NULL;
5488
5489   in_spec = filespec;
5490   isunix = 0;
5491   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5492       char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5493       int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5494
5495       /* If this is a UNIX file spec, convert it to VMS */
5496       sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5497                            &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5498                            &e_len, &vs_spec, &vs_len);
5499       if (sts != 0) {
5500           isunix = 1;
5501           char * ret_spec;
5502
5503           vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5504           if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5505           ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5506           if (ret_spec == NULL) {
5507               PerlMem_free(vmsfspec);
5508               return NULL;
5509           }
5510           in_spec = (const char *)vmsfspec;
5511
5512           /* Unless we are forcing to VMS format, a UNIX input means
5513            * UNIX output, and that requires long names to be used
5514            */
5515           if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5516 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5517               opts |= PERL_RMSEXPAND_M_LONG;
5518 #endif
5519           else
5520               isunix = 0;
5521       }
5522
5523   }
5524
5525   rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
5526   rms_bind_fab_nam(myfab, mynam);
5527
5528   /* Process the default file specification if present */
5529   def_spec = defspec;
5530   if (defspec && *defspec) {
5531     int t_isunix;
5532     t_isunix = is_unix_filespec(defspec);
5533     if (t_isunix) {
5534       vmsdefspec = PerlMem_malloc(VMS_MAXRSS);
5535       if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5536       ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5537
5538       if (ret_spec == NULL) {
5539           /* Clean up and bail */
5540           PerlMem_free(vmsdefspec);
5541           if (vmsfspec != NULL)
5542               PerlMem_free(vmsfspec);
5543               return NULL;
5544           }
5545           def_spec = (const char *)vmsdefspec;
5546       }
5547       rms_set_dna(myfab, mynam,
5548                   (char *)def_spec, strlen(def_spec)); /* cast ok */
5549   }
5550
5551   /* Now we need the expansion buffers */
5552   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5553   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5554 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5555   esal = PerlMem_malloc(VMS_MAXRSS);
5556   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5557 #endif
5558   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5559
5560   /* If a NAML block is used RMS always writes to the long and short
5561    * addresses unless you suppress the short name.
5562    */
5563 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5564   outbufl = PerlMem_malloc(VMS_MAXRSS);
5565   if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5566 #endif
5567    rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5568
5569 #ifdef NAM$M_NO_SHORT_UPCASE
5570   if (decc_efs_case_preserve)
5571     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5572 #endif
5573
5574    /* We may not want to follow symbolic links */
5575 #ifdef NAML$M_OPEN_SPECIAL
5576   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5577     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5578 #endif
5579
5580   /* First attempt to parse as an existing file */
5581   retsts = sys$parse(&myfab,0,0);
5582   if (!(retsts & STS$K_SUCCESS)) {
5583
5584     /* Could not find the file, try as syntax only if error is not fatal */
5585     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5586     if (retsts == RMS$_DNF ||
5587         retsts == RMS$_DIR ||
5588         retsts == RMS$_DEV ||
5589         retsts == RMS$_PRV) {
5590       retsts = sys$parse(&myfab,0,0);
5591       if (retsts & STS$K_SUCCESS) goto int_expanded;
5592     }
5593
5594      /* Still could not parse the file specification */
5595     /*----------------------------------------------*/
5596     sts = rms_free_search_context(&myfab); /* Free search context */
5597     if (vmsdefspec != NULL)
5598         PerlMem_free(vmsdefspec);
5599     if (vmsfspec != NULL)
5600         PerlMem_free(vmsfspec);
5601     if (outbufl != NULL)
5602         PerlMem_free(outbufl);
5603     PerlMem_free(esa);
5604     if (esal != NULL)
5605         PerlMem_free(esal);
5606     set_vaxc_errno(retsts);
5607     if      (retsts == RMS$_PRV) set_errno(EACCES);
5608     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5609     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5610     else                         set_errno(EVMSERR);
5611     return NULL;
5612   }
5613   retsts = sys$search(&myfab,0,0);
5614   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5615     sts = rms_free_search_context(&myfab); /* Free search context */
5616     if (vmsdefspec != NULL)
5617         PerlMem_free(vmsdefspec);
5618     if (vmsfspec != NULL)
5619         PerlMem_free(vmsfspec);
5620     if (outbufl != NULL)
5621         PerlMem_free(outbufl);
5622     PerlMem_free(esa);
5623     if (esal != NULL)
5624         PerlMem_free(esal);
5625     set_vaxc_errno(retsts);
5626     if      (retsts == RMS$_PRV) set_errno(EACCES);
5627     else                         set_errno(EVMSERR);
5628     return NULL;
5629   }
5630
5631   /* If the input filespec contained any lowercase characters,
5632    * downcase the result for compatibility with Unix-minded code. */
5633 int_expanded:
5634   if (!decc_efs_case_preserve) {
5635     char * tbuf;
5636     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5637       if (islower(*tbuf)) { haslower = 1; break; }
5638   }
5639
5640    /* Is a long or a short name expected */
5641   /*------------------------------------*/
5642   spec_buf = NULL;
5643   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5644     if (rms_nam_rsll(mynam)) {
5645         spec_buf = outbufl;
5646         speclen = rms_nam_rsll(mynam);
5647     }
5648     else {
5649         spec_buf = esal; /* Not esa */
5650         speclen = rms_nam_esll(mynam);
5651     }
5652   }
5653   else {
5654     if (rms_nam_rsl(mynam)) {
5655         spec_buf = outbuf;
5656         speclen = rms_nam_rsl(mynam);
5657     }
5658     else {
5659         spec_buf = esa; /* Not esal */
5660         speclen = rms_nam_esl(mynam);
5661     }
5662   }
5663   spec_buf[speclen] = '\0';
5664
5665   /* Trim off null fields added by $PARSE
5666    * If type > 1 char, must have been specified in original or default spec
5667    * (not true for version; $SEARCH may have added version of existing file).
5668    */
5669   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5670   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5671     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5672              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5673   }
5674   else {
5675     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5676              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5677   }
5678   if (trimver || trimtype) {
5679     if (defspec && *defspec) {
5680       char *defesal = NULL;
5681       char *defesa = NULL;
5682       defesa = PerlMem_malloc(VMS_MAXRSS + 1);
5683       if (defesa != NULL) {
5684         struct FAB deffab = cc$rms_fab;
5685 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5686         defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5687         if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5688 #endif
5689         rms_setup_nam(defnam);
5690
5691         rms_bind_fab_nam(deffab, defnam);
5692
5693         /* Cast ok */
5694         rms_set_fna
5695             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5696
5697         /* RMS needs the esa/esal as a work area if wildcards are involved */
5698         rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5699
5700         rms_clear_nam_nop(defnam);
5701         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5702 #ifdef NAM$M_NO_SHORT_UPCASE
5703         if (decc_efs_case_preserve)
5704           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5705 #endif
5706 #ifdef NAML$M_OPEN_SPECIAL
5707         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5708           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5709 #endif
5710         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5711           if (trimver) {
5712              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5713           }
5714           if (trimtype) {
5715             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5716           }
5717         }
5718         if (defesal != NULL)
5719             PerlMem_free(defesal);
5720         PerlMem_free(defesa);
5721       } else {
5722           _ckvmssts_noperl(SS$_INSFMEM);
5723       }
5724     }
5725     if (trimver) {
5726       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5727         if (*(rms_nam_verl(mynam)) != '\"')
5728           speclen = rms_nam_verl(mynam) - spec_buf;
5729       }
5730       else {
5731         if (*(rms_nam_ver(mynam)) != '\"')
5732           speclen = rms_nam_ver(mynam) - spec_buf;
5733       }
5734     }
5735     if (trimtype) {
5736       /* If we didn't already trim version, copy down */
5737       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5738         if (speclen > rms_nam_verl(mynam) - spec_buf)
5739           memmove
5740            (rms_nam_typel(mynam),
5741             rms_nam_verl(mynam),
5742             speclen - (rms_nam_verl(mynam) - spec_buf));
5743           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5744       }
5745       else {
5746         if (speclen > rms_nam_ver(mynam) - spec_buf)
5747           memmove
5748            (rms_nam_type(mynam),
5749             rms_nam_ver(mynam),
5750             speclen - (rms_nam_ver(mynam) - spec_buf));
5751           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5752       }
5753     }
5754   }
5755
5756    /* Done with these copies of the input files */
5757   /*-------------------------------------------*/
5758   if (vmsfspec != NULL)
5759         PerlMem_free(vmsfspec);
5760   if (vmsdefspec != NULL)
5761         PerlMem_free(vmsdefspec);
5762
5763   /* If we just had a directory spec on input, $PARSE "helpfully"
5764    * adds an empty name and type for us */
5765 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5766   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5767     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5768         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5769         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5770       speclen = rms_nam_namel(mynam) - spec_buf;
5771   }
5772   else
5773 #endif
5774   {
5775     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5776         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5777         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5778       speclen = rms_nam_name(mynam) - spec_buf;
5779   }
5780
5781   /* Posix format specifications must have matching quotes */
5782   if (speclen < (VMS_MAXRSS - 1)) {
5783     if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5784       if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5785         spec_buf[speclen] = '\"';
5786         speclen++;
5787       }
5788     }
5789   }
5790   spec_buf[speclen] = '\0';
5791   if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
5792
5793   /* Have we been working with an expanded, but not resultant, spec? */
5794   /* Also, convert back to Unix syntax if necessary. */
5795   {
5796   int rsl;
5797
5798 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5799     if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5800       rsl = rms_nam_rsll(mynam);
5801     } else
5802 #endif
5803     {
5804       rsl = rms_nam_rsl(mynam);
5805     }
5806     if (!rsl) {
5807       /* rsl is not present, it means that spec_buf is either */
5808       /* esa or esal, and needs to be copied to outbuf */
5809       /* convert to Unix if desired */
5810       if (isunix) {
5811         ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5812       } else {
5813         /* VMS file specs are not in UTF-8 */
5814         if (fs_utf8 != NULL)
5815             *fs_utf8 = 0;
5816         strcpy(outbuf, spec_buf);
5817         ret_spec = outbuf;
5818       }
5819     }
5820     else {
5821       /* Now spec_buf is either outbuf or outbufl */
5822       /* We need the result into outbuf */
5823       if (isunix) {
5824            /* If we need this in UNIX, then we need another buffer */
5825            /* to keep things in order */
5826            char * src;
5827            char * new_src = NULL;
5828            if (spec_buf == outbuf) {
5829                new_src = PerlMem_malloc(VMS_MAXRSS);
5830                strcpy(new_src, spec_buf);
5831            } else {
5832                src = spec_buf;
5833            }
5834            ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5835            if (new_src) {
5836                PerlMem_free(new_src);
5837            }
5838       } else {
5839            /* VMS file specs are not in UTF-8 */
5840            if (fs_utf8 != NULL)
5841                *fs_utf8 = 0;
5842
5843            /* Copy the buffer if needed */
5844            if (outbuf != spec_buf)
5845                strcpy(outbuf, spec_buf);
5846            ret_spec = outbuf;
5847       }
5848     }
5849   }
5850
5851   /* Need to clean up the search context */
5852   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5853   sts = rms_free_search_context(&myfab); /* Free search context */
5854
5855   /* Clean up the extra buffers */
5856   if (esal != NULL)
5857       PerlMem_free(esal);
5858   PerlMem_free(esa);
5859   if (outbufl != NULL)
5860      PerlMem_free(outbufl);
5861
5862   /* Return the result */
5863   return ret_spec;
5864 }
5865
5866 /* Common simple case - Expand an already VMS spec */
5867 static char *
5868 int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5869     opts |= PERL_RMSEXPAND_M_VMS_IN;
5870     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5871 }
5872
5873 /* Common simple case - Expand to a VMS spec */
5874 static char *
5875 int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5876     opts |= PERL_RMSEXPAND_M_VMS;
5877     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5878 }
5879
5880
5881 /* Entry point used by perl routines */
5882 static char *
5883 mp_do_rmsexpand
5884    (pTHX_ const char *filespec,
5885     char *outbuf,
5886     int ts,
5887     const char *defspec,
5888     unsigned opts,
5889     int * fs_utf8,
5890     int * dfs_utf8)
5891 {
5892     static char __rmsexpand_retbuf[VMS_MAXRSS];
5893     char * expanded, *ret_spec, *ret_buf;
5894
5895     expanded = NULL;
5896     ret_buf = outbuf;
5897     if (ret_buf == NULL) {
5898         if (ts) {
5899             Newx(expanded, VMS_MAXRSS, char);
5900             if (expanded == NULL)
5901                 _ckvmssts(SS$_INSFMEM);
5902             ret_buf = expanded;
5903         } else {
5904             ret_buf = __rmsexpand_retbuf;
5905         }
5906     }
5907
5908
5909     ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
5910                              opts, fs_utf8,  dfs_utf8);
5911
5912     if (ret_spec == NULL) {
5913        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
5914        if (expanded)
5915            Safefree(expanded);
5916     }
5917
5918     return ret_spec;
5919 }
5920 /*}}}*/
5921 /* External entry points */
5922 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5923 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5924 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5925 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5926 char *Perl_rmsexpand_utf8
5927   (pTHX_ const char *spec, char *buf, const char *def,
5928    unsigned opt, int * fs_utf8, int * dfs_utf8)
5929 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5930 char *Perl_rmsexpand_utf8_ts
5931   (pTHX_ const char *spec, char *buf, const char *def,
5932    unsigned opt, int * fs_utf8, int * dfs_utf8)
5933 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5934
5935
5936 /*
5937 ** The following routines are provided to make life easier when
5938 ** converting among VMS-style and Unix-style directory specifications.
5939 ** All will take input specifications in either VMS or Unix syntax. On
5940 ** failure, all return NULL.  If successful, the routines listed below
5941 ** return a pointer to a buffer containing the appropriately
5942 ** reformatted spec (and, therefore, subsequent calls to that routine
5943 ** will clobber the result), while the routines of the same names with
5944 ** a _ts suffix appended will return a pointer to a mallocd string
5945 ** containing the appropriately reformatted spec.
5946 ** In all cases, only explicit syntax is altered; no check is made that
5947 ** the resulting string is valid or that the directory in question
5948 ** actually exists.
5949 **
5950 **   fileify_dirspec() - convert a directory spec into the name of the
5951 **     directory file (i.e. what you can stat() to see if it's a dir).
5952 **     The style (VMS or Unix) of the result is the same as the style
5953 **     of the parameter passed in.
5954 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5955 **     what you prepend to a filename to indicate what directory it's in).
5956 **     The style (VMS or Unix) of the result is the same as the style
5957 **     of the parameter passed in.
5958 **   tounixpath() - convert a directory spec into a Unix-style path.
5959 **   tovmspath() - convert a directory spec into a VMS-style path.
5960 **   tounixspec() - convert any file spec into a Unix-style file spec.
5961 **   tovmsspec() - convert any file spec into a VMS-style spec.
5962 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5963 **
5964 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5965 ** Permission is given to distribute this code as part of the Perl
5966 ** standard distribution under the terms of the GNU General Public
5967 ** License or the Perl Artistic License.  Copies of each may be
5968 ** found in the Perl standard distribution.
5969  */
5970
5971 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5972 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
5973 {
5974     static char __fileify_retbuf[VMS_MAXRSS];
5975     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5976     char *retspec, *cp1, *cp2, *lastdir;
5977     char *trndir, *vmsdir;
5978     unsigned short int trnlnm_iter_count;
5979     int is_vms = 0;
5980     int is_unix = 0;
5981     int sts;
5982     if (utf8_fl != NULL)
5983         *utf8_fl = 0;
5984
5985     if (!dir || !*dir) {
5986       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5987     }
5988     dirlen = strlen(dir);
5989     while (dirlen && dir[dirlen-1] == '/') --dirlen;
5990     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5991       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5992         dir = "/sys$disk";
5993         dirlen = 9;
5994       }
5995       else
5996         dirlen = 1;
5997     }
5998     if (dirlen > (VMS_MAXRSS - 1)) {
5999       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
6000       return NULL;
6001     }
6002     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
6003     if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6004     if (!strpbrk(dir+1,"/]>:")  &&
6005         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
6006       strcpy(trndir,*dir == '/' ? dir + 1: dir);
6007       trnlnm_iter_count = 0;
6008       while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
6009         trnlnm_iter_count++;
6010         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6011       }
6012       dirlen = strlen(trndir);
6013     }
6014     else {
6015       strncpy(trndir,dir,dirlen);
6016       trndir[dirlen] = '\0';
6017     }
6018
6019     /* At this point we are done with *dir and use *trndir which is a
6020      * copy that can be modified.  *dir must not be modified.
6021      */
6022
6023     /* If we were handed a rooted logical name or spec, treat it like a
6024      * simple directory, so that
6025      *    $ Define myroot dev:[dir.]
6026      *    ... do_fileify_dirspec("myroot",buf,1) ...
6027      * does something useful.
6028      */
6029     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
6030       trndir[--dirlen] = '\0';
6031       trndir[dirlen-1] = ']';
6032     }
6033     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
6034       trndir[--dirlen] = '\0';
6035       trndir[dirlen-1] = '>';
6036     }
6037
6038     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
6039       /* If we've got an explicit filename, we can just shuffle the string. */
6040       if (*(cp1+1)) hasfilename = 1;
6041       /* Similarly, we can just back up a level if we've got multiple levels
6042          of explicit directories in a VMS spec which ends with directories. */
6043       else {
6044         for (cp2 = cp1; cp2 > trndir; cp2--) {
6045           if (*cp2 == '.') {
6046             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
6047 /* fix-me, can not scan EFS file specs backward like this */
6048               *cp2 = *cp1; *cp1 = '\0';
6049               hasfilename = 1;
6050               break;
6051             }
6052           }
6053           if (*cp2 == '[' || *cp2 == '<') break;
6054         }
6055       }
6056     }
6057
6058     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
6059     if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6060     cp1 = strpbrk(trndir,"]:>");
6061     if (hasfilename || !cp1) { /* Unix-style path or filename */
6062       if (trndir[0] == '.') {
6063         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
6064           PerlMem_free(trndir);
6065           PerlMem_free(vmsdir);
6066           return do_fileify_dirspec("[]",buf,ts,NULL);
6067         }
6068         else if (trndir[1] == '.' &&
6069                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
6070           PerlMem_free(trndir);
6071           PerlMem_free(vmsdir);
6072           return do_fileify_dirspec("[-]",buf,ts,NULL);
6073         }
6074       }
6075       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
6076         dirlen -= 1;                 /* to last element */
6077         lastdir = strrchr(trndir,'/');
6078       }
6079       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
6080         /* If we have "/." or "/..", VMSify it and let the VMS code
6081          * below expand it, rather than repeating the code to handle
6082          * relative components of a filespec here */
6083         do {
6084           if (*(cp1+2) == '.') cp1++;
6085           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
6086             char * ret_chr;
6087             if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
6088                 PerlMem_free(trndir);
6089                 PerlMem_free(vmsdir);
6090                 return NULL;
6091             }
6092             if (strchr(vmsdir,'/') != NULL) {
6093               /* If int_tovmsspec() returned it, it must have VMS syntax
6094                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
6095                * the time to check this here only so we avoid a recursion
6096                * loop; otherwise, gigo.
6097                */
6098               PerlMem_free(trndir);
6099               PerlMem_free(vmsdir);
6100               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
6101               return NULL;
6102             }
6103             if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
6104                 PerlMem_free(trndir);
6105                 PerlMem_free(vmsdir);
6106                 return NULL;
6107             }
6108             ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6109             PerlMem_free(trndir);
6110             PerlMem_free(vmsdir);
6111             return ret_chr;
6112           }
6113           cp1++;
6114         } while ((cp1 = strstr(cp1,"/.")) != NULL);
6115         lastdir = strrchr(trndir,'/');
6116       }
6117       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
6118         char * ret_chr;
6119         /* Ditto for specs that end in an MFD -- let the VMS code
6120          * figure out whether it's a real device or a rooted logical. */
6121
6122         /* This should not happen any more.  Allowing the fake /000000
6123          * in a UNIX pathname causes all sorts of problems when trying
6124          * to run in UNIX emulation.  So the VMS to UNIX conversions
6125          * now remove the fake /000000 directories.
6126          */
6127
6128         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6129         if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6130             PerlMem_free(trndir);
6131             PerlMem_free(vmsdir);
6132             return NULL;
6133         }
6134         if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
6135             PerlMem_free(trndir);
6136             PerlMem_free(vmsdir);
6137             return NULL;
6138         }
6139         ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6140         PerlMem_free(trndir);
6141         PerlMem_free(vmsdir);
6142         return ret_chr;
6143       }
6144       else {
6145
6146         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6147              !(lastdir = cp1 = strrchr(trndir,']')) &&
6148              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6149         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
6150           int ver; char *cp3;
6151
6152           /* For EFS or ODS-5 look for the last dot */
6153           if (decc_efs_charset) {
6154               cp2 = strrchr(cp1,'.');
6155           }
6156           if (vms_process_case_tolerant) {
6157               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
6158                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
6159                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6160                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6161                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6162                             (ver || *cp3)))))) {
6163                   PerlMem_free(trndir);
6164                   PerlMem_free(vmsdir);
6165                   set_errno(ENOTDIR);
6166                   set_vaxc_errno(RMS$_DIR);
6167                   return NULL;
6168               }
6169           }
6170           else {
6171               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
6172                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
6173                   !*(cp2+3) || *(cp2+3) != 'R' ||
6174                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6175                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6176                             (ver || *cp3)))))) {
6177                  PerlMem_free(trndir);
6178                  PerlMem_free(vmsdir);
6179                  set_errno(ENOTDIR);
6180                  set_vaxc_errno(RMS$_DIR);
6181                  return NULL;
6182               }
6183           }
6184           dirlen = cp2 - trndir;
6185         }
6186       }
6187
6188       retlen = dirlen + 6;
6189       if (buf) retspec = buf;
6190       else if (ts) Newx(retspec,retlen+1,char);
6191       else retspec = __fileify_retbuf;
6192       memcpy(retspec,trndir,dirlen);
6193       retspec[dirlen] = '\0';
6194
6195       /* We've picked up everything up to the directory file name.
6196          Now just add the type and version, and we're set. */
6197
6198       /* We should only add type for VMS syntax, but historically Perl
6199          has added it for UNIX style also */
6200
6201       /* Fix me - we should not be using the same routine for VMS and
6202          UNIX format files.  Things are too tangled so we need to lookup
6203          what syntax the output is */
6204
6205       is_unix = 0;
6206       is_vms = 0;
6207       lastdir = strrchr(trndir,'/');
6208       if (lastdir) {
6209           is_unix = 1;
6210       } else {
6211           lastdir = strpbrk(trndir,"]:>");
6212           if (lastdir) {
6213               is_vms = 1;
6214           }
6215       }
6216
6217       if ((is_vms == 0) && (is_unix == 0)) {
6218           /* We still do not  know? */
6219           is_unix = decc_filename_unix_report;
6220           if (is_unix == 0)
6221               is_vms = 1;
6222       }
6223
6224       if ((is_unix && !decc_efs_charset) || is_vms) {
6225
6226            /* It is a bug to add a .dir to a UNIX format directory spec */
6227            /* However Perl on VMS may have programs that expect this so */
6228            /* If not using EFS character specifications allow it. */
6229
6230            if ((!decc_efs_case_preserve) && vms_process_case_tolerant) {
6231                /* Traditionally Perl expects filenames in lower case */
6232                strcat(retspec, ".dir");
6233            } else {
6234                /* VMS expects the .DIR to be in upper case */
6235                strcat(retspec, ".DIR");
6236            }
6237
6238            /* It is also a bug to put a VMS format version on a UNIX file */
6239            /* specification.  Perl self tests are looking for this */
6240            if (is_vms || !(decc_efs_charset || decc_filename_unix_report))
6241                strcat(retspec, ";1");
6242       }
6243       PerlMem_free(trndir);
6244       PerlMem_free(vmsdir);
6245       return retspec;
6246     }
6247     else {  /* VMS-style directory spec */
6248
6249       char *esa, *esal, term, *cp;
6250       char *my_esa;
6251       int my_esa_len;
6252       unsigned long int sts, cmplen, haslower = 0;
6253       unsigned int nam_fnb;
6254       char * nam_type;
6255       struct FAB dirfab = cc$rms_fab;
6256       rms_setup_nam(savnam);
6257       rms_setup_nam(dirnam);
6258
6259       esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6260       if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6261       esal = NULL;
6262 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6263       esal = PerlMem_malloc(VMS_MAXRSS);
6264       if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6265 #endif
6266       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6267       rms_bind_fab_nam(dirfab, dirnam);
6268       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6269       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6270 #ifdef NAM$M_NO_SHORT_UPCASE
6271       if (decc_efs_case_preserve)
6272         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6273 #endif
6274
6275       for (cp = trndir; *cp; cp++)
6276         if (islower(*cp)) { haslower = 1; break; }
6277       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6278         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
6279           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6280           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
6281         }
6282         if (!sts) {
6283           PerlMem_free(esa);
6284           if (esal != NULL)
6285               PerlMem_free(esal);
6286           PerlMem_free(trndir);
6287           PerlMem_free(vmsdir);
6288           set_errno(EVMSERR);
6289           set_vaxc_errno(dirfab.fab$l_sts);
6290           return NULL;
6291         }
6292       }
6293       else {
6294         savnam = dirnam;
6295         /* Does the file really exist? */
6296         if (sys$search(&dirfab)& STS$K_SUCCESS) {
6297           /* Yes; fake the fnb bits so we'll check type below */
6298         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6299         }
6300         else { /* No; just work with potential name */
6301           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6302           else {
6303             int fab_sts;
6304             fab_sts = dirfab.fab$l_sts;
6305             sts = rms_free_search_context(&dirfab);
6306             PerlMem_free(esa);
6307             if (esal != NULL)
6308                 PerlMem_free(esal);
6309             PerlMem_free(trndir);
6310             PerlMem_free(vmsdir);
6311             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
6312             return NULL;
6313           }
6314         }
6315       }
6316
6317       /* Make sure we are using the right buffer */
6318       if (esal != NULL) {
6319         my_esa = esal;
6320         my_esa_len = rms_nam_esll(dirnam);
6321       } else {
6322         my_esa = esa;
6323         my_esa_len = rms_nam_esl(dirnam);
6324       }
6325       my_esa[my_esa_len] = '\0';
6326       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6327         cp1 = strchr(my_esa,']');
6328         if (!cp1) cp1 = strchr(my_esa,'>');
6329         if (cp1) {  /* Should always be true */
6330           my_esa_len -= cp1 - my_esa - 1;
6331           memmove(my_esa, cp1 + 1, my_esa_len);
6332         }
6333       }
6334       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6335         /* Yep; check version while we're at it, if it's there. */
6336         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6337         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6338           /* Something other than .DIR[;1].  Bzzt. */
6339           sts = rms_free_search_context(&dirfab);
6340           PerlMem_free(esa);
6341           if (esal != NULL)
6342              PerlMem_free(esal);
6343           PerlMem_free(trndir);
6344           PerlMem_free(vmsdir);
6345           set_errno(ENOTDIR);
6346           set_vaxc_errno(RMS$_DIR);
6347           return NULL;
6348         }
6349       }
6350
6351       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6352         /* They provided at least the name; we added the type, if necessary, */
6353         if (buf) retspec = buf;                            /* in sys$parse() */
6354         else if (ts) Newx(retspec, my_esa_len + 1, char);
6355         else retspec = __fileify_retbuf;
6356         strcpy(retspec,my_esa);
6357         sts = rms_free_search_context(&dirfab);
6358         PerlMem_free(trndir);
6359         PerlMem_free(esa);
6360         if (esal != NULL)
6361             PerlMem_free(esal);
6362         PerlMem_free(vmsdir);
6363         return retspec;
6364       }
6365       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6366         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6367         *cp1 = '\0';
6368         my_esa_len -= 9;
6369       }
6370       if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6371       if (cp1 == NULL) { /* should never happen */
6372         sts = rms_free_search_context(&dirfab);
6373         PerlMem_free(trndir);
6374         PerlMem_free(esa);
6375         if (esal != NULL)
6376             PerlMem_free(esal);
6377         PerlMem_free(vmsdir);
6378         return NULL;
6379       }
6380       term = *cp1;
6381       *cp1 = '\0';
6382       retlen = strlen(my_esa);
6383       cp1 = strrchr(my_esa,'.');
6384       /* ODS-5 directory specifications can have extra "." in them. */
6385       /* Fix-me, can not scan EFS file specifications backwards */
6386       while (cp1 != NULL) {
6387         if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6388           break;
6389         else {
6390            cp1--;
6391            while ((cp1 > my_esa) && (*cp1 != '.'))
6392              cp1--;
6393         }
6394         if (cp1 == my_esa)
6395           cp1 = NULL;
6396       }
6397
6398       if ((cp1) != NULL) {
6399         /* There's more than one directory in the path.  Just roll back. */
6400         *cp1 = term;
6401         if (buf) retspec = buf;
6402         else if (ts) Newx(retspec,retlen+7,char);
6403         else retspec = __fileify_retbuf;
6404         strcpy(retspec,my_esa);
6405       }
6406       else {
6407         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6408           /* Go back and expand rooted logical name */
6409           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6410 #ifdef NAM$M_NO_SHORT_UPCASE
6411           if (decc_efs_case_preserve)
6412             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6413 #endif
6414           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6415             sts = rms_free_search_context(&dirfab);
6416             PerlMem_free(esa);
6417             if (esal != NULL)
6418                 PerlMem_free(esal);
6419             PerlMem_free(trndir);
6420             PerlMem_free(vmsdir);
6421             set_errno(EVMSERR);
6422             set_vaxc_errno(dirfab.fab$l_sts);
6423             return NULL;
6424           }
6425
6426           /* This changes the length of the string of course */
6427           if (esal != NULL) {
6428               my_esa_len = rms_nam_esll(dirnam);
6429           } else {
6430               my_esa_len = rms_nam_esl(dirnam);
6431           }
6432
6433           retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6434           if (buf) retspec = buf;
6435           else if (ts) Newx(retspec,retlen+16,char);
6436           else retspec = __fileify_retbuf;
6437           cp1 = strstr(my_esa,"][");
6438           if (!cp1) cp1 = strstr(my_esa,"]<");
6439           dirlen = cp1 - my_esa;
6440           memcpy(retspec,my_esa,dirlen);
6441           if (!strncmp(cp1+2,"000000]",7)) {
6442             retspec[dirlen-1] = '\0';
6443             /* fix-me Not full ODS-5, just extra dots in directories for now */
6444             cp1 = retspec + dirlen - 1;
6445             while (cp1 > retspec)
6446             {
6447               if (*cp1 == '[')
6448                 break;
6449               if (*cp1 == '.') {
6450                 if (*(cp1-1) != '^')
6451                   break;
6452               }
6453               cp1--;
6454             }
6455             if (*cp1 == '.') *cp1 = ']';
6456             else {
6457               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6458               memmove(cp1+1,"000000]",7);
6459             }
6460           }
6461           else {
6462             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
6463             retspec[retlen] = '\0';
6464             /* Convert last '.' to ']' */
6465             cp1 = retspec+retlen-1;
6466             while (*cp != '[') {
6467               cp1--;
6468               if (*cp1 == '.') {
6469                 /* Do not trip on extra dots in ODS-5 directories */
6470                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
6471                 break;
6472               }
6473             }
6474             if (*cp1 == '.') *cp1 = ']';
6475             else {
6476               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6477               memmove(cp1+1,"000000]",7);
6478             }
6479           }
6480         }
6481         else {  /* This is a top-level dir.  Add the MFD to the path. */
6482           if (buf) retspec = buf;
6483           else if (ts) Newx(retspec,retlen+16,char);
6484           else retspec = __fileify_retbuf;
6485           cp1 = my_esa;
6486           cp2 = retspec;
6487           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6488           strcpy(cp2,":[000000]");
6489           cp1 += 2;
6490           strcpy(cp2+9,cp1);
6491         }
6492       }
6493       sts = rms_free_search_context(&dirfab);
6494       /* We've set up the string up through the filename.  Add the
6495          type and version, and we're done. */
6496       strcat(retspec,".DIR;1");
6497
6498       /* $PARSE may have upcased filespec, so convert output to lower
6499        * case if input contained any lowercase characters. */
6500       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
6501       PerlMem_free(trndir);
6502       PerlMem_free(esa);
6503       if (esal != NULL)
6504         PerlMem_free(esal);
6505       PerlMem_free(vmsdir);
6506       return retspec;
6507     }
6508 }  /* end of do_fileify_dirspec() */
6509 /*}}}*/
6510 /* External entry points */
6511 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6512 { return do_fileify_dirspec(dir,buf,0,NULL); }
6513 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6514 { return do_fileify_dirspec(dir,buf,1,NULL); }
6515 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6516 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6517 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6518 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6519
6520 static char * int_pathify_dirspec_simple(const char * dir, char * buf,
6521     char * v_spec, int v_len, char * r_spec, int r_len,
6522     char * d_spec, int d_len, char * n_spec, int n_len,
6523     char * e_spec, int e_len, char * vs_spec, int vs_len) {
6524
6525     /* VMS specification - Try to do this the simple way */
6526     if ((v_len + r_len > 0) || (d_len > 0)) {
6527         int is_dir;
6528
6529         /* No name or extension component, already a directory */
6530         if ((n_len + e_len + vs_len) == 0) {
6531             strcpy(buf, dir);
6532             return buf;
6533         }
6534
6535         /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6536         /* This results from catfile() being used instead of catdir() */
6537         /* So even though it should not work, we need to allow it */
6538
6539         /* If this is .DIR;1 then do a simple conversion */
6540         is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6541         if (is_dir || (e_len == 0) && (d_len > 0)) {
6542              int len;
6543              len = v_len + r_len + d_len - 1;
6544              char dclose = d_spec[d_len - 1];
6545              strncpy(buf, dir, len);
6546              buf[len] = '.';
6547              len++;
6548              strncpy(&buf[len], n_spec, n_len);
6549              len += n_len;
6550              buf[len] = dclose;
6551              buf[len + 1] = '\0';
6552              return buf;
6553         }
6554
6555 #ifdef HAS_SYMLINK
6556         else if (d_len > 0) {
6557             /* In the olden days, a directory needed to have a .DIR */
6558             /* extension to be a valid directory, but now it could  */
6559             /* be a symbolic link */
6560             int len;
6561             len = v_len + r_len + d_len - 1;
6562             char dclose = d_spec[d_len - 1];
6563             strncpy(buf, dir, len);
6564             buf[len] = '.';
6565             len++;
6566             strncpy(&buf[len], n_spec, n_len);
6567             len += n_len;
6568             if (e_len > 0) {
6569                 if (decc_efs_charset) {
6570                     buf[len] = '^';
6571                     len++;
6572                     strncpy(&buf[len], e_spec, e_len);
6573                     len += e_len;
6574                 } else {
6575                     set_vaxc_errno(RMS$_DIR);
6576                     set_errno(ENOTDIR);
6577                     return NULL;
6578                 }
6579             }
6580             buf[len] = dclose;
6581             buf[len + 1] = '\0';
6582             return buf;
6583         }
6584 #else
6585         else {
6586             set_vaxc_errno(RMS$_DIR);
6587             set_errno(ENOTDIR);
6588             return NULL;
6589         }
6590 #endif
6591     }
6592     set_vaxc_errno(RMS$_DIR);
6593     set_errno(ENOTDIR);
6594     return NULL;
6595 }
6596
6597
6598 /* Internal routine to make sure or convert a directory to be in a */
6599 /* path specification.  No utf8 flag because it is not changed or used */
6600 static char *int_pathify_dirspec(const char *dir, char *buf)
6601 {
6602     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6603     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6604     char * exp_spec, *ret_spec;
6605     char * trndir;
6606     unsigned short int trnlnm_iter_count;
6607     STRLEN trnlen;
6608     int need_to_lower;
6609
6610     if (vms_debug_fileify) {
6611         if (dir == NULL)
6612             fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6613         else
6614             fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6615     }
6616
6617     /* We may need to lower case the result if we translated  */
6618     /* a logical name or got the current working directory */
6619     need_to_lower = 0;
6620
6621     if (!dir || !*dir) {
6622       set_errno(EINVAL);
6623       set_vaxc_errno(SS$_BADPARAM);
6624       return NULL;
6625     }
6626
6627     trndir = PerlMem_malloc(VMS_MAXRSS);
6628     if (trndir == NULL)
6629         _ckvmssts_noperl(SS$_INSFMEM);
6630
6631     /* If no directory specified use the current default */
6632     if (*dir)
6633         strcpy(trndir, dir);
6634     else {
6635         getcwd(trndir, VMS_MAXRSS - 1);
6636         need_to_lower = 1;
6637     }
6638
6639     /* now deal with bare names that could be logical names */
6640     trnlnm_iter_count = 0;
6641     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6642            && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6643         trnlnm_iter_count++;
6644         need_to_lower = 1;
6645         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6646             break;
6647         trnlen = strlen(trndir);
6648
6649         /* Trap simple rooted lnms, and return lnm:[000000] */
6650         if (!strcmp(trndir+trnlen-2,".]")) {
6651             strcpy(buf, dir);
6652             strcat(buf, ":[000000]");
6653             PerlMem_free(trndir);
6654
6655             if (vms_debug_fileify) {
6656                 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6657             }
6658             return buf;
6659         }
6660     }
6661
6662     /* At this point we do not work with *dir, but the copy in  *trndir */
6663
6664     if (need_to_lower && !decc_efs_case_preserve) {
6665         /* Legacy mode, lower case the returned value */
6666         __mystrtolower(trndir);
6667     }
6668
6669
6670     /* Some special cases, '..', '.' */
6671     sts = 0;
6672     if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6673        /* Force UNIX filespec */
6674        sts = 1;
6675
6676     } else {
6677         /* Is this Unix or VMS format? */
6678         sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6679                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6680                              &e_len, &vs_spec, &vs_len);
6681         if (sts == 0) {
6682
6683             /* Just a filename? */
6684             if ((v_len + r_len + d_len) == 0) {
6685
6686                 /* Now we have a problem, this could be Unix or VMS */
6687                 /* We have to guess.  .DIR usually means VMS */
6688
6689                 /* In UNIX report mode, the .DIR extension is removed */
6690                 /* if one shows up, it is for a non-directory or a directory */
6691                 /* in EFS charset mode */
6692
6693                 /* So if we are in Unix report mode, assume that this */
6694                 /* is a relative Unix directory specification */
6695
6696                 sts = 1;
6697                 if (!decc_filename_unix_report && decc_efs_charset) {
6698                     int is_dir;
6699                     is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6700
6701                     if (is_dir) {
6702                         /* Traditional mode, assume .DIR is directory */
6703                         buf[0] = '[';
6704                         buf[1] = '.';
6705                         strncpy(&buf[2], n_spec, n_len);
6706                         buf[n_len + 2] = ']';
6707                         buf[n_len + 3] = '\0';
6708                         PerlMem_free(trndir);
6709                         if (vms_debug_fileify) {
6710                             fprintf(stderr,
6711                                     "int_pathify_dirspec: buf = %s\n",
6712                                     buf);
6713                         }
6714                         return buf;
6715                     }
6716                 }
6717             }
6718         }
6719     }
6720     if (sts == 0) {
6721         ret_spec = int_pathify_dirspec_simple(trndir, buf,
6722             v_spec, v_len, r_spec, r_len,
6723             d_spec, d_len, n_spec, n_len,
6724             e_spec, e_len, vs_spec, vs_len);
6725
6726         if (ret_spec != NULL) {
6727             PerlMem_free(trndir);
6728             if (vms_debug_fileify) {
6729                 fprintf(stderr,
6730                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6731             }
6732             return ret_spec;
6733         }
6734
6735         /* Simple way did not work, which means that a logical name */
6736         /* was present for the directory specification.             */
6737         /* Need to use an rmsexpand variant to decode it completely */
6738         exp_spec = PerlMem_malloc(VMS_MAXRSS);
6739         if (exp_spec == NULL)
6740             _ckvmssts_noperl(SS$_INSFMEM);
6741
6742         ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6743         if (ret_spec != NULL) {
6744             sts = vms_split_path(exp_spec, &v_spec, &v_len,
6745                                  &r_spec, &r_len, &d_spec, &d_len,
6746                                  &n_spec, &n_len, &e_spec,
6747                                  &e_len, &vs_spec, &vs_len);
6748             if (sts == 0) {
6749                 ret_spec = int_pathify_dirspec_simple(
6750                     exp_spec, buf, v_spec, v_len, r_spec, r_len,
6751                     d_spec, d_len, n_spec, n_len,
6752                     e_spec, e_len, vs_spec, vs_len);
6753
6754                 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6755                     /* Legacy mode, lower case the returned value */
6756                     __mystrtolower(ret_spec);
6757                 }
6758             } else {
6759                 set_vaxc_errno(RMS$_DIR);
6760                 set_errno(ENOTDIR);
6761                 ret_spec = NULL;
6762             }
6763         }
6764         PerlMem_free(exp_spec);
6765         PerlMem_free(trndir);
6766         if (vms_debug_fileify) {
6767             if (ret_spec == NULL)
6768                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6769             else
6770                 fprintf(stderr,
6771                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6772         }
6773         return ret_spec;
6774
6775     } else {
6776         /* Unix specification, Could be trivial conversion */
6777         STRLEN dir_len;
6778         dir_len = strlen(trndir);
6779
6780         /* If the extended file character set is in effect */
6781         /* then pathify is simple */
6782
6783         if (!decc_efs_charset) {
6784             /* Have to deal with traiing '.dir' or extra '.' */
6785             /* that should not be there in legacy mode, but is */
6786
6787             char * lastdot;
6788             char * lastslash;
6789             int is_dir;
6790
6791             lastslash = strrchr(trndir, '/');
6792             if (lastslash == NULL)
6793                 lastslash = trndir;
6794             else
6795                 lastslash++;
6796
6797             lastdot = NULL;
6798
6799             /* '..' or '.' are valid directory components */
6800             is_dir = 0;
6801             if (lastslash[0] == '.') {
6802                 if (lastslash[1] == '\0') {
6803                    is_dir = 1;
6804                 } else if (lastslash[1] == '.') {
6805                     if (lastslash[2] == '\0') {
6806                         is_dir = 1;
6807                     } else {
6808                         /* And finally allow '...' */
6809                         if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
6810                             is_dir = 1;
6811                         }
6812                     }
6813                 }
6814             }
6815
6816             if (!is_dir) {
6817                lastdot = strrchr(lastslash, '.');
6818             }
6819             if (lastdot != NULL) {
6820                 STRLEN e_len;
6821
6822                 /* '.dir' is discarded, and any other '.' is invalid */
6823                 e_len = strlen(lastdot);
6824
6825                 is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
6826
6827                 if (is_dir) {
6828                     dir_len = dir_len - 4;
6829
6830                 }
6831             }
6832         }
6833
6834         strcpy(buf, trndir);
6835         if (buf[dir_len - 1] != '/') {
6836             buf[dir_len] = '/';
6837             buf[dir_len + 1] = '\0';
6838         }
6839
6840         /* Under ODS-2 rules, '.' becomes '_', so fix it up */
6841         if (!decc_efs_charset) {
6842              int dir_start = 0;
6843              char * str = buf;
6844              if (str[0] == '.') {
6845                  char * dots = str;
6846                  int cnt = 1;
6847                  while ((dots[cnt] == '.') && (cnt < 3))
6848                      cnt++;
6849                  if (cnt <= 3) {
6850                      if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
6851                          dir_start = 1;
6852                          str += cnt;
6853                      }
6854                  }
6855              }
6856              for (; *str; ++str) {
6857                  while (*str == '/') {
6858                      dir_start = 1;
6859                      *str++;
6860                  }
6861                  if (dir_start) {
6862
6863                      /* Have to skip up to three dots which could be */
6864                      /* directories, 3 dots being a VMS extension for Perl */
6865                      char * dots = str;
6866                      int cnt = 0;
6867                      while ((dots[cnt] == '.') && (cnt < 3)) {
6868                          cnt++;
6869                      }
6870                      if (dots[cnt] == '\0')
6871                          break;
6872                      if ((cnt > 1) && (dots[cnt] != '/')) {
6873                          dir_start = 0;
6874                      } else {
6875                          str += cnt;
6876                      }
6877
6878                      /* too many dots? */
6879                      if ((cnt == 0) || (cnt > 3)) {
6880                          dir_start = 0;
6881                      }
6882                  }
6883                  if (!dir_start && (*str == '.')) {
6884                      *str = '_';
6885                  }
6886              }
6887         }
6888         PerlMem_free(trndir);
6889         ret_spec = buf;
6890         if (vms_debug_fileify) {
6891             if (ret_spec == NULL)
6892                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6893             else
6894                 fprintf(stderr,
6895                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6896         }
6897         return ret_spec;
6898     }
6899 }
6900
6901 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6902 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6903 {
6904     static char __pathify_retbuf[VMS_MAXRSS];
6905     char * pathified, *ret_spec, *ret_buf;
6906
6907     pathified = NULL;
6908     ret_buf = buf;
6909     if (ret_buf == NULL) {
6910         if (ts) {
6911             Newx(pathified, VMS_MAXRSS, char);
6912             if (pathified == NULL)
6913                 _ckvmssts(SS$_INSFMEM);
6914             ret_buf = pathified;
6915         } else {
6916             ret_buf = __pathify_retbuf;
6917         }
6918     }
6919
6920     ret_spec = int_pathify_dirspec(dir, ret_buf);
6921
6922     if (ret_spec == NULL) {
6923        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6924        if (pathified)
6925            Safefree(pathified);
6926     }
6927
6928     return ret_spec;
6929
6930 }  /* end of do_pathify_dirspec() */
6931
6932
6933 /* External entry points */
6934 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6935 { return do_pathify_dirspec(dir,buf,0,NULL); }
6936 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6937 { return do_pathify_dirspec(dir,buf,1,NULL); }
6938 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6939 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6940 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6941 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
6942
6943 /* Internal tounixspec routine that does not use a thread context */
6944 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
6945 static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
6946 {
6947   char *dirend, *cp1, *cp3, *tmp;
6948   const char *cp2;
6949   int devlen, dirlen, retlen = VMS_MAXRSS;
6950   int expand = 1; /* guarantee room for leading and trailing slashes */
6951   unsigned short int trnlnm_iter_count;
6952   int cmp_rslt;
6953   if (utf8_fl != NULL)
6954     *utf8_fl = 0;
6955
6956   if (vms_debug_fileify) {
6957       if (spec == NULL)
6958           fprintf(stderr, "int_tounixspec: spec = NULL\n");
6959       else
6960           fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
6961   }
6962
6963
6964   if (spec == NULL) {
6965       set_errno(EINVAL);
6966       set_vaxc_errno(SS$_BADPARAM);
6967       return NULL;
6968   }
6969   if (strlen(spec) > (VMS_MAXRSS-1)) {
6970       set_errno(E2BIG);
6971       set_vaxc_errno(SS$_BUFFEROVF);
6972       return NULL;
6973   }
6974
6975   /* New VMS specific format needs translation
6976    * glob passes filenames with trailing '\n' and expects this preserved.
6977    */
6978   if (decc_posix_compliant_pathnames) {
6979     if (strncmp(spec, "\"^UP^", 5) == 0) {
6980       char * uspec;
6981       char *tunix;
6982       int tunix_len;
6983       int nl_flag;
6984
6985       tunix = PerlMem_malloc(VMS_MAXRSS);
6986       if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6987       strcpy(tunix, spec);
6988       tunix_len = strlen(tunix);
6989       nl_flag = 0;
6990       if (tunix[tunix_len - 1] == '\n') {
6991         tunix[tunix_len - 1] = '\"';
6992         tunix[tunix_len] = '\0';
6993         tunix_len--;
6994         nl_flag = 1;
6995       }
6996       uspec = decc$translate_vms(tunix);
6997       PerlMem_free(tunix);
6998       if ((int)uspec > 0) {
6999         strcpy(rslt,uspec);
7000         if (nl_flag) {
7001           strcat(rslt,"\n");
7002         }
7003         else {
7004           /* If we can not translate it, makemaker wants as-is */
7005           strcpy(rslt, spec);
7006         }
7007         return rslt;
7008       }
7009     }
7010   }
7011
7012   cmp_rslt = 0; /* Presume VMS */
7013   cp1 = strchr(spec, '/');
7014   if (cp1 == NULL)
7015     cmp_rslt = 0;
7016
7017     /* Look for EFS ^/ */
7018     if (decc_efs_charset) {
7019       while (cp1 != NULL) {
7020         cp2 = cp1 - 1;
7021         if (*cp2 != '^') {
7022           /* Found illegal VMS, assume UNIX */
7023           cmp_rslt = 1;
7024           break;
7025         }
7026       cp1++;
7027       cp1 = strchr(cp1, '/');
7028     }
7029   }
7030
7031   /* Look for "." and ".." */
7032   if (decc_filename_unix_report) {
7033     if (spec[0] == '.') {
7034       if ((spec[1] == '\0') || (spec[1] == '\n')) {
7035         cmp_rslt = 1;
7036       }
7037       else {
7038         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
7039           cmp_rslt = 1;
7040         }
7041       }
7042     }
7043   }
7044   /* This is already UNIX or at least nothing VMS understands */
7045   if (cmp_rslt) {
7046     strcpy(rslt,spec);
7047     if (vms_debug_fileify) {
7048         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7049     }
7050     return rslt;
7051   }
7052
7053   cp1 = rslt;
7054   cp2 = spec;
7055   dirend = strrchr(spec,']');
7056   if (dirend == NULL) dirend = strrchr(spec,'>');
7057   if (dirend == NULL) dirend = strchr(spec,':');
7058   if (dirend == NULL) {
7059     strcpy(rslt,spec);
7060     if (vms_debug_fileify) {
7061         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7062     }
7063     return rslt;
7064   }
7065
7066   /* Special case 1 - sys$posix_root = / */
7067 #if __CRTL_VER >= 70000000
7068   if (!decc_disable_posix_root) {
7069     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
7070       *cp1 = '/';
7071       cp1++;
7072       cp2 = cp2 + 15;
7073       }
7074   }
7075 #endif
7076
7077   /* Special case 2 - Convert NLA0: to /dev/null */
7078 #if __CRTL_VER < 70000000
7079   cmp_rslt = strncmp(spec,"NLA0:", 5);
7080   if (cmp_rslt != 0)
7081      cmp_rslt = strncmp(spec,"nla0:", 5);
7082 #else
7083   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
7084 #endif
7085   if (cmp_rslt == 0) {
7086     strcpy(rslt, "/dev/null");
7087     cp1 = cp1 + 9;
7088     cp2 = cp2 + 5;
7089     if (spec[6] != '\0') {
7090       cp1[9] == '/';
7091       cp1++;
7092       cp2++;
7093     }
7094   }
7095
7096    /* Also handle special case "SYS$SCRATCH:" */
7097 #if __CRTL_VER < 70000000
7098   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
7099   if (cmp_rslt != 0)
7100      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
7101 #else
7102   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
7103 #endif
7104   tmp = PerlMem_malloc(VMS_MAXRSS);
7105   if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7106   if (cmp_rslt == 0) {
7107   int islnm;
7108
7109     islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
7110     if (!islnm) {
7111       strcpy(rslt, "/tmp");
7112       cp1 = cp1 + 4;
7113       cp2 = cp2 + 12;
7114       if (spec[12] != '\0') {
7115         cp1[4] == '/';
7116         cp1++;
7117         cp2++;
7118       }
7119     }
7120   }
7121
7122   if (*cp2 != '[' && *cp2 != '<') {
7123     *(cp1++) = '/';
7124   }
7125   else {  /* the VMS spec begins with directories */
7126     cp2++;
7127     if (*cp2 == ']' || *cp2 == '>') {
7128       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
7129       PerlMem_free(tmp);
7130       return rslt;
7131     }
7132     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
7133       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
7134         PerlMem_free(tmp);
7135         if (vms_debug_fileify) {
7136             fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7137         }
7138         return NULL;
7139       }
7140       trnlnm_iter_count = 0;
7141       do {
7142         cp3 = tmp;
7143         while (*cp3 != ':' && *cp3) cp3++;
7144         *(cp3++) = '\0';
7145         if (strchr(cp3,']') != NULL) break;
7146         trnlnm_iter_count++;
7147         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7148       } while (vmstrnenv(tmp,tmp,0,fildev,0));
7149       cp1 = rslt;
7150       cp3 = tmp;
7151       *(cp1++) = '/';
7152       while (*cp3) {
7153         *(cp1++) = *(cp3++);
7154         if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7155             PerlMem_free(tmp);
7156             set_errno(ENAMETOOLONG);
7157             set_vaxc_errno(SS$_BUFFEROVF);
7158             if (vms_debug_fileify) {
7159                 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7160             }
7161             return NULL; /* No room */
7162         }
7163       }
7164       *(cp1++) = '/';
7165     }
7166     if ((*cp2 == '^')) {
7167         /* EFS file escape, pass the next character as is */
7168         /* Fix me: HEX encoding for Unicode not implemented */
7169         cp2++;
7170     }
7171     else if ( *cp2 == '.') {
7172       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7173         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7174         cp2 += 3;
7175       }
7176       else cp2++;
7177     }
7178   }
7179   PerlMem_free(tmp);
7180   for (; cp2 <= dirend; cp2++) {
7181     if ((*cp2 == '^')) {
7182         /* EFS file escape, pass the next character as is */
7183         /* Fix me: HEX encoding for Unicode not implemented */
7184         *(cp1++) = *(++cp2);
7185         /* An escaped dot stays as is -- don't convert to slash */
7186         if (*cp2 == '.') cp2++;
7187     }
7188     if (*cp2 == ':') {
7189       *(cp1++) = '/';
7190       if (*(cp2+1) == '[') cp2++;
7191     }
7192     else if (*cp2 == ']' || *cp2 == '>') {
7193       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7194     }
7195     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7196       *(cp1++) = '/';
7197       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7198         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7199                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7200         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7201             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7202       }
7203       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7204         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7205         cp2 += 2;
7206       }
7207     }
7208     else if (*cp2 == '-') {
7209       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7210         while (*cp2 == '-') {
7211           cp2++;
7212           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7213         }
7214         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7215                                                          /* filespecs like */
7216           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
7217           if (vms_debug_fileify) {
7218               fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7219           }
7220           return NULL;
7221         }
7222       }
7223       else *(cp1++) = *cp2;
7224     }
7225     else *(cp1++) = *cp2;
7226   }
7227   /* Translate the rest of the filename. */
7228   while (*cp2) {
7229       int dot_seen;
7230       dot_seen = 0;
7231       switch(*cp2) {
7232       /* Fixme - for compatibility with the CRTL we should be removing */
7233       /* spaces from the file specifications, but this may show that */
7234       /* some tests that were appearing to pass are not really passing */
7235       case '%':
7236           cp2++;
7237           *(cp1++) = '?';
7238           break;
7239       case '^':
7240           /* Fix me hex expansions not implemented */
7241           cp2++;  /* '^.' --> '.' and other. */
7242           if (*cp2) {
7243               if (*cp2 == '_') {
7244                   cp2++;
7245                   *(cp1++) = ' ';
7246               } else {
7247                   *(cp1++) = *(cp2++);
7248               }
7249           }
7250           break;
7251       case ';':
7252           if (decc_filename_unix_no_version) {
7253               /* Easy, drop the version */
7254               while (*cp2)
7255                   cp2++;
7256               break;
7257           } else {
7258               /* Punt - passing the version as a dot will probably */
7259               /* break perl in weird ways, but so did passing */
7260               /* through the ; as a version.  Follow the CRTL and */
7261               /* hope for the best. */
7262               cp2++;
7263               *(cp1++) = '.';
7264           }
7265           break;
7266       case '.':
7267           if (dot_seen) {
7268               /* We will need to fix this properly later */
7269               /* As Perl may be installed on an ODS-5 volume, but not */
7270               /* have the EFS_CHARSET enabled, it still may encounter */
7271               /* filenames with extra dots in them, and a precedent got */
7272               /* set which allowed them to work, that we will uphold here */
7273               /* If extra dots are present in a name and no ^ is on them */
7274               /* VMS assumes that the first one is the extension delimiter */
7275               /* the rest have an implied ^. */
7276
7277               /* this is also a conflict as the . is also a version */
7278               /* delimiter in VMS, */
7279
7280               *(cp1++) = *(cp2++);
7281               break;
7282           }
7283           dot_seen = 1;
7284           /* This is an extension */
7285           if (decc_readdir_dropdotnotype) {
7286               cp2++;
7287               if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7288                   /* Drop the dot for the extension */
7289                   break;
7290               } else {
7291                   *(cp1++) = '.';
7292               }
7293               break;
7294           }
7295       default:
7296           *(cp1++) = *(cp2++);
7297       }
7298   }
7299   *cp1 = '\0';
7300
7301   /* This still leaves /000000/ when working with a
7302    * VMS device root or concealed root.
7303    */
7304   {
7305   int ulen;
7306   char * zeros;
7307
7308       ulen = strlen(rslt);
7309
7310       /* Get rid of "000000/ in rooted filespecs */
7311       if (ulen > 7) {
7312         zeros = strstr(rslt, "/000000/");
7313         if (zeros != NULL) {
7314           int mlen;
7315           mlen = ulen - (zeros - rslt) - 7;
7316           memmove(zeros, &zeros[7], mlen);
7317           ulen = ulen - 7;
7318           rslt[ulen] = '\0';
7319         }
7320       }
7321   }
7322
7323   if (vms_debug_fileify) {
7324       fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7325   }
7326   return rslt;
7327
7328 }  /* end of int_tounixspec() */
7329
7330
7331 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7332 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7333 {
7334     static char __tounixspec_retbuf[VMS_MAXRSS];
7335     char * unixspec, *ret_spec, *ret_buf;
7336
7337     unixspec = NULL;
7338     ret_buf = buf;
7339     if (ret_buf == NULL) {
7340         if (ts) {
7341             Newx(unixspec, VMS_MAXRSS, char);
7342             if (unixspec == NULL)
7343                 _ckvmssts(SS$_INSFMEM);
7344             ret_buf = unixspec;
7345         } else {
7346             ret_buf = __tounixspec_retbuf;
7347         }
7348     }
7349
7350     ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7351
7352     if (ret_spec == NULL) {
7353        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7354        if (unixspec)
7355            Safefree(unixspec);
7356     }
7357
7358     return ret_spec;
7359
7360 }  /* end of do_tounixspec() */
7361 /*}}}*/
7362 /* External entry points */
7363 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
7364   { return do_tounixspec(spec,buf,0, NULL); }
7365 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7366   { return do_tounixspec(spec,buf,1, NULL); }
7367 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7368   { return do_tounixspec(spec,buf,0, utf8_fl); }
7369 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7370   { return do_tounixspec(spec,buf,1, utf8_fl); }
7371
7372 #if __CRTL_VER >= 70200000 && !defined(__VAX)
7373
7374 /*
7375  This procedure is used to identify if a path is based in either
7376  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7377  it returns the OpenVMS format directory for it.
7378
7379  It is expecting specifications of only '/' or '/xxxx/'
7380
7381  If a posix root does not exist, or 'xxxx' is not a directory
7382  in the posix root, it returns a failure.
7383
7384  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7385
7386  It is used only internally by posix_to_vmsspec_hardway().
7387  */
7388
7389 static int posix_root_to_vms
7390   (char *vmspath, int vmspath_len,
7391    const char *unixpath,
7392    const int * utf8_fl)
7393 {
7394 int sts;
7395 struct FAB myfab = cc$rms_fab;
7396 rms_setup_nam(mynam);
7397 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7398 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7399 char * esa, * esal, * rsa, * rsal;
7400 char *vms_delim;
7401 int dir_flag;
7402 int unixlen;
7403
7404     dir_flag = 0;
7405     vmspath[0] = '\0';
7406     unixlen = strlen(unixpath);
7407     if (unixlen == 0) {
7408       return RMS$_FNF;
7409     }
7410
7411 #if __CRTL_VER >= 80200000
7412   /* If not a posix spec already, convert it */
7413   if (decc_posix_compliant_pathnames) {
7414     if (strncmp(unixpath,"\"^UP^",5) != 0) {
7415       sprintf(vmspath,"\"^UP^%s\"",unixpath);
7416     }
7417     else {
7418       /* This is already a VMS specification, no conversion */
7419       unixlen--;
7420       strncpy(vmspath,unixpath, vmspath_len);
7421     }
7422   }
7423   else
7424 #endif
7425   {
7426   int path_len;
7427   int i,j;
7428
7429      /* Check to see if this is under the POSIX root */
7430      if (decc_disable_posix_root) {
7431         return RMS$_FNF;
7432      }
7433
7434      /* Skip leading / */
7435      if (unixpath[0] == '/') {
7436         unixpath++;
7437         unixlen--;
7438      }
7439
7440
7441      strcpy(vmspath,"SYS$POSIX_ROOT:");
7442
7443      /* If this is only the / , or blank, then... */
7444      if (unixpath[0] == '\0') {
7445         /* by definition, this is the answer */
7446         return SS$_NORMAL;
7447      }
7448
7449      /* Need to look up a directory */
7450      vmspath[15] = '[';
7451      vmspath[16] = '\0';
7452
7453      /* Copy and add '^' escape characters as needed */
7454      j = 16;
7455      i = 0;
7456      while (unixpath[i] != 0) {
7457      int k;
7458
7459         j += copy_expand_unix_filename_escape
7460             (&vmspath[j], &unixpath[i], &k, utf8_fl);
7461         i += k;
7462      }
7463
7464      path_len = strlen(vmspath);
7465      if (vmspath[path_len - 1] == '/')
7466         path_len--;
7467      vmspath[path_len] = ']';
7468      path_len++;
7469      vmspath[path_len] = '\0';
7470
7471   }
7472   vmspath[vmspath_len] = 0;
7473   if (unixpath[unixlen - 1] == '/')
7474   dir_flag = 1;
7475   esal = PerlMem_malloc(VMS_MAXRSS);
7476   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7477   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7478   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7479   rsal = PerlMem_malloc(VMS_MAXRSS);
7480   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7481   rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7482   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7483   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7484   rms_bind_fab_nam(myfab, mynam);
7485   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7486   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7487   if (decc_efs_case_preserve)
7488     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7489 #ifdef NAML$M_OPEN_SPECIAL
7490   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7491 #endif
7492
7493   /* Set up the remaining naml fields */
7494   sts = sys$parse(&myfab);
7495
7496   /* It failed! Try again as a UNIX filespec */
7497   if (!(sts & 1)) {
7498     PerlMem_free(esal);
7499     PerlMem_free(esa);
7500     PerlMem_free(rsal);
7501     PerlMem_free(rsa);
7502     return sts;
7503   }
7504
7505    /* get the Device ID and the FID */
7506    sts = sys$search(&myfab);
7507
7508    /* These are no longer needed */
7509    PerlMem_free(esa);
7510    PerlMem_free(rsal);
7511    PerlMem_free(rsa);
7512
7513    /* on any failure, returned the POSIX ^UP^ filespec */
7514    if (!(sts & 1)) {
7515       PerlMem_free(esal);
7516       return sts;
7517    }
7518    specdsc.dsc$a_pointer = vmspath;
7519    specdsc.dsc$w_length = vmspath_len;
7520
7521    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7522    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7523    sts = lib$fid_to_name
7524       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7525
7526   /* on any failure, returned the POSIX ^UP^ filespec */
7527   if (!(sts & 1)) {
7528      /* This can happen if user does not have permission to read directories */
7529      if (strncmp(unixpath,"\"^UP^",5) != 0)
7530        sprintf(vmspath,"\"^UP^%s\"",unixpath);
7531      else
7532        strcpy(vmspath, unixpath);
7533   }
7534   else {
7535     vmspath[specdsc.dsc$w_length] = 0;
7536
7537     /* Are we expecting a directory? */
7538     if (dir_flag != 0) {
7539     int i;
7540     char *eptr;
7541
7542       eptr = NULL;
7543
7544       i = specdsc.dsc$w_length - 1;
7545       while (i > 0) {
7546       int zercnt;
7547         zercnt = 0;
7548         /* Version must be '1' */
7549         if (vmspath[i--] != '1')
7550           break;
7551         /* Version delimiter is one of ".;" */
7552         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7553           break;
7554         i--;
7555         if (vmspath[i--] != 'R')
7556           break;
7557         if (vmspath[i--] != 'I')
7558           break;
7559         if (vmspath[i--] != 'D')
7560           break;
7561         if (vmspath[i--] != '.')
7562           break;
7563         eptr = &vmspath[i+1];
7564         while (i > 0) {
7565           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7566             if (vmspath[i-1] != '^') {
7567               if (zercnt != 6) {
7568                 *eptr = vmspath[i];
7569                 eptr[1] = '\0';
7570                 vmspath[i] = '.';
7571                 break;
7572               }
7573               else {
7574                 /* Get rid of 6 imaginary zero directory filename */
7575                 vmspath[i+1] = '\0';
7576               }
7577             }
7578           }
7579           if (vmspath[i] == '0')
7580             zercnt++;
7581           else
7582             zercnt = 10;
7583           i--;
7584         }
7585         break;
7586       }
7587     }
7588   }
7589   PerlMem_free(esal);
7590   return sts;
7591 }
7592
7593 /* /dev/mumble needs to be handled special.
7594    /dev/null becomes NLA0:, And there is the potential for other stuff
7595    like /dev/tty which may need to be mapped to something.
7596 */
7597
7598 static int
7599 slash_dev_special_to_vms
7600    (const char * unixptr,
7601     char * vmspath,
7602     int vmspath_len)
7603 {
7604 char * nextslash;
7605 int len;
7606 int cmp;
7607 int islnm;
7608
7609     unixptr += 4;
7610     nextslash = strchr(unixptr, '/');
7611     len = strlen(unixptr);
7612     if (nextslash != NULL)
7613         len = nextslash - unixptr;
7614     cmp = strncmp("null", unixptr, 5);
7615     if (cmp == 0) {
7616         if (vmspath_len >= 6) {
7617             strcpy(vmspath, "_NLA0:");
7618             return SS$_NORMAL;
7619         }
7620     }
7621 }
7622
7623
7624 /* The built in routines do not understand perl's special needs, so
7625     doing a manual conversion from UNIX to VMS
7626
7627     If the utf8_fl is not null and points to a non-zero value, then
7628     treat 8 bit characters as UTF-8.
7629
7630     The sequence starting with '$(' and ending with ')' will be passed
7631     through with out interpretation instead of being escaped.
7632
7633   */
7634 static int posix_to_vmsspec_hardway
7635   (char *vmspath, int vmspath_len,
7636    const char *unixpath,
7637    int dir_flag,
7638    int * utf8_fl) {
7639
7640 char *esa;
7641 const char *unixptr;
7642 const char *unixend;
7643 char *vmsptr;
7644 const char *lastslash;
7645 const char *lastdot;
7646 int unixlen;
7647 int vmslen;
7648 int dir_start;
7649 int dir_dot;
7650 int quoted;
7651 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7652 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7653
7654   if (utf8_fl != NULL)
7655     *utf8_fl = 0;
7656
7657   unixptr = unixpath;
7658   dir_dot = 0;
7659
7660   /* Ignore leading "/" characters */
7661   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7662     unixptr++;
7663   }
7664   unixlen = strlen(unixptr);
7665
7666   /* Do nothing with blank paths */
7667   if (unixlen == 0) {
7668     vmspath[0] = '\0';
7669     return SS$_NORMAL;
7670   }
7671
7672   quoted = 0;
7673   /* This could have a "^UP^ on the front */
7674   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7675     quoted = 1;
7676     unixptr+= 5;
7677     unixlen-= 5;
7678   }
7679
7680   lastslash = strrchr(unixptr,'/');
7681   lastdot = strrchr(unixptr,'.');
7682   unixend = strrchr(unixptr,'\"');
7683   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7684     unixend = unixptr + unixlen;
7685   }
7686
7687   /* last dot is last dot or past end of string */
7688   if (lastdot == NULL)
7689     lastdot = unixptr + unixlen;
7690
7691   /* if no directories, set last slash to beginning of string */
7692   if (lastslash == NULL) {
7693     lastslash = unixptr;
7694   }
7695   else {
7696     /* Watch out for trailing "." after last slash, still a directory */
7697     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7698       lastslash = unixptr + unixlen;
7699     }
7700
7701     /* Watch out for traiing ".." after last slash, still a directory */
7702     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7703       lastslash = unixptr + unixlen;
7704     }
7705
7706     /* dots in directories are aways escaped */
7707     if (lastdot < lastslash)
7708       lastdot = unixptr + unixlen;
7709   }
7710
7711   /* if (unixptr < lastslash) then we are in a directory */
7712
7713   dir_start = 0;
7714
7715   vmsptr = vmspath;
7716   vmslen = 0;
7717
7718   /* Start with the UNIX path */
7719   if (*unixptr != '/') {
7720     /* relative paths */
7721
7722     /* If allowing logical names on relative pathnames, then handle here */
7723     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7724         !decc_posix_compliant_pathnames) {
7725     char * nextslash;
7726     int seg_len;
7727     char * trn;
7728     int islnm;
7729
7730         /* Find the next slash */
7731         nextslash = strchr(unixptr,'/');
7732
7733         esa = PerlMem_malloc(vmspath_len);
7734         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7735
7736         trn = PerlMem_malloc(VMS_MAXRSS);
7737         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7738
7739         if (nextslash != NULL) {
7740
7741             seg_len = nextslash - unixptr;
7742             strncpy(esa, unixptr, seg_len);
7743             esa[seg_len] = 0;
7744         }
7745         else {
7746             strcpy(esa, unixptr);
7747             seg_len = strlen(unixptr);
7748         }
7749         /* trnlnm(section) */
7750         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7751
7752         if (islnm) {
7753             /* Now fix up the directory */
7754
7755             /* Split up the path to find the components */
7756             sts = vms_split_path
7757                   (trn,
7758                    &v_spec,
7759                    &v_len,
7760                    &r_spec,
7761                    &r_len,
7762                    &d_spec,
7763                    &d_len,
7764                    &n_spec,
7765                    &n_len,
7766                    &e_spec,
7767                    &e_len,
7768                    &vs_spec,
7769                    &vs_len);
7770
7771             while (sts == 0) {
7772             char * strt;
7773             int cmp;
7774
7775                 /* A logical name must be a directory  or the full
7776                    specification.  It is only a full specification if
7777                    it is the only component */
7778                 if ((unixptr[seg_len] == '\0') ||
7779                     (unixptr[seg_len+1] == '\0')) {
7780
7781                     /* Is a directory being required? */
7782                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7783                         /* Not a logical name */
7784                         break;
7785                     }
7786
7787
7788                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7789                         /* This must be a directory */
7790                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7791                             strcpy(vmsptr, esa);
7792                             vmslen=strlen(vmsptr);
7793                             vmsptr[vmslen] = ':';
7794                             vmslen++;
7795                             vmsptr[vmslen] = '\0';
7796                             return SS$_NORMAL;
7797                         }
7798                     }
7799
7800                 }
7801
7802
7803                 /* must be dev/directory - ignore version */
7804                 if ((n_len + e_len) != 0)
7805                     break;
7806
7807                 /* transfer the volume */
7808                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7809                     strncpy(vmsptr, v_spec, v_len);
7810                     vmsptr += v_len;
7811                     vmsptr[0] = '\0';
7812                     vmslen += v_len;
7813                 }
7814
7815                 /* unroot the rooted directory */
7816                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7817                     r_spec[0] = '[';
7818                     r_spec[r_len - 1] = ']';
7819
7820                     /* This should not be there, but nothing is perfect */
7821                     if (r_len > 9) {
7822                         cmp = strcmp(&r_spec[1], "000000.");
7823                         if (cmp == 0) {
7824                             r_spec += 7;
7825                             r_spec[7] = '[';
7826                             r_len -= 7;
7827                             if (r_len == 2)
7828                                 r_len = 0;
7829                         }
7830                     }
7831                     if (r_len > 0) {
7832                         strncpy(vmsptr, r_spec, r_len);
7833                         vmsptr += r_len;
7834                         vmslen += r_len;
7835                         vmsptr[0] = '\0';
7836                     }
7837                 }
7838                 /* Bring over the directory. */
7839                 if ((d_len > 0) &&
7840                     ((d_len + vmslen) < vmspath_len)) {
7841                     d_spec[0] = '[';
7842                     d_spec[d_len - 1] = ']';
7843                     if (d_len > 9) {
7844                         cmp = strcmp(&d_spec[1], "000000.");
7845                         if (cmp == 0) {
7846                             d_spec += 7;
7847                             d_spec[7] = '[';
7848                             d_len -= 7;
7849                             if (d_len == 2)
7850                                 d_len = 0;
7851                         }
7852                     }
7853
7854                     if (r_len > 0) {
7855                         /* Remove the redundant root */
7856                         if (r_len > 0) {
7857                             /* remove the ][ */
7858                             vmsptr--;
7859                             vmslen--;
7860                             d_spec++;
7861                             d_len--;
7862                         }
7863                         strncpy(vmsptr, d_spec, d_len);
7864                             vmsptr += d_len;
7865                             vmslen += d_len;
7866                             vmsptr[0] = '\0';
7867                     }
7868                 }
7869                 break;
7870             }
7871         }
7872
7873         PerlMem_free(esa);
7874         PerlMem_free(trn);
7875     }
7876
7877     if (lastslash > unixptr) {
7878     int dotdir_seen;
7879
7880       /* skip leading ./ */
7881       dotdir_seen = 0;
7882       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7883         dotdir_seen = 1;
7884         unixptr++;
7885         unixptr++;
7886       }
7887
7888       /* Are we still in a directory? */
7889       if (unixptr <= lastslash) {
7890         *vmsptr++ = '[';
7891         vmslen = 1;
7892         dir_start = 1;
7893
7894         /* if not backing up, then it is relative forward. */
7895         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7896               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7897           *vmsptr++ = '.';
7898           vmslen++;
7899           dir_dot = 1;
7900           }
7901        }
7902        else {
7903          if (dotdir_seen) {
7904            /* Perl wants an empty directory here to tell the difference
7905             * between a DCL commmand and a filename
7906             */
7907           *vmsptr++ = '[';
7908           *vmsptr++ = ']';
7909           vmslen = 2;
7910         }
7911       }
7912     }
7913     else {
7914       /* Handle two special files . and .. */
7915       if (unixptr[0] == '.') {
7916         if (&unixptr[1] == unixend) {
7917           *vmsptr++ = '[';
7918           *vmsptr++ = ']';
7919           vmslen += 2;
7920           *vmsptr++ = '\0';
7921           return SS$_NORMAL;
7922         }
7923         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7924           *vmsptr++ = '[';
7925           *vmsptr++ = '-';
7926           *vmsptr++ = ']';
7927           vmslen += 3;
7928           *vmsptr++ = '\0';
7929           return SS$_NORMAL;
7930         }
7931       }
7932     }
7933   }
7934   else {        /* Absolute PATH handling */
7935   int sts;
7936   char * nextslash;
7937   int seg_len;
7938     /* Need to find out where root is */
7939
7940     /* In theory, this procedure should never get an absolute POSIX pathname
7941      * that can not be found on the POSIX root.
7942      * In practice, that can not be relied on, and things will show up
7943      * here that are a VMS device name or concealed logical name instead.
7944      * So to make things work, this procedure must be tolerant.
7945      */
7946     esa = PerlMem_malloc(vmspath_len);
7947     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7948
7949     sts = SS$_NORMAL;
7950     nextslash = strchr(&unixptr[1],'/');
7951     seg_len = 0;
7952     if (nextslash != NULL) {
7953     int cmp;
7954       seg_len = nextslash - &unixptr[1];
7955       strncpy(vmspath, unixptr, seg_len + 1);
7956       vmspath[seg_len+1] = 0;
7957       cmp = 1;
7958       if (seg_len == 3) {
7959         cmp = strncmp(vmspath, "dev", 4);
7960         if (cmp == 0) {
7961             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7962             if (sts = SS$_NORMAL)
7963                 return SS$_NORMAL;
7964         }
7965       }
7966       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
7967     }
7968
7969     if ($VMS_STATUS_SUCCESS(sts)) {
7970       /* This is verified to be a real path */
7971
7972       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7973       if ($VMS_STATUS_SUCCESS(sts)) {
7974         strcpy(vmspath, esa);
7975         vmslen = strlen(vmspath);
7976         vmsptr = vmspath + vmslen;
7977         unixptr++;
7978         if (unixptr < lastslash) {
7979         char * rptr;
7980           vmsptr--;
7981           *vmsptr++ = '.';
7982           dir_start = 1;
7983           dir_dot = 1;
7984           if (vmslen > 7) {
7985           int cmp;
7986             rptr = vmsptr - 7;
7987             cmp = strcmp(rptr,"000000.");
7988             if (cmp == 0) {
7989               vmslen -= 7;
7990               vmsptr -= 7;
7991               vmsptr[1] = '\0';
7992             } /* removing 6 zeros */
7993           } /* vmslen < 7, no 6 zeros possible */
7994         } /* Not in a directory */
7995       } /* Posix root found */
7996       else {
7997         /* No posix root, fall back to default directory */
7998         strcpy(vmspath, "SYS$DISK:[");
7999         vmsptr = &vmspath[10];
8000         vmslen = 10;
8001         if (unixptr > lastslash) {
8002            *vmsptr = ']';
8003            vmsptr++;
8004            vmslen++;
8005         }
8006         else {
8007            dir_start = 1;
8008         }
8009       }
8010     } /* end of verified real path handling */
8011     else {
8012     int add_6zero;
8013     int islnm;
8014
8015       /* Ok, we have a device or a concealed root that is not in POSIX
8016        * or we have garbage.  Make the best of it.
8017        */
8018
8019       /* Posix to VMS destroyed this, so copy it again */
8020       strncpy(vmspath, &unixptr[1], seg_len);
8021       vmspath[seg_len] = 0;
8022       vmslen = seg_len;
8023       vmsptr = &vmsptr[vmslen];
8024       islnm = 0;
8025
8026       /* Now do we need to add the fake 6 zero directory to it? */
8027       add_6zero = 1;
8028       if ((*lastslash == '/') && (nextslash < lastslash)) {
8029         /* No there is another directory */
8030         add_6zero = 0;
8031       }
8032       else {
8033       int trnend;
8034       int cmp;
8035
8036         /* now we have foo:bar or foo:[000000]bar to decide from */
8037         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
8038
8039         if (!islnm && !decc_posix_compliant_pathnames) {
8040
8041             cmp = strncmp("bin", vmspath, 4);
8042             if (cmp == 0) {
8043                 /* bin => SYS$SYSTEM: */
8044                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
8045             }
8046             else {
8047                 /* tmp => SYS$SCRATCH: */
8048                 cmp = strncmp("tmp", vmspath, 4);
8049                 if (cmp == 0) {
8050                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
8051                 }
8052             }
8053         }
8054
8055         trnend = islnm ? islnm - 1 : 0;
8056
8057         /* if this was a logical name, ']' or '>' must be present */
8058         /* if not a logical name, then assume a device and hope. */
8059         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
8060
8061         /* if log name and trailing '.' then rooted - treat as device */
8062         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
8063
8064         /* Fix me, if not a logical name, a device lookup should be
8065          * done to see if the device is file structured.  If the device
8066          * is not file structured, the 6 zeros should not be put on.
8067          *
8068          * As it is, perl is occasionally looking for dev:[000000]tty.
8069          * which looks a little strange.
8070          *
8071          * Not that easy to detect as "/dev" may be file structured with
8072          * special device files.
8073          */
8074
8075         if ((add_6zero == 0) && (*nextslash == '/') &&
8076             (&nextslash[1] == unixend)) {
8077           /* No real directory present */
8078           add_6zero = 1;
8079         }
8080       }
8081
8082       /* Put the device delimiter on */
8083       *vmsptr++ = ':';
8084       vmslen++;
8085       unixptr = nextslash;
8086       unixptr++;
8087
8088       /* Start directory if needed */
8089       if (!islnm || add_6zero) {
8090         *vmsptr++ = '[';
8091         vmslen++;
8092         dir_start = 1;
8093       }
8094
8095       /* add fake 000000] if needed */
8096       if (add_6zero) {
8097         *vmsptr++ = '0';
8098         *vmsptr++ = '0';
8099         *vmsptr++ = '0';
8100         *vmsptr++ = '0';
8101         *vmsptr++ = '0';
8102         *vmsptr++ = '0';
8103         *vmsptr++ = ']';
8104         vmslen += 7;
8105         dir_start = 0;
8106       }
8107
8108     } /* non-POSIX translation */
8109     PerlMem_free(esa);
8110   } /* End of relative/absolute path handling */
8111
8112   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
8113   int dash_flag;
8114   int in_cnt;
8115   int out_cnt;
8116
8117     dash_flag = 0;
8118
8119     if (dir_start != 0) {
8120
8121       /* First characters in a directory are handled special */
8122       while ((*unixptr == '/') ||
8123              ((*unixptr == '.') &&
8124               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8125                 (&unixptr[1]==unixend)))) {
8126       int loop_flag;
8127
8128         loop_flag = 0;
8129
8130         /* Skip redundant / in specification */
8131         while ((*unixptr == '/') && (dir_start != 0)) {
8132           loop_flag = 1;
8133           unixptr++;
8134           if (unixptr == lastslash)
8135             break;
8136         }
8137         if (unixptr == lastslash)
8138           break;
8139
8140         /* Skip redundant ./ characters */
8141         while ((*unixptr == '.') &&
8142                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8143           loop_flag = 1;
8144           unixptr++;
8145           if (unixptr == lastslash)
8146             break;
8147           if (*unixptr == '/')
8148             unixptr++;
8149         }
8150         if (unixptr == lastslash)
8151           break;
8152
8153         /* Skip redundant ../ characters */
8154         while ((*unixptr == '.') && (unixptr[1] == '.') &&
8155              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8156           /* Set the backing up flag */
8157           loop_flag = 1;
8158           dir_dot = 0;
8159           dash_flag = 1;
8160           *vmsptr++ = '-';
8161           vmslen++;
8162           unixptr++; /* first . */
8163           unixptr++; /* second . */
8164           if (unixptr == lastslash)
8165             break;
8166           if (*unixptr == '/') /* The slash */
8167             unixptr++;
8168         }
8169         if (unixptr == lastslash)
8170           break;
8171
8172         /* To do: Perl expects /.../ to be translated to [...] on VMS */
8173         /* Not needed when VMS is pretending to be UNIX. */
8174
8175         /* Is this loop stuck because of too many dots? */
8176         if (loop_flag == 0) {
8177           /* Exit the loop and pass the rest through */
8178           break;
8179         }
8180       }
8181
8182       /* Are we done with directories yet? */
8183       if (unixptr >= lastslash) {
8184
8185         /* Watch out for trailing dots */
8186         if (dir_dot != 0) {
8187             vmslen --;
8188             vmsptr--;
8189         }
8190         *vmsptr++ = ']';
8191         vmslen++;
8192         dash_flag = 0;
8193         dir_start = 0;
8194         if (*unixptr == '/')
8195           unixptr++;
8196       }
8197       else {
8198         /* Have we stopped backing up? */
8199         if (dash_flag) {
8200           *vmsptr++ = '.';
8201           vmslen++;
8202           dash_flag = 0;
8203           /* dir_start continues to be = 1 */
8204         }
8205         if (*unixptr == '-') {
8206           *vmsptr++ = '^';
8207           *vmsptr++ = *unixptr++;
8208           vmslen += 2;
8209           dir_start = 0;
8210
8211           /* Now are we done with directories yet? */
8212           if (unixptr >= lastslash) {
8213
8214             /* Watch out for trailing dots */
8215             if (dir_dot != 0) {
8216               vmslen --;
8217               vmsptr--;
8218             }
8219
8220             *vmsptr++ = ']';
8221             vmslen++;
8222             dash_flag = 0;
8223             dir_start = 0;
8224           }
8225         }
8226       }
8227     }
8228
8229     /* All done? */
8230     if (unixptr >= unixend)
8231       break;
8232
8233     /* Normal characters - More EFS work probably needed */
8234     dir_start = 0;
8235     dir_dot = 0;
8236
8237     switch(*unixptr) {
8238     case '/':
8239         /* remove multiple / */
8240         while (unixptr[1] == '/') {
8241            unixptr++;
8242         }
8243         if (unixptr == lastslash) {
8244           /* Watch out for trailing dots */
8245           if (dir_dot != 0) {
8246             vmslen --;
8247             vmsptr--;
8248           }
8249           *vmsptr++ = ']';
8250         }
8251         else {
8252           dir_start = 1;
8253           *vmsptr++ = '.';
8254           dir_dot = 1;
8255
8256           /* To do: Perl expects /.../ to be translated to [...] on VMS */
8257           /* Not needed when VMS is pretending to be UNIX. */
8258
8259         }
8260         dash_flag = 0;
8261         if (unixptr != unixend)
8262           unixptr++;
8263         vmslen++;
8264         break;
8265     case '.':
8266         if ((unixptr < lastdot) || (unixptr < lastslash) ||
8267             (&unixptr[1] == unixend)) {
8268           *vmsptr++ = '^';
8269           *vmsptr++ = '.';
8270           vmslen += 2;
8271           unixptr++;
8272
8273           /* trailing dot ==> '^..' on VMS */
8274           if (unixptr == unixend) {
8275             *vmsptr++ = '.';
8276             vmslen++;
8277             unixptr++;
8278           }
8279           break;
8280         }
8281
8282         *vmsptr++ = *unixptr++;
8283         vmslen ++;
8284         break;
8285     case '"':
8286         if (quoted && (&unixptr[1] == unixend)) {
8287             unixptr++;
8288             break;
8289         }
8290         in_cnt = copy_expand_unix_filename_escape
8291                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8292         vmsptr += out_cnt;
8293         unixptr += in_cnt;
8294         break;
8295     case '~':
8296     case ';':
8297     case '\\':
8298     case '?':
8299     case ' ':
8300     default:
8301         in_cnt = copy_expand_unix_filename_escape
8302                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8303         vmsptr += out_cnt;
8304         unixptr += in_cnt;
8305         break;
8306     }
8307   }
8308
8309   /* Make sure directory is closed */
8310   if (unixptr == lastslash) {
8311     char *vmsptr2;
8312     vmsptr2 = vmsptr - 1;
8313
8314     if (*vmsptr2 != ']') {
8315       *vmsptr2--;
8316
8317       /* directories do not end in a dot bracket */
8318       if (*vmsptr2 == '.') {
8319         vmsptr2--;
8320
8321         /* ^. is allowed */
8322         if (*vmsptr2 != '^') {
8323           vmsptr--; /* back up over the dot */
8324         }
8325       }
8326       *vmsptr++ = ']';
8327     }
8328   }
8329   else {
8330     char *vmsptr2;
8331     /* Add a trailing dot if a file with no extension */
8332     vmsptr2 = vmsptr - 1;
8333     if ((vmslen > 1) &&
8334         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8335         (*vmsptr2 != ')') && (*lastdot != '.')) {
8336         *vmsptr++ = '.';
8337         vmslen++;
8338     }
8339   }
8340
8341   *vmsptr = '\0';
8342   return SS$_NORMAL;
8343 }
8344 #endif
8345
8346  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
8347 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
8348 {
8349 char * result;
8350 int utf8_flag;
8351
8352    /* If a UTF8 flag is being passed, honor it */
8353    utf8_flag = 0;
8354    if (utf8_fl != NULL) {
8355      utf8_flag = *utf8_fl;
8356     *utf8_fl = 0;
8357    }
8358
8359    if (utf8_flag) {
8360      /* If there is a possibility of UTF8, then if any UTF8 characters
8361         are present, then they must be converted to VTF-7
8362       */
8363      result = strcpy(rslt, path); /* FIX-ME */
8364    }
8365    else
8366      result = strcpy(rslt, path);
8367
8368    return result;
8369 }
8370
8371
8372
8373 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8374 static char *int_tovmsspec
8375    (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
8376   char *dirend;
8377   char *lastdot;
8378   char *vms_delim;
8379   register char *cp1;
8380   const char *cp2;
8381   unsigned long int infront = 0, hasdir = 1;
8382   int rslt_len;
8383   int no_type_seen;
8384   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8385   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8386
8387   if (vms_debug_fileify) {
8388       if (path == NULL)
8389           fprintf(stderr, "int_tovmsspec: path = NULL\n");
8390       else
8391           fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8392   }
8393
8394   if (path == NULL) {
8395       /* If we fail, we should be setting errno */
8396       set_errno(EINVAL);
8397       set_vaxc_errno(SS$_BADPARAM);
8398       return NULL;
8399   }
8400   rslt_len = VMS_MAXRSS-1;
8401
8402   /* '.' and '..' are "[]" and "[-]" for a quick check */
8403   if (path[0] == '.') {
8404     if (path[1] == '\0') {
8405       strcpy(rslt,"[]");
8406       if (utf8_flag != NULL)
8407         *utf8_flag = 0;
8408       return rslt;
8409     }
8410     else {
8411       if (path[1] == '.' && path[2] == '\0') {
8412         strcpy(rslt,"[-]");
8413         if (utf8_flag != NULL)
8414            *utf8_flag = 0;
8415         return rslt;
8416       }
8417     }
8418   }
8419
8420    /* Posix specifications are now a native VMS format */
8421   /*--------------------------------------------------*/
8422 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8423   if (decc_posix_compliant_pathnames) {
8424     if (strncmp(path,"\"^UP^",5) == 0) {
8425       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8426       return rslt;
8427     }
8428   }
8429 #endif
8430
8431   /* This is really the only way to see if this is already in VMS format */
8432   sts = vms_split_path
8433        (path,
8434         &v_spec,
8435         &v_len,
8436         &r_spec,
8437         &r_len,
8438         &d_spec,
8439         &d_len,
8440         &n_spec,
8441         &n_len,
8442         &e_spec,
8443         &e_len,
8444         &vs_spec,
8445         &vs_len);
8446   if (sts == 0) {
8447     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8448        replacement, because the above parse just took care of most of
8449        what is needed to do vmspath when the specification is already
8450        in VMS format.
8451
8452        And if it is not already, it is easier to do the conversion as
8453        part of this routine than to call this routine and then work on
8454        the result.
8455      */
8456
8457     /* If VMS punctuation was found, it is already VMS format */
8458     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8459       if (utf8_flag != NULL)
8460         *utf8_flag = 0;
8461       strcpy(rslt, path);
8462       if (vms_debug_fileify) {
8463           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8464       }
8465       return rslt;
8466     }
8467     /* Now, what to do with trailing "." cases where there is no
8468        extension?  If this is a UNIX specification, and EFS characters
8469        are enabled, then the trailing "." should be converted to a "^.".
8470        But if this was already a VMS specification, then it should be
8471        left alone.
8472
8473        So in the case of ambiguity, leave the specification alone.
8474      */
8475
8476
8477     /* If there is a possibility of UTF8, then if any UTF8 characters
8478         are present, then they must be converted to VTF-7
8479      */
8480     if (utf8_flag != NULL)
8481       *utf8_flag = 0;
8482     strcpy(rslt, path);
8483     if (vms_debug_fileify) {
8484         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8485     }
8486     return rslt;
8487   }
8488
8489   dirend = strrchr(path,'/');
8490
8491   if (dirend == NULL) {
8492      char *macro_start;
8493      int has_macro;
8494
8495      /* If we get here with no UNIX directory delimiters, then this is
8496         not a complete file specification, either garbage a UNIX glob
8497         specification that can not be converted to a VMS wildcard, or
8498         it a UNIX shell macro.  MakeMaker wants shell macros passed
8499         through AS-IS,
8500
8501         utf8 flag setting needs to be preserved.
8502       */
8503       hasdir = 0;
8504
8505       has_macro = 0;
8506       macro_start = strchr(path,'$');
8507       if (macro_start != NULL) {
8508           if (macro_start[1] == '(') {
8509               has_macro = 1;
8510           }
8511       }
8512       if ((decc_efs_charset == 0) || (has_macro)) {
8513           strcpy(rslt, path);
8514           if (vms_debug_fileify) {
8515               fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8516           }
8517           return rslt;
8518       }
8519   }
8520
8521 /* If POSIX mode active, handle the conversion */
8522 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8523   if (decc_efs_charset) {
8524     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8525     if (vms_debug_fileify) {
8526         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8527     }
8528     return rslt;
8529   }
8530 #endif
8531
8532   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
8533     if (!*(dirend+2)) dirend +=2;
8534     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8535     if (decc_efs_charset == 0) {
8536       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8537     }
8538   }
8539
8540   cp1 = rslt;
8541   cp2 = path;
8542   lastdot = strrchr(cp2,'.');
8543   if (*cp2 == '/') {
8544     char *trndev;
8545     int islnm, rooted;
8546     STRLEN trnend;
8547
8548     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8549     if (!*(cp2+1)) {
8550       if (decc_disable_posix_root) {
8551         strcpy(rslt,"sys$disk:[000000]");
8552       }
8553       else {
8554         strcpy(rslt,"sys$posix_root:[000000]");
8555       }
8556       if (utf8_flag != NULL)
8557         *utf8_flag = 0;
8558       if (vms_debug_fileify) {
8559           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8560       }
8561       return rslt;
8562     }
8563     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8564     *cp1 = '\0';
8565     trndev = PerlMem_malloc(VMS_MAXRSS);
8566     if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8567     islnm =  simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8568
8569      /* DECC special handling */
8570     if (!islnm) {
8571       if (strcmp(rslt,"bin") == 0) {
8572         strcpy(rslt,"sys$system");
8573         cp1 = rslt + 10;
8574         *cp1 = 0;
8575         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8576       }
8577       else if (strcmp(rslt,"tmp") == 0) {
8578         strcpy(rslt,"sys$scratch");
8579         cp1 = rslt + 11;
8580         *cp1 = 0;
8581         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8582       }
8583       else if (!decc_disable_posix_root) {
8584         strcpy(rslt, "sys$posix_root");
8585         cp1 = rslt + 14;
8586         *cp1 = 0;
8587         cp2 = path;
8588         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8589         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8590       }
8591       else if (strcmp(rslt,"dev") == 0) {
8592         if (strncmp(cp2,"/null", 5) == 0) {
8593           if ((cp2[5] == 0) || (cp2[5] == '/')) {
8594             strcpy(rslt,"NLA0");
8595             cp1 = rslt + 4;
8596             *cp1 = 0;
8597             cp2 = cp2 + 5;
8598             islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8599           }
8600         }
8601       }
8602     }
8603
8604     trnend = islnm ? strlen(trndev) - 1 : 0;
8605     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8606     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8607     /* If the first element of the path is a logical name, determine
8608      * whether it has to be translated so we can add more directories. */
8609     if (!islnm || rooted) {
8610       *(cp1++) = ':';
8611       *(cp1++) = '[';
8612       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8613       else cp2++;
8614     }
8615     else {
8616       if (cp2 != dirend) {
8617         strcpy(rslt,trndev);
8618         cp1 = rslt + trnend;
8619         if (*cp2 != 0) {
8620           *(cp1++) = '.';
8621           cp2++;
8622         }
8623       }
8624       else {
8625         if (decc_disable_posix_root) {
8626           *(cp1++) = ':';
8627           hasdir = 0;
8628         }
8629       }
8630     }
8631     PerlMem_free(trndev);
8632   }
8633   else {
8634     *(cp1++) = '[';
8635     if (*cp2 == '.') {
8636       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8637         cp2 += 2;         /* skip over "./" - it's redundant */
8638         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8639       }
8640       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8641         *(cp1++) = '-';                                 /* "../" --> "-" */
8642         cp2 += 3;
8643       }
8644       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8645                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8646         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8647         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8648         cp2 += 4;
8649       }
8650       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8651         /* Escape the extra dots in EFS file specifications */
8652         *(cp1++) = '^';
8653       }
8654       if (cp2 > dirend) cp2 = dirend;
8655     }
8656     else *(cp1++) = '.';
8657   }
8658   for (; cp2 < dirend; cp2++) {
8659     if (*cp2 == '/') {
8660       if (*(cp2-1) == '/') continue;
8661       if (*(cp1-1) != '.') *(cp1++) = '.';
8662       infront = 0;
8663     }
8664     else if (!infront && *cp2 == '.') {
8665       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8666       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8667       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8668         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8669         else if (*(cp1-2) == '[') *(cp1-1) = '-';
8670         else {  /* back up over previous directory name */
8671           cp1--;
8672           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
8673           if (*(cp1-1) == '[') {
8674             memcpy(cp1,"000000.",7);
8675             cp1 += 7;
8676           }
8677         }
8678         cp2 += 2;
8679         if (cp2 == dirend) break;
8680       }
8681       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8682                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8683         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8684         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8685         if (!*(cp2+3)) {
8686           *(cp1++) = '.';  /* Simulate trailing '/' */
8687           cp2 += 2;  /* for loop will incr this to == dirend */
8688         }
8689         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8690       }
8691       else {
8692         if (decc_efs_charset == 0)
8693           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8694         else {
8695           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
8696           *(cp1++) = '.';
8697         }
8698       }
8699     }
8700     else {
8701       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
8702       if (*cp2 == '.') {
8703         if (decc_efs_charset == 0)
8704           *(cp1++) = '_';
8705         else {
8706           *(cp1++) = '^';
8707           *(cp1++) = '.';
8708         }
8709       }
8710       else                  *(cp1++) =  *cp2;
8711       infront = 1;
8712     }
8713   }
8714   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8715   if (hasdir) *(cp1++) = ']';
8716   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
8717   /* fixme for ODS5 */
8718   no_type_seen = 0;
8719   if (cp2 > lastdot)
8720     no_type_seen = 1;
8721   while (*cp2) {
8722     switch(*cp2) {
8723     case '?':
8724         if (decc_efs_charset == 0)
8725           *(cp1++) = '%';
8726         else
8727           *(cp1++) = '?';
8728         cp2++;
8729     case ' ':
8730         *(cp1)++ = '^';
8731         *(cp1)++ = '_';
8732         cp2++;
8733         break;
8734     case '.':
8735         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8736             decc_readdir_dropdotnotype) {
8737           *(cp1)++ = '^';
8738           *(cp1)++ = '.';
8739           cp2++;
8740
8741           /* trailing dot ==> '^..' on VMS */
8742           if (*cp2 == '\0') {
8743             *(cp1++) = '.';
8744             no_type_seen = 0;
8745           }
8746         }
8747         else {
8748           *(cp1++) = *(cp2++);
8749           no_type_seen = 0;
8750         }
8751         break;
8752     case '$':
8753          /* This could be a macro to be passed through */
8754         *(cp1++) = *(cp2++);
8755         if (*cp2 == '(') {
8756         const char * save_cp2;
8757         char * save_cp1;
8758         int is_macro;
8759
8760             /* paranoid check */
8761             save_cp2 = cp2;
8762             save_cp1 = cp1;
8763             is_macro = 0;
8764
8765             /* Test through */
8766             *(cp1++) = *(cp2++);
8767             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8768                 *(cp1++) = *(cp2++);
8769                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8770                     *(cp1++) = *(cp2++);
8771                 }
8772                 if (*cp2 == ')') {
8773                     *(cp1++) = *(cp2++);
8774                     is_macro = 1;
8775                 }
8776             }
8777             if (is_macro == 0) {
8778                 /* Not really a macro - never mind */
8779                 cp2 = save_cp2;
8780                 cp1 = save_cp1;
8781             }
8782         }
8783         break;
8784     case '\"':
8785     case '~':
8786     case '`':
8787     case '!':
8788     case '#':
8789     case '%':
8790     case '^':
8791         /* Don't escape again if following character is
8792          * already something we escape.
8793          */
8794         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8795             *(cp1++) = *(cp2++);
8796             break;
8797         }
8798         /* But otherwise fall through and escape it. */
8799     case '&':
8800     case '(':
8801     case ')':
8802     case '=':
8803     case '+':
8804     case '\'':
8805     case '@':
8806     case '[':
8807     case ']':
8808     case '{':
8809     case '}':
8810     case ':':
8811     case '\\':
8812     case '|':
8813     case '<':
8814     case '>':
8815         *(cp1++) = '^';
8816         *(cp1++) = *(cp2++);
8817         break;
8818     case ';':
8819         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8820          * which is wrong.  UNIX notation should be ".dir." unless
8821          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8822          * changing this behavior could break more things at this time.
8823          * efs character set effectively does not allow "." to be a version
8824          * delimiter as a further complication about changing this.
8825          */
8826         if (decc_filename_unix_report != 0) {
8827           *(cp1++) = '^';
8828         }
8829         *(cp1++) = *(cp2++);
8830         break;
8831     default:
8832         *(cp1++) = *(cp2++);
8833     }
8834   }
8835   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8836   char *lcp1;
8837     lcp1 = cp1;
8838     lcp1--;
8839      /* Fix me for "^]", but that requires making sure that you do
8840       * not back up past the start of the filename
8841       */
8842     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8843       *cp1++ = '.';
8844   }
8845   *cp1 = '\0';
8846
8847   if (utf8_flag != NULL)
8848     *utf8_flag = 0;
8849   if (vms_debug_fileify) {
8850       fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8851   }
8852   return rslt;
8853
8854 }  /* end of int_tovmsspec() */
8855
8856
8857 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8858 static char *mp_do_tovmsspec
8859    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
8860   static char __tovmsspec_retbuf[VMS_MAXRSS];
8861     char * vmsspec, *ret_spec, *ret_buf;
8862
8863     vmsspec = NULL;
8864     ret_buf = buf;
8865     if (ret_buf == NULL) {
8866         if (ts) {
8867             Newx(vmsspec, VMS_MAXRSS, char);
8868             if (vmsspec == NULL)
8869                 _ckvmssts(SS$_INSFMEM);
8870             ret_buf = vmsspec;
8871         } else {
8872             ret_buf = __tovmsspec_retbuf;
8873         }
8874     }
8875
8876     ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
8877
8878     if (ret_spec == NULL) {
8879        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
8880        if (vmsspec)
8881            Safefree(vmsspec);
8882     }
8883
8884     return ret_spec;
8885
8886 }  /* end of mp_do_tovmsspec() */
8887 /*}}}*/
8888 /* External entry points */
8889 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8890   { return do_tovmsspec(path,buf,0,NULL); }
8891 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8892   { return do_tovmsspec(path,buf,1,NULL); }
8893 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8894   { return do_tovmsspec(path,buf,0,utf8_fl); }
8895 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8896   { return do_tovmsspec(path,buf,1,utf8_fl); }
8897
8898 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8899 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8900   static char __tovmspath_retbuf[VMS_MAXRSS];
8901   int vmslen;
8902   char *pathified, *vmsified, *cp;
8903
8904   if (path == NULL) return NULL;
8905   pathified = PerlMem_malloc(VMS_MAXRSS);
8906   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8907   if (int_pathify_dirspec(path, pathified) == NULL) {
8908     PerlMem_free(pathified);
8909     return NULL;
8910   }
8911
8912   vmsified = NULL;
8913   if (buf == NULL)
8914      Newx(vmsified, VMS_MAXRSS, char);
8915   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8916     PerlMem_free(pathified);
8917     if (vmsified) Safefree(vmsified);
8918     return NULL;
8919   }
8920   PerlMem_free(pathified);
8921   if (buf) {
8922     return buf;
8923   }
8924   else if (ts) {
8925     vmslen = strlen(vmsified);
8926     Newx(cp,vmslen+1,char);
8927     memcpy(cp,vmsified,vmslen);
8928     cp[vmslen] = '\0';
8929     Safefree(vmsified);
8930     return cp;
8931   }
8932   else {
8933     strcpy(__tovmspath_retbuf,vmsified);
8934     Safefree(vmsified);
8935     return __tovmspath_retbuf;
8936   }
8937
8938 }  /* end of do_tovmspath() */
8939 /*}}}*/
8940 /* External entry points */
8941 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8942   { return do_tovmspath(path,buf,0, NULL); }
8943 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8944   { return do_tovmspath(path,buf,1, NULL); }
8945 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8946   { return do_tovmspath(path,buf,0,utf8_fl); }
8947 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8948   { return do_tovmspath(path,buf,1,utf8_fl); }
8949
8950
8951 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8952 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8953   static char __tounixpath_retbuf[VMS_MAXRSS];
8954   int unixlen;
8955   char *pathified, *unixified, *cp;
8956
8957   if (path == NULL) return NULL;
8958   pathified = PerlMem_malloc(VMS_MAXRSS);
8959   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8960   if (int_pathify_dirspec(path, pathified) == NULL) {
8961     PerlMem_free(pathified);
8962     return NULL;
8963   }
8964
8965   unixified = NULL;
8966   if (buf == NULL) {
8967       Newx(unixified, VMS_MAXRSS, char);
8968   }
8969   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
8970     PerlMem_free(pathified);
8971     if (unixified) Safefree(unixified);
8972     return NULL;
8973   }
8974   PerlMem_free(pathified);
8975   if (buf) {
8976     return buf;
8977   }
8978   else if (ts) {
8979     unixlen = strlen(unixified);
8980     Newx(cp,unixlen+1,char);
8981     memcpy(cp,unixified,unixlen);
8982     cp[unixlen] = '\0';
8983     Safefree(unixified);
8984     return cp;
8985   }
8986   else {
8987     strcpy(__tounixpath_retbuf,unixified);
8988     Safefree(unixified);
8989     return __tounixpath_retbuf;
8990   }
8991
8992 }  /* end of do_tounixpath() */
8993 /*}}}*/
8994 /* External entry points */
8995 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8996   { return do_tounixpath(path,buf,0,NULL); }
8997 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8998   { return do_tounixpath(path,buf,1,NULL); }
8999 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9000   { return do_tounixpath(path,buf,0,utf8_fl); }
9001 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9002   { return do_tounixpath(path,buf,1,utf8_fl); }
9003
9004 /*
9005  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
9006  *
9007  *****************************************************************************
9008  *                                                                           *
9009  *  Copyright (C) 1989-1994, 2007 by                                         *
9010  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
9011  *                                                                           *
9012  *  Permission is hereby granted for the reproduction of this software       *
9013  *  on condition that this copyright notice is included in source            *
9014  *  distributions of the software.  The code may be modified and             *
9015  *  distributed under the same terms as Perl itself.                         *
9016  *                                                                           *
9017  *  27-Aug-1994 Modified for inclusion in perl5                              *
9018  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
9019  *****************************************************************************
9020  */
9021
9022 /*
9023  * getredirection() is intended to aid in porting C programs
9024  * to VMS (Vax-11 C).  The native VMS environment does not support
9025  * '>' and '<' I/O redirection, or command line wild card expansion,
9026  * or a command line pipe mechanism using the '|' AND background
9027  * command execution '&'.  All of these capabilities are provided to any
9028  * C program which calls this procedure as the first thing in the
9029  * main program.
9030  * The piping mechanism will probably work with almost any 'filter' type
9031  * of program.  With suitable modification, it may useful for other
9032  * portability problems as well.
9033  *
9034  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
9035  */
9036 struct list_item
9037     {
9038     struct list_item *next;
9039     char *value;
9040     };
9041
9042 static void add_item(struct list_item **head,
9043                      struct list_item **tail,
9044                      char *value,
9045                      int *count);
9046
9047 static void mp_expand_wild_cards(pTHX_ char *item,
9048                                 struct list_item **head,
9049                                 struct list_item **tail,
9050                                 int *count);
9051
9052 static int background_process(pTHX_ int argc, char **argv);
9053
9054 static void pipe_and_fork(pTHX_ char **cmargv);
9055
9056 /*{{{ void getredirection(int *ac, char ***av)*/
9057 static void
9058 mp_getredirection(pTHX_ int *ac, char ***av)
9059 /*
9060  * Process vms redirection arg's.  Exit if any error is seen.
9061  * If getredirection() processes an argument, it is erased
9062  * from the vector.  getredirection() returns a new argc and argv value.
9063  * In the event that a background command is requested (by a trailing "&"),
9064  * this routine creates a background subprocess, and simply exits the program.
9065  *
9066  * Warning: do not try to simplify the code for vms.  The code
9067  * presupposes that getredirection() is called before any data is
9068  * read from stdin or written to stdout.
9069  *
9070  * Normal usage is as follows:
9071  *
9072  *      main(argc, argv)
9073  *      int             argc;
9074  *      char            *argv[];
9075  *      {
9076  *              getredirection(&argc, &argv);
9077  *      }
9078  */
9079 {
9080     int                 argc = *ac;     /* Argument Count         */
9081     char                **argv = *av;   /* Argument Vector        */
9082     char                *ap;            /* Argument pointer       */
9083     int                 j;              /* argv[] index           */
9084     int                 item_count = 0; /* Count of Items in List */
9085     struct list_item    *list_head = 0; /* First Item in List       */
9086     struct list_item    *list_tail;     /* Last Item in List        */
9087     char                *in = NULL;     /* Input File Name          */
9088     char                *out = NULL;    /* Output File Name         */
9089     char                *outmode = "w"; /* Mode to Open Output File */
9090     char                *err = NULL;    /* Error File Name          */
9091     char                *errmode = "w"; /* Mode to Open Error File  */
9092     int                 cmargc = 0;     /* Piped Command Arg Count  */
9093     char                **cmargv = NULL;/* Piped Command Arg Vector */
9094
9095     /*
9096      * First handle the case where the last thing on the line ends with
9097      * a '&'.  This indicates the desire for the command to be run in a
9098      * subprocess, so we satisfy that desire.
9099      */
9100     ap = argv[argc-1];
9101     if (0 == strcmp("&", ap))
9102        exit(background_process(aTHX_ --argc, argv));
9103     if (*ap && '&' == ap[strlen(ap)-1])
9104         {
9105         ap[strlen(ap)-1] = '\0';
9106        exit(background_process(aTHX_ argc, argv));
9107         }
9108     /*
9109      * Now we handle the general redirection cases that involve '>', '>>',
9110      * '<', and pipes '|'.
9111      */
9112     for (j = 0; j < argc; ++j)
9113         {
9114         if (0 == strcmp("<", argv[j]))
9115             {
9116             if (j+1 >= argc)
9117                 {
9118                 fprintf(stderr,"No input file after < on command line");
9119                 exit(LIB$_WRONUMARG);
9120                 }
9121             in = argv[++j];
9122             continue;
9123             }
9124         if ('<' == *(ap = argv[j]))
9125             {
9126             in = 1 + ap;
9127             continue;
9128             }
9129         if (0 == strcmp(">", ap))
9130             {
9131             if (j+1 >= argc)
9132                 {
9133                 fprintf(stderr,"No output file after > on command line");
9134                 exit(LIB$_WRONUMARG);
9135                 }
9136             out = argv[++j];
9137             continue;
9138             }
9139         if ('>' == *ap)
9140             {
9141             if ('>' == ap[1])
9142                 {
9143                 outmode = "a";
9144                 if ('\0' == ap[2])
9145                     out = argv[++j];
9146                 else
9147                     out = 2 + ap;
9148                 }
9149             else
9150                 out = 1 + ap;
9151             if (j >= argc)
9152                 {
9153                 fprintf(stderr,"No output file after > or >> on command line");
9154                 exit(LIB$_WRONUMARG);
9155                 }
9156             continue;
9157             }
9158         if (('2' == *ap) && ('>' == ap[1]))
9159             {
9160             if ('>' == ap[2])
9161                 {
9162                 errmode = "a";
9163                 if ('\0' == ap[3])
9164                     err = argv[++j];
9165                 else
9166                     err = 3 + ap;
9167                 }
9168             else
9169                 if ('\0' == ap[2])
9170                     err = argv[++j];
9171                 else
9172                     err = 2 + ap;
9173             if (j >= argc)
9174                 {
9175                 fprintf(stderr,"No output file after 2> or 2>> on command line");
9176                 exit(LIB$_WRONUMARG);
9177                 }
9178             continue;
9179             }
9180         if (0 == strcmp("|", argv[j]))
9181             {
9182             if (j+1 >= argc)
9183                 {
9184                 fprintf(stderr,"No command into which to pipe on command line");
9185                 exit(LIB$_WRONUMARG);
9186                 }
9187             cmargc = argc-(j+1);
9188             cmargv = &argv[j+1];
9189             argc = j;
9190             continue;
9191             }
9192         if ('|' == *(ap = argv[j]))
9193             {
9194             ++argv[j];
9195             cmargc = argc-j;
9196             cmargv = &argv[j];
9197             argc = j;
9198             continue;
9199             }
9200         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9201         }
9202     /*
9203      * Allocate and fill in the new argument vector, Some Unix's terminate
9204      * the list with an extra null pointer.
9205      */
9206     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9207     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9208     *av = argv;
9209     for (j = 0; j < item_count; ++j, list_head = list_head->next)
9210         argv[j] = list_head->value;
9211     *ac = item_count;
9212     if (cmargv != NULL)
9213         {
9214         if (out != NULL)
9215             {
9216             fprintf(stderr,"'|' and '>' may not both be specified on command line");
9217             exit(LIB$_INVARGORD);
9218             }
9219         pipe_and_fork(aTHX_ cmargv);
9220         }
9221
9222     /* Check for input from a pipe (mailbox) */
9223
9224     if (in == NULL && 1 == isapipe(0))
9225         {
9226         char mbxname[L_tmpnam];
9227         long int bufsize;
9228         long int dvi_item = DVI$_DEVBUFSIZ;
9229         $DESCRIPTOR(mbxnam, "");
9230         $DESCRIPTOR(mbxdevnam, "");
9231
9232         /* Input from a pipe, reopen it in binary mode to disable       */
9233         /* carriage control processing.                                 */
9234
9235         fgetname(stdin, mbxname);
9236         mbxnam.dsc$a_pointer = mbxname;
9237         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9238         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9239         mbxdevnam.dsc$a_pointer = mbxname;
9240         mbxdevnam.dsc$w_length = sizeof(mbxname);
9241         dvi_item = DVI$_DEVNAM;
9242         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9243         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9244         set_errno(0);
9245         set_vaxc_errno(1);
9246         freopen(mbxname, "rb", stdin);
9247         if (errno != 0)
9248             {
9249             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9250             exit(vaxc$errno);
9251             }
9252         }
9253     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9254         {
9255         fprintf(stderr,"Can't open input file %s as stdin",in);
9256         exit(vaxc$errno);
9257         }
9258     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9259         {
9260         fprintf(stderr,"Can't open output file %s as stdout",out);
9261         exit(vaxc$errno);
9262         }
9263         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
9264
9265     if (err != NULL) {
9266         if (strcmp(err,"&1") == 0) {
9267             dup2(fileno(stdout), fileno(stderr));
9268             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
9269         } else {
9270         FILE *tmperr;
9271         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9272             {
9273             fprintf(stderr,"Can't open error file %s as stderr",err);
9274             exit(vaxc$errno);
9275             }
9276             fclose(tmperr);
9277            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9278                 {
9279                 exit(vaxc$errno);
9280                 }
9281             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
9282         }
9283         }
9284 #ifdef ARGPROC_DEBUG
9285     PerlIO_printf(Perl_debug_log, "Arglist:\n");
9286     for (j = 0; j < *ac;  ++j)
9287         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9288 #endif
9289    /* Clear errors we may have hit expanding wildcards, so they don't
9290       show up in Perl's $! later */
9291    set_errno(0); set_vaxc_errno(1);
9292 }  /* end of getredirection() */
9293 /*}}}*/
9294
9295 static void add_item(struct list_item **head,
9296                      struct list_item **tail,
9297                      char *value,
9298                      int *count)
9299 {
9300     if (*head == 0)
9301         {
9302         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9303         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9304         *tail = *head;
9305         }
9306     else {
9307         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9308         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9309         *tail = (*tail)->next;
9310         }
9311     (*tail)->value = value;
9312     ++(*count);
9313 }
9314
9315 static void mp_expand_wild_cards(pTHX_ char *item,
9316                               struct list_item **head,
9317                               struct list_item **tail,
9318                               int *count)
9319 {
9320 int expcount = 0;
9321 unsigned long int context = 0;
9322 int isunix = 0;
9323 int item_len = 0;
9324 char *had_version;
9325 char *had_device;
9326 int had_directory;
9327 char *devdir,*cp;
9328 char *vmsspec;
9329 $DESCRIPTOR(filespec, "");
9330 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9331 $DESCRIPTOR(resultspec, "");
9332 unsigned long int lff_flags = 0;
9333 int sts;
9334 int rms_sts;
9335
9336 #ifdef VMS_LONGNAME_SUPPORT
9337     lff_flags = LIB$M_FIL_LONG_NAMES;
9338 #endif
9339
9340     for (cp = item; *cp; cp++) {
9341         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9342         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9343     }
9344     if (!*cp || isspace(*cp))
9345         {
9346         add_item(head, tail, item, count);
9347         return;
9348         }
9349     else
9350         {
9351      /* "double quoted" wild card expressions pass as is */
9352      /* From DCL that means using e.g.:                  */
9353      /* perl program """perl.*"""                        */
9354      item_len = strlen(item);
9355      if ( '"' == *item && '"' == item[item_len-1] )
9356        {
9357        item++;
9358        item[item_len-2] = '\0';
9359        add_item(head, tail, item, count);
9360        return;
9361        }
9362      }
9363     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9364     resultspec.dsc$b_class = DSC$K_CLASS_D;
9365     resultspec.dsc$a_pointer = NULL;
9366     vmsspec = PerlMem_malloc(VMS_MAXRSS);
9367     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9368     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9369       filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9370     if (!isunix || !filespec.dsc$a_pointer)
9371       filespec.dsc$a_pointer = item;
9372     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9373     /*
9374      * Only return version specs, if the caller specified a version
9375      */
9376     had_version = strchr(item, ';');
9377     /*
9378      * Only return device and directory specs, if the caller specifed either.
9379      */
9380     had_device = strchr(item, ':');
9381     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9382
9383     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9384                                  (&filespec, &resultspec, &context,
9385                                   &defaultspec, 0, &rms_sts, &lff_flags)))
9386         {
9387         char *string;
9388         char *c;
9389
9390         string = PerlMem_malloc(resultspec.dsc$w_length+1);
9391         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9392         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
9393         string[resultspec.dsc$w_length] = '\0';
9394         if (NULL == had_version)
9395             *(strrchr(string, ';')) = '\0';
9396         if ((!had_directory) && (had_device == NULL))
9397             {
9398             if (NULL == (devdir = strrchr(string, ']')))
9399                 devdir = strrchr(string, '>');
9400             strcpy(string, devdir + 1);
9401             }
9402         /*
9403          * Be consistent with what the C RTL has already done to the rest of
9404          * the argv items and lowercase all of these names.
9405          */
9406         if (!decc_efs_case_preserve) {
9407             for (c = string; *c; ++c)
9408             if (isupper(*c))
9409                 *c = tolower(*c);
9410         }
9411         if (isunix) trim_unixpath(string,item,1);
9412         add_item(head, tail, string, count);
9413         ++expcount;
9414     }
9415     PerlMem_free(vmsspec);
9416     if (sts != RMS$_NMF)
9417         {
9418         set_vaxc_errno(sts);
9419         switch (sts)
9420             {
9421             case RMS$_FNF: case RMS$_DNF:
9422                 set_errno(ENOENT); break;
9423             case RMS$_DIR:
9424                 set_errno(ENOTDIR); break;
9425             case RMS$_DEV:
9426                 set_errno(ENODEV); break;
9427             case RMS$_FNM: case RMS$_SYN:
9428                 set_errno(EINVAL); break;
9429             case RMS$_PRV:
9430                 set_errno(EACCES); break;
9431             default:
9432                 _ckvmssts_noperl(sts);
9433             }
9434         }
9435     if (expcount == 0)
9436         add_item(head, tail, item, count);
9437     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9438     _ckvmssts_noperl(lib$find_file_end(&context));
9439 }
9440
9441 static int child_st[2];/* Event Flag set when child process completes   */
9442
9443 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
9444
9445 static unsigned long int exit_handler(int *status)
9446 {
9447 short iosb[4];
9448
9449     if (0 == child_st[0])
9450         {
9451 #ifdef ARGPROC_DEBUG
9452         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
9453 #endif
9454         fflush(stdout);     /* Have to flush pipe for binary data to    */
9455                             /* terminate properly -- <tp@mccall.com>    */
9456         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
9457         sys$dassgn(child_chan);
9458         fclose(stdout);
9459         sys$synch(0, child_st);
9460         }
9461     return(1);
9462 }
9463
9464 static void sig_child(int chan)
9465 {
9466 #ifdef ARGPROC_DEBUG
9467     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
9468 #endif
9469     if (child_st[0] == 0)
9470         child_st[0] = 1;
9471 }
9472
9473 static struct exit_control_block exit_block =
9474     {
9475     0,
9476     exit_handler,
9477     1,
9478     &exit_block.exit_status,
9479     0
9480     };
9481
9482 static void
9483 pipe_and_fork(pTHX_ char **cmargv)
9484 {
9485     PerlIO *fp;
9486     struct dsc$descriptor_s *vmscmd;
9487     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9488     int sts, j, l, ismcr, quote, tquote = 0;
9489
9490     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9491     vms_execfree(vmscmd);
9492
9493     j = l = 0;
9494     p = subcmd;
9495     q = cmargv[0];
9496     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
9497               && toupper(*(q+2)) == 'R' && !*(q+3);
9498
9499     while (q && l < MAX_DCL_LINE_LENGTH) {
9500         if (!*q) {
9501             if (j > 0 && quote) {
9502                 *p++ = '"';
9503                 l++;
9504             }
9505             q = cmargv[++j];
9506             if (q) {
9507                 if (ismcr && j > 1) quote = 1;
9508                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
9509                 *p++ = ' ';
9510                 l++;
9511                 if (quote || tquote) {
9512                     *p++ = '"';
9513                     l++;
9514                 }
9515             }
9516         } else {
9517             if ((quote||tquote) && *q == '"') {
9518                 *p++ = '"';
9519                 l++;
9520             }
9521             *p++ = *q++;
9522             l++;
9523         }
9524     }
9525     *p = '\0';
9526
9527     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9528     if (fp == NULL) {
9529         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9530     }
9531 }
9532
9533 static int background_process(pTHX_ int argc, char **argv)
9534 {
9535 char command[MAX_DCL_SYMBOL + 1] = "$";
9536 $DESCRIPTOR(value, "");
9537 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9538 static $DESCRIPTOR(null, "NLA0:");
9539 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9540 char pidstring[80];
9541 $DESCRIPTOR(pidstr, "");
9542 int pid;
9543 unsigned long int flags = 17, one = 1, retsts;
9544 int len;
9545
9546     strcat(command, argv[0]);
9547     len = strlen(command);
9548     while (--argc && (len < MAX_DCL_SYMBOL))
9549         {
9550         strcat(command, " \"");
9551         strcat(command, *(++argv));
9552         strcat(command, "\"");
9553         len = strlen(command);
9554         }
9555     value.dsc$a_pointer = command;
9556     value.dsc$w_length = strlen(value.dsc$a_pointer);
9557     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9558     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9559     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9560         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9561     }
9562     else {
9563         _ckvmssts_noperl(retsts);
9564     }
9565 #ifdef ARGPROC_DEBUG
9566     PerlIO_printf(Perl_debug_log, "%s\n", command);
9567 #endif
9568     sprintf(pidstring, "%08X", pid);
9569     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9570     pidstr.dsc$a_pointer = pidstring;
9571     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9572     lib$set_symbol(&pidsymbol, &pidstr);
9573     return(SS$_NORMAL);
9574 }
9575 /*}}}*/
9576 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9577
9578
9579 /* OS-specific initialization at image activation (not thread startup) */
9580 /* Older VAXC header files lack these constants */
9581 #ifndef JPI$_RIGHTS_SIZE
9582 #  define JPI$_RIGHTS_SIZE 817
9583 #endif
9584 #ifndef KGB$M_SUBSYSTEM
9585 #  define KGB$M_SUBSYSTEM 0x8
9586 #endif
9587
9588 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9589
9590 /*{{{void vms_image_init(int *, char ***)*/
9591 void
9592 vms_image_init(int *argcp, char ***argvp)
9593 {
9594   int status;
9595   char eqv[LNM$C_NAMLENGTH+1] = "";
9596   unsigned int len, tabct = 8, tabidx = 0;
9597   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9598   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9599   unsigned short int dummy, rlen;
9600   struct dsc$descriptor_s **tabvec;
9601 #if defined(PERL_IMPLICIT_CONTEXT)
9602   pTHX = NULL;
9603 #endif
9604   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
9605                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
9606                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9607                                  {          0,                0,    0,      0} };
9608
9609 #ifdef KILL_BY_SIGPRC
9610     Perl_csighandler_init();
9611 #endif
9612
9613     /* This was moved from the pre-image init handler because on threaded */
9614     /* Perl it was always returning 0 for the default value. */
9615     status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9616     if (status > 0) {
9617         int s;
9618         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9619         if (s > 0) {
9620             int initial;
9621             initial = decc$feature_get_value(s, 4);
9622             if (initial > 0) {
9623                 /* initial is: 0 if nothing has set the feature */
9624                 /*            -1 if initialized to default */
9625                 /*             1 if set by logical name */
9626                 /*             2 if set by decc$feature_set_value */
9627                 decc_disable_posix_root = decc$feature_get_value(s, 1);
9628
9629                 /* If the value is not valid, force the feature off */
9630                 if (decc_disable_posix_root < 0) {
9631                     decc$feature_set_value(s, 1, 1);
9632                     decc_disable_posix_root = 1;
9633                 }
9634             }
9635             else {
9636                 /* Nothing has asked for it explicitly, so use our own default. */
9637                 decc_disable_posix_root = 1;
9638                 decc$feature_set_value(s, 1, 1);
9639             }
9640         }
9641     }
9642
9643
9644   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9645   _ckvmssts_noperl(iosb[0]);
9646   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9647     if (iprv[i]) {           /* Running image installed with privs? */
9648       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
9649       will_taint = TRUE;
9650       break;
9651     }
9652   }
9653   /* Rights identifiers might trigger tainting as well. */
9654   if (!will_taint && (rlen || rsz)) {
9655     while (rlen < rsz) {
9656       /* We didn't get all the identifiers on the first pass.  Allocate a
9657        * buffer much larger than $GETJPI wants (rsz is size in bytes that
9658        * were needed to hold all identifiers at time of last call; we'll
9659        * allocate that many unsigned long ints), and go back and get 'em.
9660        * If it gave us less than it wanted to despite ample buffer space,
9661        * something's broken.  Is your system missing a system identifier?
9662        */
9663       if (rsz <= jpilist[1].buflen) {
9664          /* Perl_croak accvios when used this early in startup. */
9665          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9666                          rsz, (unsigned long) jpilist[1].buflen,
9667                          "Check your rights database for corruption.\n");
9668          exit(SS$_ABORT);
9669       }
9670       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9671       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9672       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9673       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9674       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9675       _ckvmssts_noperl(iosb[0]);
9676     }
9677     mask = jpilist[1].bufadr;
9678     /* Check attribute flags for each identifier (2nd longword); protected
9679      * subsystem identifiers trigger tainting.
9680      */
9681     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9682       if (mask[i] & KGB$M_SUBSYSTEM) {
9683         will_taint = TRUE;
9684         break;
9685       }
9686     }
9687     if (mask != rlst) PerlMem_free(mask);
9688   }
9689
9690   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9691    * logical, some versions of the CRTL will add a phanthom /000000/
9692    * directory.  This needs to be removed.
9693    */
9694   if (decc_filename_unix_report) {
9695   char * zeros;
9696   int ulen;
9697     ulen = strlen(argvp[0][0]);
9698     if (ulen > 7) {
9699       zeros = strstr(argvp[0][0], "/000000/");
9700       if (zeros != NULL) {
9701         int mlen;
9702         mlen = ulen - (zeros - argvp[0][0]) - 7;
9703         memmove(zeros, &zeros[7], mlen);
9704         ulen = ulen - 7;
9705         argvp[0][0][ulen] = '\0';
9706       }
9707     }
9708     /* It also may have a trailing dot that needs to be removed otherwise
9709      * it will be converted to VMS mode incorrectly.
9710      */
9711     ulen--;
9712     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9713       argvp[0][0][ulen] = '\0';
9714   }
9715
9716   /* We need to use this hack to tell Perl it should run with tainting,
9717    * since its tainting flag may be part of the PL_curinterp struct, which
9718    * hasn't been allocated when vms_image_init() is called.
9719    */
9720   if (will_taint) {
9721     char **newargv, **oldargv;
9722     oldargv = *argvp;
9723     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9724     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9725     newargv[0] = oldargv[0];
9726     newargv[1] = PerlMem_malloc(3 * sizeof(char));
9727     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9728     strcpy(newargv[1], "-T");
9729     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9730     (*argcp)++;
9731     newargv[*argcp] = NULL;
9732     /* We orphan the old argv, since we don't know where it's come from,
9733      * so we don't know how to free it.
9734      */
9735     *argvp = newargv;
9736   }
9737   else {  /* Did user explicitly request tainting? */
9738     int i;
9739     char *cp, **av = *argvp;
9740     for (i = 1; i < *argcp; i++) {
9741       if (*av[i] != '-') break;
9742       for (cp = av[i]+1; *cp; cp++) {
9743         if (*cp == 'T') { will_taint = 1; break; }
9744         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9745                   strchr("DFIiMmx",*cp)) break;
9746       }
9747       if (will_taint) break;
9748     }
9749   }
9750
9751   for (tabidx = 0;
9752        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9753        tabidx++) {
9754     if (!tabidx) {
9755       tabvec = (struct dsc$descriptor_s **)
9756             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9757       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9758     }
9759     else if (tabidx >= tabct) {
9760       tabct += 8;
9761       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9762       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9763     }
9764     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9765     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9766     tabvec[tabidx]->dsc$w_length  = 0;
9767     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9768     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
9769     tabvec[tabidx]->dsc$a_pointer = NULL;
9770     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9771   }
9772   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9773
9774   getredirection(argcp,argvp);
9775 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9776   {
9777 # include <reentrancy.h>
9778   decc$set_reentrancy(C$C_MULTITHREAD);
9779   }
9780 #endif
9781   return;
9782 }
9783 /*}}}*/
9784
9785
9786 /* trim_unixpath()
9787  * Trim Unix-style prefix off filespec, so it looks like what a shell
9788  * glob expansion would return (i.e. from specified prefix on, not
9789  * full path).  Note that returned filespec is Unix-style, regardless
9790  * of whether input filespec was VMS-style or Unix-style.
9791  *
9792  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9793  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9794  * vector of options; at present, only bit 0 is used, and if set tells
9795  * trim unixpath to try the current default directory as a prefix when
9796  * presented with a possibly ambiguous ... wildcard.
9797  *
9798  * Returns !=0 on success, with trimmed filespec replacing contents of
9799  * fspec, and 0 on failure, with contents of fpsec unchanged.
9800  */
9801 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9802 int
9803 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9804 {
9805   char *unixified, *unixwild,
9806        *template, *base, *end, *cp1, *cp2;
9807   register int tmplen, reslen = 0, dirs = 0;
9808
9809   if (!wildspec || !fspec) return 0;
9810
9811   unixwild = PerlMem_malloc(VMS_MAXRSS);
9812   if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9813   template = unixwild;
9814   if (strpbrk(wildspec,"]>:") != NULL) {
9815     if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
9816         PerlMem_free(unixwild);
9817         return 0;
9818     }
9819   }
9820   else {
9821     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
9822     unixwild[VMS_MAXRSS-1] = 0;
9823   }
9824   unixified = PerlMem_malloc(VMS_MAXRSS);
9825   if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9826   if (strpbrk(fspec,"]>:") != NULL) {
9827     if (int_tounixspec(fspec, unixified, NULL) == NULL) {
9828         PerlMem_free(unixwild);
9829         PerlMem_free(unixified);
9830         return 0;
9831     }
9832     else base = unixified;
9833     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9834      * check to see that final result fits into (isn't longer than) fspec */
9835     reslen = strlen(fspec);
9836   }
9837   else base = fspec;
9838
9839   /* No prefix or absolute path on wildcard, so nothing to remove */
9840   if (!*template || *template == '/') {
9841     PerlMem_free(unixwild);
9842     if (base == fspec) {
9843         PerlMem_free(unixified);
9844         return 1;
9845     }
9846     tmplen = strlen(unixified);
9847     if (tmplen > reslen) {
9848         PerlMem_free(unixified);
9849         return 0;  /* not enough space */
9850     }
9851     /* Copy unixified resultant, including trailing NUL */
9852     memmove(fspec,unixified,tmplen+1);
9853     PerlMem_free(unixified);
9854     return 1;
9855   }
9856
9857   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
9858   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
9859     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
9860     for (cp1 = end ;cp1 >= base; cp1--)
9861       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9862         { cp1++; break; }
9863     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9864     PerlMem_free(unixified);
9865     PerlMem_free(unixwild);
9866     return 1;
9867   }
9868   else {
9869     char *tpl, *lcres;
9870     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9871     int ells = 1, totells, segdirs, match;
9872     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9873                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9874
9875     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9876     totells = ells;
9877     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9878     tpl = PerlMem_malloc(VMS_MAXRSS);
9879     if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9880     if (ellipsis == template && opts & 1) {
9881       /* Template begins with an ellipsis.  Since we can't tell how many
9882        * directory names at the front of the resultant to keep for an
9883        * arbitrary starting point, we arbitrarily choose the current
9884        * default directory as a starting point.  If it's there as a prefix,
9885        * clip it off.  If not, fall through and act as if the leading
9886        * ellipsis weren't there (i.e. return shortest possible path that
9887        * could match template).
9888        */
9889       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9890           PerlMem_free(tpl);
9891           PerlMem_free(unixified);
9892           PerlMem_free(unixwild);
9893           return 0;
9894       }
9895       if (!decc_efs_case_preserve) {
9896         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9897           if (_tolower(*cp1) != _tolower(*cp2)) break;
9898       }
9899       segdirs = dirs - totells;  /* Min # of dirs we must have left */
9900       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9901       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9902         memmove(fspec,cp2+1,end - cp2);
9903         PerlMem_free(tpl);
9904         PerlMem_free(unixified);
9905         PerlMem_free(unixwild);
9906         return 1;
9907       }
9908     }
9909     /* First off, back up over constant elements at end of path */
9910     if (dirs) {
9911       for (front = end ; front >= base; front--)
9912          if (*front == '/' && !dirs--) { front++; break; }
9913     }
9914     lcres = PerlMem_malloc(VMS_MAXRSS);
9915     if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9916     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9917          cp1++,cp2++) {
9918             if (!decc_efs_case_preserve) {
9919                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
9920             }
9921             else {
9922                 *cp2 = *cp1;
9923             }
9924     }
9925     if (cp1 != '\0') {
9926         PerlMem_free(tpl);
9927         PerlMem_free(unixified);
9928         PerlMem_free(unixwild);
9929         PerlMem_free(lcres);
9930         return 0;  /* Path too long. */
9931     }
9932     lcend = cp2;
9933     *cp2 = '\0';  /* Pick up with memcpy later */
9934     lcfront = lcres + (front - base);
9935     /* Now skip over each ellipsis and try to match the path in front of it. */
9936     while (ells--) {
9937       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
9938         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
9939             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
9940       if (cp1 < template) break; /* template started with an ellipsis */
9941       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9942         ellipsis = cp1; continue;
9943       }
9944       wilddsc.dsc$a_pointer = tpl;
9945       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9946       nextell = cp1;
9947       for (segdirs = 0, cp2 = tpl;
9948            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9949            cp1++, cp2++) {
9950          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9951          else {
9952             if (!decc_efs_case_preserve) {
9953               *cp2 = _tolower(*cp1);  /* else lowercase for match */
9954             }
9955             else {
9956               *cp2 = *cp1;  /* else preserve case for match */
9957             }
9958          }
9959          if (*cp2 == '/') segdirs++;
9960       }
9961       if (cp1 != ellipsis - 1) {
9962           PerlMem_free(tpl);
9963           PerlMem_free(unixified);
9964           PerlMem_free(unixwild);
9965           PerlMem_free(lcres);
9966           return 0; /* Path too long */
9967       }
9968       /* Back up at least as many dirs as in template before matching */
9969       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9970         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9971       for (match = 0; cp1 > lcres;) {
9972         resdsc.dsc$a_pointer = cp1;
9973         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9974           match++;
9975           if (match == 1) lcfront = cp1;
9976         }
9977         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9978       }
9979       if (!match) {
9980         PerlMem_free(tpl);
9981         PerlMem_free(unixified);
9982         PerlMem_free(unixwild);
9983         PerlMem_free(lcres);
9984         return 0;  /* Can't find prefix ??? */
9985       }
9986       if (match > 1 && opts & 1) {
9987         /* This ... wildcard could cover more than one set of dirs (i.e.
9988          * a set of similar dir names is repeated).  If the template
9989          * contains more than 1 ..., upstream elements could resolve the
9990          * ambiguity, but it's not worth a full backtracking setup here.
9991          * As a quick heuristic, clip off the current default directory
9992          * if it's present to find the trimmed spec, else use the
9993          * shortest string that this ... could cover.
9994          */
9995         char def[NAM$C_MAXRSS+1], *st;
9996
9997         if (getcwd(def, sizeof def,0) == NULL) {
9998             PerlMem_free(unixified);
9999             PerlMem_free(unixwild);
10000             PerlMem_free(lcres);
10001             PerlMem_free(tpl);
10002             return 0;
10003         }
10004         if (!decc_efs_case_preserve) {
10005           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
10006             if (_tolower(*cp1) != _tolower(*cp2)) break;
10007         }
10008         segdirs = dirs - totells;  /* Min # of dirs we must have left */
10009         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
10010         if (*cp1 == '\0' && *cp2 == '/') {
10011           memmove(fspec,cp2+1,end - cp2);
10012           PerlMem_free(tpl);
10013           PerlMem_free(unixified);
10014           PerlMem_free(unixwild);
10015           PerlMem_free(lcres);
10016           return 1;
10017         }
10018         /* Nope -- stick with lcfront from above and keep going. */
10019       }
10020     }
10021     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
10022     PerlMem_free(tpl);
10023     PerlMem_free(unixified);
10024     PerlMem_free(unixwild);
10025     PerlMem_free(lcres);
10026     return 1;
10027     ellipsis = nextell;
10028   }
10029
10030 }  /* end of trim_unixpath() */
10031 /*}}}*/
10032
10033
10034 /*
10035  *  VMS readdir() routines.
10036  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
10037  *
10038  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
10039  *  Minor modifications to original routines.
10040  */
10041
10042 /* readdir may have been redefined by reentr.h, so make sure we get
10043  * the local version for what we do here.
10044  */
10045 #ifdef readdir
10046 # undef readdir
10047 #endif
10048 #if !defined(PERL_IMPLICIT_CONTEXT)
10049 # define readdir Perl_readdir
10050 #else
10051 # define readdir(a) Perl_readdir(aTHX_ a)
10052 #endif
10053
10054     /* Number of elements in vms_versions array */
10055 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
10056
10057 /*
10058  *  Open a directory, return a handle for later use.
10059  */
10060 /*{{{ DIR *opendir(char*name) */
10061 DIR *
10062 Perl_opendir(pTHX_ const char *name)
10063 {
10064     DIR *dd;
10065     char *dir;
10066     Stat_t sb;
10067
10068     Newx(dir, VMS_MAXRSS, char);
10069     if (do_tovmspath(name,dir,0,NULL) == NULL) {
10070       Safefree(dir);
10071       return NULL;
10072     }
10073     /* Check access before stat; otherwise stat does not
10074      * accurately report whether it's a directory.
10075      */
10076     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
10077       /* cando_by_name has already set errno */
10078       Safefree(dir);
10079       return NULL;
10080     }
10081     if (flex_stat(dir,&sb) == -1) return NULL;
10082     if (!S_ISDIR(sb.st_mode)) {
10083       Safefree(dir);
10084       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
10085       return NULL;
10086     }
10087     /* Get memory for the handle, and the pattern. */
10088     Newx(dd,1,DIR);
10089     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
10090
10091     /* Fill in the fields; mainly playing with the descriptor. */
10092     sprintf(dd->pattern, "%s*.*",dir);
10093     Safefree(dir);
10094     dd->context = 0;
10095     dd->count = 0;
10096     dd->flags = 0;
10097     /* By saying we always want the result of readdir() in unix format, we
10098      * are really saying we want all the escapes removed.  Otherwise the caller,
10099      * having no way to know whether it's already in VMS format, might send it
10100      * through tovmsspec again, thus double escaping.
10101      */
10102     dd->flags = PERL_VMSDIR_M_UNIXSPECS;
10103     dd->pat.dsc$a_pointer = dd->pattern;
10104     dd->pat.dsc$w_length = strlen(dd->pattern);
10105     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
10106     dd->pat.dsc$b_class = DSC$K_CLASS_S;
10107 #if defined(USE_ITHREADS)
10108     Newx(dd->mutex,1,perl_mutex);
10109     MUTEX_INIT( (perl_mutex *) dd->mutex );
10110 #else
10111     dd->mutex = NULL;
10112 #endif
10113
10114     return dd;
10115 }  /* end of opendir() */
10116 /*}}}*/
10117
10118 /*
10119  *  Set the flag to indicate we want versions or not.
10120  */
10121 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10122 void
10123 vmsreaddirversions(DIR *dd, int flag)
10124 {
10125     if (flag)
10126         dd->flags |= PERL_VMSDIR_M_VERSIONS;
10127     else
10128         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10129 }
10130 /*}}}*/
10131
10132 /*
10133  *  Free up an opened directory.
10134  */
10135 /*{{{ void closedir(DIR *dd)*/
10136 void
10137 Perl_closedir(DIR *dd)
10138 {
10139     int sts;
10140
10141     sts = lib$find_file_end(&dd->context);
10142     Safefree(dd->pattern);
10143 #if defined(USE_ITHREADS)
10144     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10145     Safefree(dd->mutex);
10146 #endif
10147     Safefree(dd);
10148 }
10149 /*}}}*/
10150
10151 /*
10152  *  Collect all the version numbers for the current file.
10153  */
10154 static void
10155 collectversions(pTHX_ DIR *dd)
10156 {
10157     struct dsc$descriptor_s     pat;
10158     struct dsc$descriptor_s     res;
10159     struct dirent *e;
10160     char *p, *text, *buff;
10161     int i;
10162     unsigned long context, tmpsts;
10163
10164     /* Convenient shorthand. */
10165     e = &dd->entry;
10166
10167     /* Add the version wildcard, ignoring the "*.*" put on before */
10168     i = strlen(dd->pattern);
10169     Newx(text,i + e->d_namlen + 3,char);
10170     strcpy(text, dd->pattern);
10171     sprintf(&text[i - 3], "%s;*", e->d_name);
10172
10173     /* Set up the pattern descriptor. */
10174     pat.dsc$a_pointer = text;
10175     pat.dsc$w_length = i + e->d_namlen - 1;
10176     pat.dsc$b_dtype = DSC$K_DTYPE_T;
10177     pat.dsc$b_class = DSC$K_CLASS_S;
10178
10179     /* Set up result descriptor. */
10180     Newx(buff, VMS_MAXRSS, char);
10181     res.dsc$a_pointer = buff;
10182     res.dsc$w_length = VMS_MAXRSS - 1;
10183     res.dsc$b_dtype = DSC$K_DTYPE_T;
10184     res.dsc$b_class = DSC$K_CLASS_S;
10185
10186     /* Read files, collecting versions. */
10187     for (context = 0, e->vms_verscount = 0;
10188          e->vms_verscount < VERSIZE(e);
10189          e->vms_verscount++) {
10190         unsigned long rsts;
10191         unsigned long flags = 0;
10192
10193 #ifdef VMS_LONGNAME_SUPPORT
10194         flags = LIB$M_FIL_LONG_NAMES;
10195 #endif
10196         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10197         if (tmpsts == RMS$_NMF || context == 0) break;
10198         _ckvmssts(tmpsts);
10199         buff[VMS_MAXRSS - 1] = '\0';
10200         if ((p = strchr(buff, ';')))
10201             e->vms_versions[e->vms_verscount] = atoi(p + 1);
10202         else
10203             e->vms_versions[e->vms_verscount] = -1;
10204     }
10205
10206     _ckvmssts(lib$find_file_end(&context));
10207     Safefree(text);
10208     Safefree(buff);
10209
10210 }  /* end of collectversions() */
10211
10212 /*
10213  *  Read the next entry from the directory.
10214  */
10215 /*{{{ struct dirent *readdir(DIR *dd)*/
10216 struct dirent *
10217 Perl_readdir(pTHX_ DIR *dd)
10218 {
10219     struct dsc$descriptor_s     res;
10220     char *p, *buff;
10221     unsigned long int tmpsts;
10222     unsigned long rsts;
10223     unsigned long flags = 0;
10224     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10225     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10226
10227     /* Set up result descriptor, and get next file. */
10228     Newx(buff, VMS_MAXRSS, char);
10229     res.dsc$a_pointer = buff;
10230     res.dsc$w_length = VMS_MAXRSS - 1;
10231     res.dsc$b_dtype = DSC$K_DTYPE_T;
10232     res.dsc$b_class = DSC$K_CLASS_S;
10233
10234 #ifdef VMS_LONGNAME_SUPPORT
10235     flags = LIB$M_FIL_LONG_NAMES;
10236 #endif
10237
10238     tmpsts = lib$find_file
10239         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10240     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
10241     if (!(tmpsts & 1)) {
10242       set_vaxc_errno(tmpsts);
10243       switch (tmpsts) {
10244         case RMS$_PRV:
10245           set_errno(EACCES); break;
10246         case RMS$_DEV:
10247           set_errno(ENODEV); break;
10248         case RMS$_DIR:
10249           set_errno(ENOTDIR); break;
10250         case RMS$_FNF: case RMS$_DNF:
10251           set_errno(ENOENT); break;
10252         default:
10253           set_errno(EVMSERR);
10254       }
10255       Safefree(buff);
10256       return NULL;
10257     }
10258     dd->count++;
10259     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10260     buff[res.dsc$w_length] = '\0';
10261     p = buff + res.dsc$w_length;
10262     while (--p >= buff) if (!isspace(*p)) break;
10263     *p = '\0';
10264     if (!decc_efs_case_preserve) {
10265       for (p = buff; *p; p++) *p = _tolower(*p);
10266     }
10267
10268     /* Skip any directory component and just copy the name. */
10269     sts = vms_split_path
10270        (buff,
10271         &v_spec,
10272         &v_len,
10273         &r_spec,
10274         &r_len,
10275         &d_spec,
10276         &d_len,
10277         &n_spec,
10278         &n_len,
10279         &e_spec,
10280         &e_len,
10281         &vs_spec,
10282         &vs_len);
10283
10284     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10285
10286         /* In Unix report mode, remove the ".dir;1" from the name */
10287         /* if it is a real directory. */
10288         if (decc_filename_unix_report || decc_efs_charset) {
10289             if ((e_len == 4) && (vs_len == 2) && (vs_spec[1] == '1')) {
10290                 if ((toupper(e_spec[1]) == 'D') &&
10291                     (toupper(e_spec[2]) == 'I') &&
10292                     (toupper(e_spec[3]) == 'R')) {
10293                     Stat_t statbuf;
10294                     int ret_sts;
10295
10296                     ret_sts = stat(buff, (stat_t *)&statbuf);
10297                     if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10298                         e_len = 0;
10299                         e_spec[0] = 0;
10300                     }
10301                 }
10302             }
10303         }
10304
10305         /* Drop NULL extensions on UNIX file specification */
10306         if ((e_len == 1) && decc_readdir_dropdotnotype) {
10307             e_len = 0;
10308             e_spec[0] = '\0';
10309         }
10310     }
10311
10312     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
10313     dd->entry.d_name[n_len + e_len] = '\0';
10314     dd->entry.d_namlen = strlen(dd->entry.d_name);
10315
10316     /* Convert the filename to UNIX format if needed */
10317     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10318
10319         /* Translate the encoded characters. */
10320         /* Fixme: Unicode handling could result in embedded 0 characters */
10321         if (strchr(dd->entry.d_name, '^') != NULL) {
10322             char new_name[256];
10323             char * q;
10324             p = dd->entry.d_name;
10325             q = new_name;
10326             while (*p != 0) {
10327                 int inchars_read, outchars_added;
10328                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10329                 p += inchars_read;
10330                 q += outchars_added;
10331                 /* fix-me */
10332                 /* if outchars_added > 1, then this is a wide file specification */
10333                 /* Wide file specifications need to be passed in Perl */
10334                 /* counted strings apparently with a Unicode flag */
10335             }
10336             *q = 0;
10337             strcpy(dd->entry.d_name, new_name);
10338             dd->entry.d_namlen = strlen(dd->entry.d_name);
10339         }
10340     }
10341
10342     dd->entry.vms_verscount = 0;
10343     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10344     Safefree(buff);
10345     return &dd->entry;
10346
10347 }  /* end of readdir() */
10348 /*}}}*/
10349
10350 /*
10351  *  Read the next entry from the directory -- thread-safe version.
10352  */
10353 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10354 int
10355 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10356 {
10357     int retval;
10358
10359     MUTEX_LOCK( (perl_mutex *) dd->mutex );
10360
10361     entry = readdir(dd);
10362     *result = entry;
10363     retval = ( *result == NULL ? errno : 0 );
10364
10365     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10366
10367     return retval;
10368
10369 }  /* end of readdir_r() */
10370 /*}}}*/
10371
10372 /*
10373  *  Return something that can be used in a seekdir later.
10374  */
10375 /*{{{ long telldir(DIR *dd)*/
10376 long
10377 Perl_telldir(DIR *dd)
10378 {
10379     return dd->count;
10380 }
10381 /*}}}*/
10382
10383 /*
10384  *  Return to a spot where we used to be.  Brute force.
10385  */
10386 /*{{{ void seekdir(DIR *dd,long count)*/
10387 void
10388 Perl_seekdir(pTHX_ DIR *dd, long count)
10389 {
10390     int old_flags;
10391
10392     /* If we haven't done anything yet... */
10393     if (dd->count == 0)
10394         return;
10395
10396     /* Remember some state, and clear it. */
10397     old_flags = dd->flags;
10398     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10399     _ckvmssts(lib$find_file_end(&dd->context));
10400     dd->context = 0;
10401
10402     /* The increment is in readdir(). */
10403     for (dd->count = 0; dd->count < count; )
10404         readdir(dd);
10405
10406     dd->flags = old_flags;
10407
10408 }  /* end of seekdir() */
10409 /*}}}*/
10410
10411 /* VMS subprocess management
10412  *
10413  * my_vfork() - just a vfork(), after setting a flag to record that
10414  * the current script is trying a Unix-style fork/exec.
10415  *
10416  * vms_do_aexec() and vms_do_exec() are called in response to the
10417  * perl 'exec' function.  If this follows a vfork call, then they
10418  * call out the regular perl routines in doio.c which do an
10419  * execvp (for those who really want to try this under VMS).
10420  * Otherwise, they do exactly what the perl docs say exec should
10421  * do - terminate the current script and invoke a new command
10422  * (See below for notes on command syntax.)
10423  *
10424  * do_aspawn() and do_spawn() implement the VMS side of the perl
10425  * 'system' function.
10426  *
10427  * Note on command arguments to perl 'exec' and 'system': When handled
10428  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10429  * are concatenated to form a DCL command string.  If the first non-numeric
10430  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10431  * the command string is handed off to DCL directly.  Otherwise,
10432  * the first token of the command is taken as the filespec of an image
10433  * to run.  The filespec is expanded using a default type of '.EXE' and
10434  * the process defaults for device, directory, etc., and if found, the resultant
10435  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10436  * the command string as parameters.  This is perhaps a bit complicated,
10437  * but I hope it will form a happy medium between what VMS folks expect
10438  * from lib$spawn and what Unix folks expect from exec.
10439  */
10440
10441 static int vfork_called;
10442
10443 /*{{{int my_vfork()*/
10444 int
10445 my_vfork()
10446 {
10447   vfork_called++;
10448   return vfork();
10449 }
10450 /*}}}*/
10451
10452
10453 static void
10454 vms_execfree(struct dsc$descriptor_s *vmscmd)
10455 {
10456   if (vmscmd) {
10457       if (vmscmd->dsc$a_pointer) {
10458           PerlMem_free(vmscmd->dsc$a_pointer);
10459       }
10460       PerlMem_free(vmscmd);
10461   }
10462 }
10463
10464 static char *
10465 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10466 {
10467   char *junk, *tmps = NULL;
10468   register size_t cmdlen = 0;
10469   size_t rlen;
10470   register SV **idx;
10471   STRLEN n_a;
10472
10473   idx = mark;
10474   if (really) {
10475     tmps = SvPV(really,rlen);
10476     if (*tmps) {
10477       cmdlen += rlen + 1;
10478       idx++;
10479     }
10480   }
10481
10482   for (idx++; idx <= sp; idx++) {
10483     if (*idx) {
10484       junk = SvPVx(*idx,rlen);
10485       cmdlen += rlen ? rlen + 1 : 0;
10486     }
10487   }
10488   Newx(PL_Cmd, cmdlen+1, char);
10489
10490   if (tmps && *tmps) {
10491     strcpy(PL_Cmd,tmps);
10492     mark++;
10493   }
10494   else *PL_Cmd = '\0';
10495   while (++mark <= sp) {
10496     if (*mark) {
10497       char *s = SvPVx(*mark,n_a);
10498       if (!*s) continue;
10499       if (*PL_Cmd) strcat(PL_Cmd," ");
10500       strcat(PL_Cmd,s);
10501     }
10502   }
10503   return PL_Cmd;
10504
10505 }  /* end of setup_argstr() */
10506
10507
10508 static unsigned long int
10509 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10510                    struct dsc$descriptor_s **pvmscmd)
10511 {
10512   char * vmsspec;
10513   char * resspec;
10514   char image_name[NAM$C_MAXRSS+1];
10515   char image_argv[NAM$C_MAXRSS+1];
10516   $DESCRIPTOR(defdsc,".EXE");
10517   $DESCRIPTOR(defdsc2,".");
10518   struct dsc$descriptor_s resdsc;
10519   struct dsc$descriptor_s *vmscmd;
10520   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10521   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10522   register char *s, *rest, *cp, *wordbreak;
10523   char * cmd;
10524   int cmdlen;
10525   register int isdcl;
10526
10527   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10528   if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10529
10530   /* vmsspec is a DCL command buffer, not just a filename */
10531   vmsspec = PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10532   if (vmsspec == NULL)
10533       _ckvmssts_noperl(SS$_INSFMEM);
10534
10535   resspec = PerlMem_malloc(VMS_MAXRSS);
10536   if (resspec == NULL)
10537       _ckvmssts_noperl(SS$_INSFMEM);
10538
10539   /* Make a copy for modification */
10540   cmdlen = strlen(incmd);
10541   cmd = PerlMem_malloc(cmdlen+1);
10542   if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10543   strncpy(cmd, incmd, cmdlen);
10544   cmd[cmdlen] = 0;
10545   image_name[0] = 0;
10546   image_argv[0] = 0;
10547
10548   resdsc.dsc$a_pointer = resspec;
10549   resdsc.dsc$b_dtype  = DSC$K_DTYPE_T;
10550   resdsc.dsc$b_class  = DSC$K_CLASS_S;
10551   resdsc.dsc$w_length = VMS_MAXRSS - 1;
10552
10553   vmscmd->dsc$a_pointer = NULL;
10554   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
10555   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
10556   vmscmd->dsc$w_length = 0;
10557   if (pvmscmd) *pvmscmd = vmscmd;
10558
10559   if (suggest_quote) *suggest_quote = 0;
10560
10561   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10562     PerlMem_free(cmd);
10563     PerlMem_free(vmsspec);
10564     PerlMem_free(resspec);
10565     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
10566   }
10567
10568   s = cmd;
10569
10570   while (*s && isspace(*s)) s++;
10571
10572   if (*s == '@' || *s == '$') {
10573     vmsspec[0] = *s;  rest = s + 1;
10574     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10575   }
10576   else { cp = vmsspec; rest = s; }
10577   if (*rest == '.' || *rest == '/') {
10578     char *cp2;
10579     for (cp2 = resspec;
10580          *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10581          rest++, cp2++) *cp2 = *rest;
10582     *cp2 = '\0';
10583     if (int_tovmsspec(resspec, cp, 0, NULL)) {
10584       s = vmsspec;
10585
10586       /* When a UNIX spec with no file type is translated to VMS, */
10587       /* A trailing '.' is appended under ODS-5 rules.            */
10588       /* Here we do not want that trailing "." as it prevents     */
10589       /* Looking for a implied ".exe" type. */
10590       if (decc_efs_charset) {
10591           int i;
10592           i = strlen(vmsspec);
10593           if (vmsspec[i-1] == '.') {
10594               vmsspec[i-1] = '\0';
10595           }
10596       }
10597
10598       if (*rest) {
10599         for (cp2 = vmsspec + strlen(vmsspec);
10600              *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10601              rest++, cp2++) *cp2 = *rest;
10602         *cp2 = '\0';
10603       }
10604     }
10605   }
10606   /* Intuit whether verb (first word of cmd) is a DCL command:
10607    *   - if first nonspace char is '@', it's a DCL indirection
10608    * otherwise
10609    *   - if verb contains a filespec separator, it's not a DCL command
10610    *   - if it doesn't, caller tells us whether to default to a DCL
10611    *     command, or to a local image unless told it's DCL (by leading '$')
10612    */
10613   if (*s == '@') {
10614       isdcl = 1;
10615       if (suggest_quote) *suggest_quote = 1;
10616   } else {
10617     register char *filespec = strpbrk(s,":<[.;");
10618     rest = wordbreak = strpbrk(s," \"\t/");
10619     if (!wordbreak) wordbreak = s + strlen(s);
10620     if (*s == '$') check_img = 0;
10621     if (filespec && (filespec < wordbreak)) isdcl = 0;
10622     else isdcl = !check_img;
10623   }
10624
10625   if (!isdcl) {
10626     int rsts;
10627     imgdsc.dsc$a_pointer = s;
10628     imgdsc.dsc$w_length = wordbreak - s;
10629     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10630     if (!(retsts&1)) {
10631         _ckvmssts_noperl(lib$find_file_end(&cxt));
10632         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10633       if (!(retsts & 1) && *s == '$') {
10634         _ckvmssts_noperl(lib$find_file_end(&cxt));
10635         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10636         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10637         if (!(retsts&1)) {
10638           _ckvmssts_noperl(lib$find_file_end(&cxt));
10639           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10640         }
10641       }
10642     }
10643     _ckvmssts_noperl(lib$find_file_end(&cxt));
10644
10645     if (retsts & 1) {
10646       FILE *fp;
10647       s = resspec;
10648       while (*s && !isspace(*s)) s++;
10649       *s = '\0';
10650
10651       /* check that it's really not DCL with no file extension */
10652       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10653       if (fp) {
10654         char b[256] = {0,0,0,0};
10655         read(fileno(fp), b, 256);
10656         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10657         if (isdcl) {
10658           int shebang_len;
10659
10660           /* Check for script */
10661           shebang_len = 0;
10662           if ((b[0] == '#') && (b[1] == '!'))
10663              shebang_len = 2;
10664 #ifdef ALTERNATE_SHEBANG
10665           else {
10666             shebang_len = strlen(ALTERNATE_SHEBANG);
10667             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10668               char * perlstr;
10669                 perlstr = strstr("perl",b);
10670                 if (perlstr == NULL)
10671                   shebang_len = 0;
10672             }
10673             else
10674               shebang_len = 0;
10675           }
10676 #endif
10677
10678           if (shebang_len > 0) {
10679           int i;
10680           int j;
10681           char tmpspec[NAM$C_MAXRSS + 1];
10682
10683             i = shebang_len;
10684              /* Image is following after white space */
10685             /*--------------------------------------*/
10686             while (isprint(b[i]) && isspace(b[i]))
10687                 i++;
10688
10689             j = 0;
10690             while (isprint(b[i]) && !isspace(b[i])) {
10691                 tmpspec[j++] = b[i++];
10692                 if (j >= NAM$C_MAXRSS)
10693                    break;
10694             }
10695             tmpspec[j] = '\0';
10696
10697              /* There may be some default parameters to the image */
10698             /*---------------------------------------------------*/
10699             j = 0;
10700             while (isprint(b[i])) {
10701                 image_argv[j++] = b[i++];
10702                 if (j >= NAM$C_MAXRSS)
10703                    break;
10704             }
10705             while ((j > 0) && !isprint(image_argv[j-1]))
10706                 j--;
10707             image_argv[j] = 0;
10708
10709             /* It will need to be converted to VMS format and validated */
10710             if (tmpspec[0] != '\0') {
10711               char * iname;
10712
10713                /* Try to find the exact program requested to be run */
10714               /*---------------------------------------------------*/
10715               iname = int_rmsexpand
10716                  (tmpspec, image_name, ".exe",
10717                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10718               if (iname != NULL) {
10719                 if (cando_by_name_int
10720                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10721                   /* MCR prefix needed */
10722                   isdcl = 0;
10723                 }
10724                 else {
10725                    /* Try again with a null type */
10726                   /*----------------------------*/
10727                   iname = int_rmsexpand
10728                     (tmpspec, image_name, ".",
10729                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10730                   if (iname != NULL) {
10731                     if (cando_by_name_int
10732                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10733                       /* MCR prefix needed */
10734                       isdcl = 0;
10735                     }
10736                   }
10737                 }
10738
10739                  /* Did we find the image to run the script? */
10740                 /*------------------------------------------*/
10741                 if (isdcl) {
10742                   char *tchr;
10743
10744                    /* Assume DCL or foreign command exists */
10745                   /*--------------------------------------*/
10746                   tchr = strrchr(tmpspec, '/');
10747                   if (tchr != NULL) {
10748                     tchr++;
10749                   }
10750                   else {
10751                     tchr = tmpspec;
10752                   }
10753                   strcpy(image_name, tchr);
10754                 }
10755               }
10756             }
10757           }
10758         }
10759         fclose(fp);
10760       }
10761       if (check_img && isdcl) {
10762           PerlMem_free(cmd);
10763           PerlMem_free(resspec);
10764           PerlMem_free(vmsspec);
10765           return RMS$_FNF;
10766       }
10767
10768       if (cando_by_name(S_IXUSR,0,resspec)) {
10769         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10770         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10771         if (!isdcl) {
10772             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
10773             if (image_name[0] != 0) {
10774                 strcat(vmscmd->dsc$a_pointer, image_name);
10775                 strcat(vmscmd->dsc$a_pointer, " ");
10776             }
10777         } else if (image_name[0] != 0) {
10778             strcpy(vmscmd->dsc$a_pointer, image_name);
10779             strcat(vmscmd->dsc$a_pointer, " ");
10780         } else {
10781             strcpy(vmscmd->dsc$a_pointer,"@");
10782         }
10783         if (suggest_quote) *suggest_quote = 1;
10784
10785         /* If there is an image name, use original command */
10786         if (image_name[0] == 0)
10787             strcat(vmscmd->dsc$a_pointer,resspec);
10788         else {
10789             rest = cmd;
10790             while (*rest && isspace(*rest)) rest++;
10791         }
10792
10793         if (image_argv[0] != 0) {
10794           strcat(vmscmd->dsc$a_pointer,image_argv);
10795           strcat(vmscmd->dsc$a_pointer, " ");
10796         }
10797         if (rest) {
10798            int rest_len;
10799            int vmscmd_len;
10800
10801            rest_len = strlen(rest);
10802            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10803            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10804               strcat(vmscmd->dsc$a_pointer,rest);
10805            else
10806              retsts = CLI$_BUFOVF;
10807         }
10808         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10809         PerlMem_free(cmd);
10810         PerlMem_free(vmsspec);
10811         PerlMem_free(resspec);
10812         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10813       }
10814       else
10815         retsts = RMS$_PRV;
10816     }
10817   }
10818   /* It's either a DCL command or we couldn't find a suitable image */
10819   vmscmd->dsc$w_length = strlen(cmd);
10820
10821   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
10822   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
10823   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
10824
10825   PerlMem_free(cmd);
10826   PerlMem_free(resspec);
10827   PerlMem_free(vmsspec);
10828
10829   /* check if it's a symbol (for quoting purposes) */
10830   if (suggest_quote && !*suggest_quote) {
10831     int iss;
10832     char equiv[LNM$C_NAMLENGTH];
10833     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10834     eqvdsc.dsc$a_pointer = equiv;
10835
10836     iss = lib$get_symbol(vmscmd,&eqvdsc);
10837     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10838   }
10839   if (!(retsts & 1)) {
10840     /* just hand off status values likely to be due to user error */
10841     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10842         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10843        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10844     else { _ckvmssts_noperl(retsts); }
10845   }
10846
10847   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10848
10849 }  /* end of setup_cmddsc() */
10850
10851
10852 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10853 bool
10854 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10855 {
10856 bool exec_sts;
10857 char * cmd;
10858
10859   if (sp > mark) {
10860     if (vfork_called) {           /* this follows a vfork - act Unixish */
10861       vfork_called--;
10862       if (vfork_called < 0) {
10863         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10864         vfork_called = 0;
10865       }
10866       else return do_aexec(really,mark,sp);
10867     }
10868                                            /* no vfork - act VMSish */
10869     cmd = setup_argstr(aTHX_ really,mark,sp);
10870     exec_sts = vms_do_exec(cmd);
10871     Safefree(cmd);  /* Clean up from setup_argstr() */
10872     return exec_sts;
10873   }
10874
10875   return FALSE;
10876 }  /* end of vms_do_aexec() */
10877 /*}}}*/
10878
10879 /* {{{bool vms_do_exec(char *cmd) */
10880 bool
10881 Perl_vms_do_exec(pTHX_ const char *cmd)
10882 {
10883   struct dsc$descriptor_s *vmscmd;
10884
10885   if (vfork_called) {             /* this follows a vfork - act Unixish */
10886     vfork_called--;
10887     if (vfork_called < 0) {
10888       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10889       vfork_called = 0;
10890     }
10891     else return do_exec(cmd);
10892   }
10893
10894   {                               /* no vfork - act VMSish */
10895     unsigned long int retsts;
10896
10897     TAINT_ENV();
10898     TAINT_PROPER("exec");
10899     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10900       retsts = lib$do_command(vmscmd);
10901
10902     switch (retsts) {
10903       case RMS$_FNF: case RMS$_DNF:
10904         set_errno(ENOENT); break;
10905       case RMS$_DIR:
10906         set_errno(ENOTDIR); break;
10907       case RMS$_DEV:
10908         set_errno(ENODEV); break;
10909       case RMS$_PRV:
10910         set_errno(EACCES); break;
10911       case RMS$_SYN:
10912         set_errno(EINVAL); break;
10913       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10914         set_errno(E2BIG); break;
10915       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10916         _ckvmssts_noperl(retsts); /* fall through */
10917       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10918         set_errno(EVMSERR);
10919     }
10920     set_vaxc_errno(retsts);
10921     if (ckWARN(WARN_EXEC)) {
10922       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10923              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10924     }
10925     vms_execfree(vmscmd);
10926   }
10927
10928   return FALSE;
10929
10930 }  /* end of vms_do_exec() */
10931 /*}}}*/
10932
10933 int do_spawn2(pTHX_ const char *, int);
10934
10935 int
10936 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
10937 {
10938 unsigned long int sts;
10939 char * cmd;
10940 int flags = 0;
10941
10942   if (sp > mark) {
10943
10944     /* We'll copy the (undocumented?) Win32 behavior and allow a
10945      * numeric first argument.  But the only value we'll support
10946      * through do_aspawn is a value of 1, which means spawn without
10947      * waiting for completion -- other values are ignored.
10948      */
10949     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
10950         ++mark;
10951         flags = SvIVx(*mark);
10952     }
10953
10954     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
10955         flags = CLI$M_NOWAIT;
10956     else
10957         flags = 0;
10958
10959     cmd = setup_argstr(aTHX_ really, mark, sp);
10960     sts = do_spawn2(aTHX_ cmd, flags);
10961     /* pp_sys will clean up cmd */
10962     return sts;
10963   }
10964   return SS$_ABORT;
10965 }  /* end of do_aspawn() */
10966 /*}}}*/
10967
10968
10969 /* {{{int do_spawn(char* cmd) */
10970 int
10971 Perl_do_spawn(pTHX_ char* cmd)
10972 {
10973     PERL_ARGS_ASSERT_DO_SPAWN;
10974
10975     return do_spawn2(aTHX_ cmd, 0);
10976 }
10977 /*}}}*/
10978
10979 /* {{{int do_spawn_nowait(char* cmd) */
10980 int
10981 Perl_do_spawn_nowait(pTHX_ char* cmd)
10982 {
10983     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
10984
10985     return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
10986 }
10987 /*}}}*/
10988
10989 /* {{{int do_spawn2(char *cmd) */
10990 int
10991 do_spawn2(pTHX_ const char *cmd, int flags)
10992 {
10993   unsigned long int sts, substs;
10994
10995   /* The caller of this routine expects to Safefree(PL_Cmd) */
10996   Newx(PL_Cmd,10,char);
10997
10998   TAINT_ENV();
10999   TAINT_PROPER("spawn");
11000   if (!cmd || !*cmd) {
11001     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
11002     if (!(sts & 1)) {
11003       switch (sts) {
11004         case RMS$_FNF:  case RMS$_DNF:
11005           set_errno(ENOENT); break;
11006         case RMS$_DIR:
11007           set_errno(ENOTDIR); break;
11008         case RMS$_DEV:
11009           set_errno(ENODEV); break;
11010         case RMS$_PRV:
11011           set_errno(EACCES); break;
11012         case RMS$_SYN:
11013           set_errno(EINVAL); break;
11014         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11015           set_errno(E2BIG); break;
11016         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11017           _ckvmssts_noperl(sts); /* fall through */
11018         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11019           set_errno(EVMSERR);
11020       }
11021       set_vaxc_errno(sts);
11022       if (ckWARN(WARN_EXEC)) {
11023         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
11024                     Strerror(errno));
11025       }
11026     }
11027     sts = substs;
11028   }
11029   else {
11030     char mode[3];
11031     PerlIO * fp;
11032     if (flags & CLI$M_NOWAIT)
11033         strcpy(mode, "n");
11034     else
11035         strcpy(mode, "nW");
11036
11037     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
11038     if (fp != NULL)
11039       my_pclose(fp);
11040     /* sts will be the pid in the nowait case */
11041   }
11042   return sts;
11043 }  /* end of do_spawn2() */
11044 /*}}}*/
11045
11046
11047 static unsigned int *sockflags, sockflagsize;
11048
11049 /*
11050  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
11051  * routines found in some versions of the CRTL can't deal with sockets.
11052  * We don't shim the other file open routines since a socket isn't
11053  * likely to be opened by a name.
11054  */
11055 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
11056 FILE *my_fdopen(int fd, const char *mode)
11057 {
11058   FILE *fp = fdopen(fd, mode);
11059
11060   if (fp) {
11061     unsigned int fdoff = fd / sizeof(unsigned int);
11062     Stat_t sbuf; /* native stat; we don't need flex_stat */
11063     if (!sockflagsize || fdoff > sockflagsize) {
11064       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
11065       else           Newx  (sockflags,fdoff+2,unsigned int);
11066       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11067       sockflagsize = fdoff + 2;
11068     }
11069     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
11070       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11071   }
11072   return fp;
11073
11074 }
11075 /*}}}*/
11076
11077
11078 /*
11079  * Clear the corresponding bit when the (possibly) socket stream is closed.
11080  * There still a small hole: we miss an implicit close which might occur
11081  * via freopen().  >> Todo
11082  */
11083 /*{{{ int my_fclose(FILE *fp)*/
11084 int my_fclose(FILE *fp) {
11085   if (fp) {
11086     unsigned int fd = fileno(fp);
11087     unsigned int fdoff = fd / sizeof(unsigned int);
11088
11089     if (sockflagsize && fdoff < sockflagsize)
11090       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11091   }
11092   return fclose(fp);
11093 }
11094 /*}}}*/
11095
11096
11097 /*
11098  * A simple fwrite replacement which outputs itmsz*nitm chars without
11099  * introducing record boundaries every itmsz chars.
11100  * We are using fputs, which depends on a terminating null.  We may
11101  * well be writing binary data, so we need to accommodate not only
11102  * data with nulls sprinkled in the middle but also data with no null
11103  * byte at the end.
11104  */
11105 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
11106 int
11107 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11108 {
11109   register char *cp, *end, *cpd, *data;
11110   register unsigned int fd = fileno(dest);
11111   register unsigned int fdoff = fd / sizeof(unsigned int);
11112   int retval;
11113   int bufsize = itmsz * nitm + 1;
11114
11115   if (fdoff < sockflagsize &&
11116       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11117     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11118     return nitm;
11119   }
11120
11121   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11122   memcpy( data, src, itmsz*nitm );
11123   data[itmsz*nitm] = '\0';
11124
11125   end = data + itmsz * nitm;
11126   retval = (int) nitm; /* on success return # items written */
11127
11128   cpd = data;
11129   while (cpd <= end) {
11130     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11131     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11132     if (cp < end)
11133       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11134     cpd = cp + 1;
11135   }
11136
11137   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11138   return retval;
11139
11140 }  /* end of my_fwrite() */
11141 /*}}}*/
11142
11143 /*{{{ int my_flush(FILE *fp)*/
11144 int
11145 Perl_my_flush(pTHX_ FILE *fp)
11146 {
11147     int res;
11148     if ((res = fflush(fp)) == 0 && fp) {
11149 #ifdef VMS_DO_SOCKETS
11150         Stat_t s;
11151         if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11152 #endif
11153             res = fsync(fileno(fp));
11154     }
11155 /*
11156  * If the flush succeeded but set end-of-file, we need to clear
11157  * the error because our caller may check ferror().  BTW, this
11158  * probably means we just flushed an empty file.
11159  */
11160     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11161
11162     return res;
11163 }
11164 /*}}}*/
11165
11166 /*
11167  * Here are replacements for the following Unix routines in the VMS environment:
11168  *      getpwuid    Get information for a particular UIC or UID
11169  *      getpwnam    Get information for a named user
11170  *      getpwent    Get information for each user in the rights database
11171  *      setpwent    Reset search to the start of the rights database
11172  *      endpwent    Finish searching for users in the rights database
11173  *
11174  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11175  * (defined in pwd.h), which contains the following fields:-
11176  *      struct passwd {
11177  *              char        *pw_name;    Username (in lower case)
11178  *              char        *pw_passwd;  Hashed password
11179  *              unsigned int pw_uid;     UIC
11180  *              unsigned int pw_gid;     UIC group  number
11181  *              char        *pw_unixdir; Default device/directory (VMS-style)
11182  *              char        *pw_gecos;   Owner name
11183  *              char        *pw_dir;     Default device/directory (Unix-style)
11184  *              char        *pw_shell;   Default CLI name (eg. DCL)
11185  *      };
11186  * If the specified user does not exist, getpwuid and getpwnam return NULL.
11187  *
11188  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11189  * not the UIC member number (eg. what's returned by getuid()),
11190  * getpwuid() can accept either as input (if uid is specified, the caller's
11191  * UIC group is used), though it won't recognise gid=0.
11192  *
11193  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11194  * information about other users in your group or in other groups, respectively.
11195  * If the required privilege is not available, then these routines fill only
11196  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11197  * string).
11198  *
11199  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11200  */
11201
11202 /* sizes of various UAF record fields */
11203 #define UAI$S_USERNAME 12
11204 #define UAI$S_IDENT    31
11205 #define UAI$S_OWNER    31
11206 #define UAI$S_DEFDEV   31
11207 #define UAI$S_DEFDIR   63
11208 #define UAI$S_DEFCLI   31
11209 #define UAI$S_PWD       8
11210
11211 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
11212                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11213                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
11214
11215 static char __empty[]= "";
11216 static struct passwd __passwd_empty=
11217     {(char *) __empty, (char *) __empty, 0, 0,
11218      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11219 static int contxt= 0;
11220 static struct passwd __pwdcache;
11221 static char __pw_namecache[UAI$S_IDENT+1];
11222
11223 /*
11224  * This routine does most of the work extracting the user information.
11225  */
11226 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11227 {
11228     static struct {
11229         unsigned char length;
11230         char pw_gecos[UAI$S_OWNER+1];
11231     } owner;
11232     static union uicdef uic;
11233     static struct {
11234         unsigned char length;
11235         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11236     } defdev;
11237     static struct {
11238         unsigned char length;
11239         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11240     } defdir;
11241     static struct {
11242         unsigned char length;
11243         char pw_shell[UAI$S_DEFCLI+1];
11244     } defcli;
11245     static char pw_passwd[UAI$S_PWD+1];
11246
11247     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11248     struct dsc$descriptor_s name_desc;
11249     unsigned long int sts;
11250
11251     static struct itmlst_3 itmlst[]= {
11252         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
11253         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
11254         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
11255         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
11256         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
11257         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
11258         {0,                0,           NULL,    NULL}};
11259
11260     name_desc.dsc$w_length=  strlen(name);
11261     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11262     name_desc.dsc$b_class=   DSC$K_CLASS_S;
11263     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11264
11265 /*  Note that sys$getuai returns many fields as counted strings. */
11266     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11267     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11268       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11269     }
11270     else { _ckvmssts(sts); }
11271     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
11272
11273     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
11274     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11275     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11276     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11277     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11278     owner.pw_gecos[lowner]=            '\0';
11279     defdev.pw_dir[ldefdev+ldefdir]= '\0';
11280     defcli.pw_shell[ldefcli]=          '\0';
11281     if (valid_uic(uic)) {
11282         pwd->pw_uid= uic.uic$l_uic;
11283         pwd->pw_gid= uic.uic$v_group;
11284     }
11285     else
11286       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11287     pwd->pw_passwd=  pw_passwd;
11288     pwd->pw_gecos=   owner.pw_gecos;
11289     pwd->pw_dir=     defdev.pw_dir;
11290     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11291     pwd->pw_shell=   defcli.pw_shell;
11292     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11293         int ldir;
11294         ldir= strlen(pwd->pw_unixdir) - 1;
11295         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11296     }
11297     else
11298         strcpy(pwd->pw_unixdir, pwd->pw_dir);
11299     if (!decc_efs_case_preserve)
11300         __mystrtolower(pwd->pw_unixdir);
11301     return 1;
11302 }
11303
11304 /*
11305  * Get information for a named user.
11306 */
11307 /*{{{struct passwd *getpwnam(char *name)*/
11308 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
11309 {
11310     struct dsc$descriptor_s name_desc;
11311     union uicdef uic;
11312     unsigned long int status, sts;
11313
11314     __pwdcache = __passwd_empty;
11315     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11316       /* We still may be able to determine pw_uid and pw_gid */
11317       name_desc.dsc$w_length=  strlen(name);
11318       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11319       name_desc.dsc$b_class=   DSC$K_CLASS_S;
11320       name_desc.dsc$a_pointer= (char *) name;
11321       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11322         __pwdcache.pw_uid= uic.uic$l_uic;
11323         __pwdcache.pw_gid= uic.uic$v_group;
11324       }
11325       else {
11326         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11327           set_vaxc_errno(sts);
11328           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11329           return NULL;
11330         }
11331         else { _ckvmssts(sts); }
11332       }
11333     }
11334     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
11335     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
11336     __pwdcache.pw_name= __pw_namecache;
11337     return &__pwdcache;
11338 }  /* end of my_getpwnam() */
11339 /*}}}*/
11340
11341 /*
11342  * Get information for a particular UIC or UID.
11343  * Called by my_getpwent with uid=-1 to list all users.
11344 */
11345 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11346 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
11347 {
11348     const $DESCRIPTOR(name_desc,__pw_namecache);
11349     unsigned short lname;
11350     union uicdef uic;
11351     unsigned long int status;
11352
11353     if (uid == (unsigned int) -1) {
11354       do {
11355         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11356         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11357           set_vaxc_errno(status);
11358           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11359           my_endpwent();
11360           return NULL;
11361         }
11362         else { _ckvmssts(status); }
11363       } while (!valid_uic (uic));
11364     }
11365     else {
11366       uic.uic$l_uic= uid;
11367       if (!uic.uic$v_group)
11368         uic.uic$v_group= PerlProc_getgid();
11369       if (valid_uic(uic))
11370         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11371       else status = SS$_IVIDENT;
11372       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11373           status == RMS$_PRV) {
11374         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11375         return NULL;
11376       }
11377       else { _ckvmssts(status); }
11378     }
11379     __pw_namecache[lname]= '\0';
11380     __mystrtolower(__pw_namecache);
11381
11382     __pwdcache = __passwd_empty;
11383     __pwdcache.pw_name = __pw_namecache;
11384
11385 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11386     The identifier's value is usually the UIC, but it doesn't have to be,
11387     so if we can, we let fillpasswd update this. */
11388     __pwdcache.pw_uid =  uic.uic$l_uic;
11389     __pwdcache.pw_gid =  uic.uic$v_group;
11390
11391     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11392     return &__pwdcache;
11393
11394 }  /* end of my_getpwuid() */
11395 /*}}}*/
11396
11397 /*
11398  * Get information for next user.
11399 */
11400 /*{{{struct passwd *my_getpwent()*/
11401 struct passwd *Perl_my_getpwent(pTHX)
11402 {
11403     return (my_getpwuid((unsigned int) -1));
11404 }
11405 /*}}}*/
11406
11407 /*
11408  * Finish searching rights database for users.
11409 */
11410 /*{{{void my_endpwent()*/
11411 void Perl_my_endpwent(pTHX)
11412 {
11413     if (contxt) {
11414       _ckvmssts(sys$finish_rdb(&contxt));
11415       contxt= 0;
11416     }
11417 }
11418 /*}}}*/
11419
11420 #ifdef HOMEGROWN_POSIX_SIGNALS
11421   /* Signal handling routines, pulled into the core from POSIX.xs.
11422    *
11423    * We need these for threads, so they've been rolled into the core,
11424    * rather than left in POSIX.xs.
11425    *
11426    * (DRS, Oct 23, 1997)
11427    */
11428
11429   /* sigset_t is atomic under VMS, so these routines are easy */
11430 /*{{{int my_sigemptyset(sigset_t *) */
11431 int my_sigemptyset(sigset_t *set) {
11432     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11433     *set = 0; return 0;
11434 }
11435 /*}}}*/
11436
11437
11438 /*{{{int my_sigfillset(sigset_t *)*/
11439 int my_sigfillset(sigset_t *set) {
11440     int i;
11441     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11442     for (i = 0; i < NSIG; i++) *set |= (1 << i);
11443     return 0;
11444 }
11445 /*}}}*/
11446
11447
11448 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
11449 int my_sigaddset(sigset_t *set, int sig) {
11450     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11451     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11452     *set |= (1 << (sig - 1));
11453     return 0;
11454 }
11455 /*}}}*/
11456
11457
11458 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
11459 int my_sigdelset(sigset_t *set, int sig) {
11460     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11461     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11462     *set &= ~(1 << (sig - 1));
11463     return 0;
11464 }
11465 /*}}}*/
11466
11467
11468 /*{{{int my_sigismember(sigset_t *set, int sig)*/
11469 int my_sigismember(sigset_t *set, int sig) {
11470     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11471     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11472     return *set & (1 << (sig - 1));
11473 }
11474 /*}}}*/
11475
11476
11477 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
11478 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
11479     sigset_t tempmask;
11480
11481     /* If set and oset are both null, then things are badly wrong. Bail out. */
11482     if ((oset == NULL) && (set == NULL)) {
11483       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
11484       return -1;
11485     }
11486
11487     /* If set's null, then we're just handling a fetch. */
11488     if (set == NULL) {
11489         tempmask = sigblock(0);
11490     }
11491     else {
11492       switch (how) {
11493       case SIG_SETMASK:
11494         tempmask = sigsetmask(*set);
11495         break;
11496       case SIG_BLOCK:
11497         tempmask = sigblock(*set);
11498         break;
11499       case SIG_UNBLOCK:
11500         tempmask = sigblock(0);
11501         sigsetmask(*oset & ~tempmask);
11502         break;
11503       default:
11504         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11505         return -1;
11506       }
11507     }
11508
11509     /* Did they pass us an oset? If so, stick our holding mask into it */
11510     if (oset)
11511       *oset = tempmask;
11512
11513     return 0;
11514 }
11515 /*}}}*/
11516 #endif  /* HOMEGROWN_POSIX_SIGNALS */
11517
11518
11519 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11520  * my_utime(), and flex_stat(), all of which operate on UTC unless
11521  * VMSISH_TIMES is true.
11522  */
11523 /* method used to handle UTC conversions:
11524  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
11525  */
11526 static int gmtime_emulation_type;
11527 /* number of secs to add to UTC POSIX-style time to get local time */
11528 static long int utc_offset_secs;
11529
11530 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11531  * in vmsish.h.  #undef them here so we can call the CRTL routines
11532  * directly.
11533  */
11534 #undef gmtime
11535 #undef localtime
11536 #undef time
11537
11538
11539 /*
11540  * DEC C previous to 6.0 corrupts the behavior of the /prefix
11541  * qualifier with the extern prefix pragma.  This provisional
11542  * hack circumvents this prefix pragma problem in previous
11543  * precompilers.
11544  */
11545 #if defined(__VMS_VER) && __VMS_VER >= 70000000
11546 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
11547 #    pragma __extern_prefix save
11548 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
11549 #    define gmtime decc$__utctz_gmtime
11550 #    define localtime decc$__utctz_localtime
11551 #    define time decc$__utc_time
11552 #    pragma __extern_prefix restore
11553
11554      struct tm *gmtime(), *localtime();
11555
11556 #  endif
11557 #endif
11558
11559
11560 static time_t toutc_dst(time_t loc) {
11561   struct tm *rsltmp;
11562
11563   if ((rsltmp = localtime(&loc)) == NULL) return -1;
11564   loc -= utc_offset_secs;
11565   if (rsltmp->tm_isdst) loc -= 3600;
11566   return loc;
11567 }
11568 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11569        ((gmtime_emulation_type || my_time(NULL)), \
11570        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11571        ((secs) - utc_offset_secs))))
11572
11573 static time_t toloc_dst(time_t utc) {
11574   struct tm *rsltmp;
11575
11576   utc += utc_offset_secs;
11577   if ((rsltmp = localtime(&utc)) == NULL) return -1;
11578   if (rsltmp->tm_isdst) utc += 3600;
11579   return utc;
11580 }
11581 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11582        ((gmtime_emulation_type || my_time(NULL)), \
11583        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11584        ((secs) + utc_offset_secs))))
11585
11586 #ifndef RTL_USES_UTC
11587 /*
11588
11589     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
11590         DST starts on 1st sun of april      at 02:00  std time
11591             ends on last sun of october     at 02:00  dst time
11592     see the UCX management command reference, SET CONFIG TIMEZONE
11593     for formatting info.
11594
11595     No, it's not as general as it should be, but then again, NOTHING
11596     will handle UK times in a sensible way.
11597 */
11598
11599
11600 /*
11601     parse the DST start/end info:
11602     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
11603 */
11604
11605 static char *
11606 tz_parse_startend(char *s, struct tm *w, int *past)
11607 {
11608     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
11609     int ly, dozjd, d, m, n, hour, min, sec, j, k;
11610     time_t g;
11611
11612     if (!s)    return 0;
11613     if (!w) return 0;
11614     if (!past) return 0;
11615
11616     ly = 0;
11617     if (w->tm_year % 4        == 0) ly = 1;
11618     if (w->tm_year % 100      == 0) ly = 0;
11619     if (w->tm_year+1900 % 400 == 0) ly = 1;
11620     if (ly) dinm[1]++;
11621
11622     dozjd = isdigit(*s);
11623     if (*s == 'J' || *s == 'j' || dozjd) {
11624         if (!dozjd && !isdigit(*++s)) return 0;
11625         d = *s++ - '0';
11626         if (isdigit(*s)) {
11627             d = d*10 + *s++ - '0';
11628             if (isdigit(*s)) {
11629                 d = d*10 + *s++ - '0';
11630             }
11631         }
11632         if (d == 0) return 0;
11633         if (d > 366) return 0;
11634         d--;
11635         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
11636         g = d * 86400;
11637         dozjd = 1;
11638     } else if (*s == 'M' || *s == 'm') {
11639         if (!isdigit(*++s)) return 0;
11640         m = *s++ - '0';
11641         if (isdigit(*s)) m = 10*m + *s++ - '0';
11642         if (*s != '.') return 0;
11643         if (!isdigit(*++s)) return 0;
11644         n = *s++ - '0';
11645         if (n < 1 || n > 5) return 0;
11646         if (*s != '.') return 0;
11647         if (!isdigit(*++s)) return 0;
11648         d = *s++ - '0';
11649         if (d > 6) return 0;
11650     }
11651
11652     if (*s == '/') {
11653         if (!isdigit(*++s)) return 0;
11654         hour = *s++ - '0';
11655         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
11656         if (*s == ':') {
11657             if (!isdigit(*++s)) return 0;
11658             min = *s++ - '0';
11659             if (isdigit(*s)) min = 10*min + *s++ - '0';
11660             if (*s == ':') {
11661                 if (!isdigit(*++s)) return 0;
11662                 sec = *s++ - '0';
11663                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
11664             }
11665         }
11666     } else {
11667         hour = 2;
11668         min = 0;
11669         sec = 0;
11670     }
11671
11672     if (dozjd) {
11673         if (w->tm_yday < d) goto before;
11674         if (w->tm_yday > d) goto after;
11675     } else {
11676         if (w->tm_mon+1 < m) goto before;
11677         if (w->tm_mon+1 > m) goto after;
11678
11679         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
11680         k = d - j; /* mday of first d */
11681         if (k <= 0) k += 7;
11682         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
11683         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
11684         if (w->tm_mday < k) goto before;
11685         if (w->tm_mday > k) goto after;
11686     }
11687
11688     if (w->tm_hour < hour) goto before;
11689     if (w->tm_hour > hour) goto after;
11690     if (w->tm_min  < min)  goto before;
11691     if (w->tm_min  > min)  goto after;
11692     if (w->tm_sec  < sec)  goto before;
11693     goto after;
11694
11695 before:
11696     *past = 0;
11697     return s;
11698 after:
11699     *past = 1;
11700     return s;
11701 }
11702
11703
11704
11705
11706 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
11707
11708 static char *
11709 tz_parse_offset(char *s, int *offset)
11710 {
11711     int hour = 0, min = 0, sec = 0;
11712     int neg = 0;
11713     if (!s) return 0;
11714     if (!offset) return 0;
11715
11716     if (*s == '-') {neg++; s++;}
11717     if (*s == '+') s++;
11718     if (!isdigit(*s)) return 0;
11719     hour = *s++ - '0';
11720     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
11721     if (hour > 24) return 0;
11722     if (*s == ':') {
11723         if (!isdigit(*++s)) return 0;
11724         min = *s++ - '0';
11725         if (isdigit(*s)) min = min*10 + (*s++ - '0');
11726         if (min > 59) return 0;
11727         if (*s == ':') {
11728             if (!isdigit(*++s)) return 0;
11729             sec = *s++ - '0';
11730             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
11731             if (sec > 59) return 0;
11732         }
11733     }
11734
11735     *offset = (hour*60+min)*60 + sec;
11736     if (neg) *offset = -*offset;
11737     return s;
11738 }
11739
11740 /*
11741     input time is w, whatever type of time the CRTL localtime() uses.
11742     sets dst, the zone, and the gmtoff (seconds)
11743
11744     caches the value of TZ and UCX$TZ env variables; note that
11745     my_setenv looks for these and sets a flag if they're changed
11746     for efficiency.
11747
11748     We have to watch out for the "australian" case (dst starts in
11749     october, ends in april)...flagged by "reverse" and checked by
11750     scanning through the months of the previous year.
11751
11752 */
11753
11754 static int
11755 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
11756 {
11757     time_t when;
11758     struct tm *w2;
11759     char *s,*s2;
11760     char *dstzone, *tz, *s_start, *s_end;
11761     int std_off, dst_off, isdst;
11762     int y, dststart, dstend;
11763     static char envtz[1025];  /* longer than any logical, symbol, ... */
11764     static char ucxtz[1025];
11765     static char reversed = 0;
11766
11767     if (!w) return 0;
11768
11769     if (tz_updated) {
11770         tz_updated = 0;
11771         reversed = -1;  /* flag need to check  */
11772         envtz[0] = ucxtz[0] = '\0';
11773         tz = my_getenv("TZ",0);
11774         if (tz) strcpy(envtz, tz);
11775         tz = my_getenv("UCX$TZ",0);
11776         if (tz) strcpy(ucxtz, tz);
11777         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
11778     }
11779     tz = envtz;
11780     if (!*tz) tz = ucxtz;
11781
11782     s = tz;
11783     while (isalpha(*s)) s++;
11784     s = tz_parse_offset(s, &std_off);
11785     if (!s) return 0;
11786     if (!*s) {                  /* no DST, hurray we're done! */
11787         isdst = 0;
11788         goto done;
11789     }
11790
11791     dstzone = s;
11792     while (isalpha(*s)) s++;
11793     s2 = tz_parse_offset(s, &dst_off);
11794     if (s2) {
11795         s = s2;
11796     } else {
11797         dst_off = std_off - 3600;
11798     }
11799
11800     if (!*s) {      /* default dst start/end?? */
11801         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
11802             s = strchr(ucxtz,',');
11803         }
11804         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
11805     }
11806     if (*s != ',') return 0;
11807
11808     when = *w;
11809     when = _toutc(when);      /* convert to utc */
11810     when = when - std_off;    /* convert to pseudolocal time*/
11811
11812     w2 = localtime(&when);
11813     y = w2->tm_year;
11814     s_start = s+1;
11815     s = tz_parse_startend(s_start,w2,&dststart);
11816     if (!s) return 0;
11817     if (*s != ',') return 0;
11818
11819     when = *w;
11820     when = _toutc(when);      /* convert to utc */
11821     when = when - dst_off;    /* convert to pseudolocal time*/
11822     w2 = localtime(&when);
11823     if (w2->tm_year != y) {   /* spans a year, just check one time */
11824         when += dst_off - std_off;
11825         w2 = localtime(&when);
11826     }
11827     s_end = s+1;
11828     s = tz_parse_startend(s_end,w2,&dstend);
11829     if (!s) return 0;
11830
11831     if (reversed == -1) {  /* need to check if start later than end */
11832         int j, ds, de;
11833
11834         when = *w;
11835         if (when < 2*365*86400) {
11836             when += 2*365*86400;
11837         } else {
11838             when -= 365*86400;
11839         }
11840         w2 =localtime(&when);
11841         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
11842
11843         for (j = 0; j < 12; j++) {
11844             w2 =localtime(&when);
11845             tz_parse_startend(s_start,w2,&ds);
11846             tz_parse_startend(s_end,w2,&de);
11847             if (ds != de) break;
11848             when += 30*86400;
11849         }
11850         reversed = 0;
11851         if (de && !ds) reversed = 1;
11852     }
11853
11854     isdst = dststart && !dstend;
11855     if (reversed) isdst = dststart  || !dstend;
11856
11857 done:
11858     if (dst)    *dst = isdst;
11859     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
11860     if (isdst)  tz = dstzone;
11861     if (zone) {
11862         while(isalpha(*tz))  *zone++ = *tz++;
11863         *zone = '\0';
11864     }
11865     return 1;
11866 }
11867
11868 #endif /* !RTL_USES_UTC */
11869
11870 /* my_time(), my_localtime(), my_gmtime()
11871  * By default traffic in UTC time values, using CRTL gmtime() or
11872  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11873  * Note: We need to use these functions even when the CRTL has working
11874  * UTC support, since they also handle C<use vmsish qw(times);>
11875  *
11876  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
11877  * Modified by Charles Bailey <bailey@newman.upenn.edu>
11878  */
11879
11880 /*{{{time_t my_time(time_t *timep)*/
11881 time_t Perl_my_time(pTHX_ time_t *timep)
11882 {
11883   time_t when;
11884   struct tm *tm_p;
11885
11886   if (gmtime_emulation_type == 0) {
11887     int dstnow;
11888     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
11889                               /* results of calls to gmtime() and localtime() */
11890                               /* for same &base */
11891
11892     gmtime_emulation_type++;
11893     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11894       char off[LNM$C_NAMLENGTH+1];;
11895
11896       gmtime_emulation_type++;
11897       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11898         gmtime_emulation_type++;
11899         utc_offset_secs = 0;
11900         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11901       }
11902       else { utc_offset_secs = atol(off); }
11903     }
11904     else { /* We've got a working gmtime() */
11905       struct tm gmt, local;
11906
11907       gmt = *tm_p;
11908       tm_p = localtime(&base);
11909       local = *tm_p;
11910       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
11911       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11912       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
11913       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
11914     }
11915   }
11916
11917   when = time(NULL);
11918 # ifdef VMSISH_TIME
11919 # ifdef RTL_USES_UTC
11920   if (VMSISH_TIME) when = _toloc(when);
11921 # else
11922   if (!VMSISH_TIME) when = _toutc(when);
11923 # endif
11924 # endif
11925   if (timep != NULL) *timep = when;
11926   return when;
11927
11928 }  /* end of my_time() */
11929 /*}}}*/
11930
11931
11932 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11933 struct tm *
11934 Perl_my_gmtime(pTHX_ const time_t *timep)
11935 {
11936   char *p;
11937   time_t when;
11938   struct tm *rsltmp;
11939
11940   if (timep == NULL) {
11941     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11942     return NULL;
11943   }
11944   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11945
11946   when = *timep;
11947 # ifdef VMSISH_TIME
11948   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11949 #  endif
11950 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
11951   return gmtime(&when);
11952 # else
11953   /* CRTL localtime() wants local time as input, so does no tz correction */
11954   rsltmp = localtime(&when);
11955   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
11956   return rsltmp;
11957 #endif
11958 }  /* end of my_gmtime() */
11959 /*}}}*/
11960
11961
11962 /*{{{struct tm *my_localtime(const time_t *timep)*/
11963 struct tm *
11964 Perl_my_localtime(pTHX_ const time_t *timep)
11965 {
11966   time_t when, whenutc;
11967   struct tm *rsltmp;
11968   int dst, offset;
11969
11970   if (timep == NULL) {
11971     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11972     return NULL;
11973   }
11974   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11975   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11976
11977   when = *timep;
11978 # ifdef RTL_USES_UTC
11979 # ifdef VMSISH_TIME
11980   if (VMSISH_TIME) when = _toutc(when);
11981 # endif
11982   /* CRTL localtime() wants UTC as input, does tz correction itself */
11983   return localtime(&when);
11984
11985 # else /* !RTL_USES_UTC */
11986   whenutc = when;
11987 # ifdef VMSISH_TIME
11988   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
11989   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
11990 # endif
11991   dst = -1;
11992 #ifndef RTL_USES_UTC
11993   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
11994       when = whenutc - offset;                   /* pseudolocal time*/
11995   }
11996 # endif
11997   /* CRTL localtime() wants local time as input, so does no tz correction */
11998   rsltmp = localtime(&when);
11999   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
12000   return rsltmp;
12001 # endif
12002
12003 } /*  end of my_localtime() */
12004 /*}}}*/
12005
12006 /* Reset definitions for later calls */
12007 #define gmtime(t)    my_gmtime(t)
12008 #define localtime(t) my_localtime(t)
12009 #define time(t)      my_time(t)
12010
12011
12012 /* my_utime - update modification/access time of a file
12013  *
12014  * VMS 7.3 and later implementation
12015  * Only the UTC translation is home-grown. The rest is handled by the
12016  * CRTL utime(), which will take into account the relevant feature
12017  * logicals and ODS-5 volume characteristics for true access times.
12018  *
12019  * pre VMS 7.3 implementation:
12020  * The calling sequence is identical to POSIX utime(), but under
12021  * VMS with ODS-2, only the modification time is changed; ODS-2 does
12022  * not maintain access times.  Restrictions differ from the POSIX
12023  * definition in that the time can be changed as long as the
12024  * caller has permission to execute the necessary IO$_MODIFY $QIO;
12025  * no separate checks are made to insure that the caller is the
12026  * owner of the file or has special privs enabled.
12027  * Code here is based on Joe Meadows' FILE utility.
12028  *
12029  */
12030
12031 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
12032  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
12033  * in 100 ns intervals.
12034  */
12035 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
12036
12037 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
12038 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
12039 {
12040 #if __CRTL_VER >= 70300000
12041   struct utimbuf utc_utimes, *utc_utimesp;
12042
12043   if (utimes != NULL) {
12044     utc_utimes.actime = utimes->actime;
12045     utc_utimes.modtime = utimes->modtime;
12046 # ifdef VMSISH_TIME
12047     /* If input was local; convert to UTC for sys svc */
12048     if (VMSISH_TIME) {
12049       utc_utimes.actime = _toutc(utimes->actime);
12050       utc_utimes.modtime = _toutc(utimes->modtime);
12051     }
12052 # endif
12053     utc_utimesp = &utc_utimes;
12054   }
12055   else {
12056     utc_utimesp = NULL;
12057   }
12058
12059   return utime(file, utc_utimesp);
12060
12061 #else /* __CRTL_VER < 70300000 */
12062
12063   register int i;
12064   int sts;
12065   long int bintime[2], len = 2, lowbit, unixtime,
12066            secscale = 10000000; /* seconds --> 100 ns intervals */
12067   unsigned long int chan, iosb[2], retsts;
12068   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
12069   struct FAB myfab = cc$rms_fab;
12070   struct NAM mynam = cc$rms_nam;
12071 #if defined (__DECC) && defined (__VAX)
12072   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
12073    * at least through VMS V6.1, which causes a type-conversion warning.
12074    */
12075 #  pragma message save
12076 #  pragma message disable cvtdiftypes
12077 #endif
12078   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
12079   struct fibdef myfib;
12080 #if defined (__DECC) && defined (__VAX)
12081   /* This should be right after the declaration of myatr, but due
12082    * to a bug in VAX DEC C, this takes effect a statement early.
12083    */
12084 #  pragma message restore
12085 #endif
12086   /* cast ok for read only parameter */
12087   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
12088                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
12089                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
12090
12091   if (file == NULL || *file == '\0') {
12092     SETERRNO(ENOENT, LIB$_INVARG);
12093     return -1;
12094   }
12095
12096   /* Convert to VMS format ensuring that it will fit in 255 characters */
12097   if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
12098       SETERRNO(ENOENT, LIB$_INVARG);
12099       return -1;
12100   }
12101   if (utimes != NULL) {
12102     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
12103      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
12104      * Since time_t is unsigned long int, and lib$emul takes a signed long int
12105      * as input, we force the sign bit to be clear by shifting unixtime right
12106      * one bit, then multiplying by an extra factor of 2 in lib$emul().
12107      */
12108     lowbit = (utimes->modtime & 1) ? secscale : 0;
12109     unixtime = (long int) utimes->modtime;
12110 #   ifdef VMSISH_TIME
12111     /* If input was UTC; convert to local for sys svc */
12112     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
12113 #   endif
12114     unixtime >>= 1;  secscale <<= 1;
12115     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
12116     if (!(retsts & 1)) {
12117       SETERRNO(EVMSERR, retsts);
12118       return -1;
12119     }
12120     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
12121     if (!(retsts & 1)) {
12122       SETERRNO(EVMSERR, retsts);
12123       return -1;
12124     }
12125   }
12126   else {
12127     /* Just get the current time in VMS format directly */
12128     retsts = sys$gettim(bintime);
12129     if (!(retsts & 1)) {
12130       SETERRNO(EVMSERR, retsts);
12131       return -1;
12132     }
12133   }
12134
12135   myfab.fab$l_fna = vmsspec;
12136   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
12137   myfab.fab$l_nam = &mynam;
12138   mynam.nam$l_esa = esa;
12139   mynam.nam$b_ess = (unsigned char) sizeof esa;
12140   mynam.nam$l_rsa = rsa;
12141   mynam.nam$b_rss = (unsigned char) sizeof rsa;
12142   if (decc_efs_case_preserve)
12143       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
12144
12145   /* Look for the file to be affected, letting RMS parse the file
12146    * specification for us as well.  I have set errno using only
12147    * values documented in the utime() man page for VMS POSIX.
12148    */
12149   retsts = sys$parse(&myfab,0,0);
12150   if (!(retsts & 1)) {
12151     set_vaxc_errno(retsts);
12152     if      (retsts == RMS$_PRV) set_errno(EACCES);
12153     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
12154     else                         set_errno(EVMSERR);
12155     return -1;
12156   }
12157   retsts = sys$search(&myfab,0,0);
12158   if (!(retsts & 1)) {
12159     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12160     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12161     set_vaxc_errno(retsts);
12162     if      (retsts == RMS$_PRV) set_errno(EACCES);
12163     else if (retsts == RMS$_FNF) set_errno(ENOENT);
12164     else                         set_errno(EVMSERR);
12165     return -1;
12166   }
12167
12168   devdsc.dsc$w_length = mynam.nam$b_dev;
12169   /* cast ok for read only parameter */
12170   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
12171
12172   retsts = sys$assign(&devdsc,&chan,0,0);
12173   if (!(retsts & 1)) {
12174     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12175     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12176     set_vaxc_errno(retsts);
12177     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
12178     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
12179     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
12180     else                               set_errno(EVMSERR);
12181     return -1;
12182   }
12183
12184   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
12185   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
12186
12187   memset((void *) &myfib, 0, sizeof myfib);
12188 #if defined(__DECC) || defined(__DECCXX)
12189   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
12190   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
12191   /* This prevents the revision time of the file being reset to the current
12192    * time as a result of our IO$_MODIFY $QIO. */
12193   myfib.fib$l_acctl = FIB$M_NORECORD;
12194 #else
12195   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
12196   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
12197   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
12198 #endif
12199   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
12200   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12201   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12202   _ckvmssts(sys$dassgn(chan));
12203   if (retsts & 1) retsts = iosb[0];
12204   if (!(retsts & 1)) {
12205     set_vaxc_errno(retsts);
12206     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12207     else                      set_errno(EVMSERR);
12208     return -1;
12209   }
12210
12211   return 0;
12212
12213 #endif /* #if __CRTL_VER >= 70300000 */
12214
12215 }  /* end of my_utime() */
12216 /*}}}*/
12217
12218 /*
12219  * flex_stat, flex_lstat, flex_fstat
12220  * basic stat, but gets it right when asked to stat
12221  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
12222  */
12223
12224 #ifndef _USE_STD_STAT
12225 /* encode_dev packs a VMS device name string into an integer to allow
12226  * simple comparisons. This can be used, for example, to check whether two
12227  * files are located on the same device, by comparing their encoded device
12228  * names. Even a string comparison would not do, because stat() reuses the
12229  * device name buffer for each call; so without encode_dev, it would be
12230  * necessary to save the buffer and use strcmp (this would mean a number of
12231  * changes to the standard Perl code, to say nothing of what a Perl script
12232  * would have to do.
12233  *
12234  * The device lock id, if it exists, should be unique (unless perhaps compared
12235  * with lock ids transferred from other nodes). We have a lock id if the disk is
12236  * mounted cluster-wide, which is when we tend to get long (host-qualified)
12237  * device names. Thus we use the lock id in preference, and only if that isn't
12238  * available, do we try to pack the device name into an integer (flagged by
12239  * the sign bit (LOCKID_MASK) being set).
12240  *
12241  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
12242  * name and its encoded form, but it seems very unlikely that we will find
12243  * two files on different disks that share the same encoded device names,
12244  * and even more remote that they will share the same file id (if the test
12245  * is to check for the same file).
12246  *
12247  * A better method might be to use sys$device_scan on the first call, and to
12248  * search for the device, returning an index into the cached array.
12249  * The number returned would be more intelligible.
12250  * This is probably not worth it, and anyway would take quite a bit longer
12251  * on the first call.
12252  */
12253 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
12254 static mydev_t encode_dev (pTHX_ const char *dev)
12255 {
12256   int i;
12257   unsigned long int f;
12258   mydev_t enc;
12259   char c;
12260   const char *q;
12261
12262   if (!dev || !dev[0]) return 0;
12263
12264 #if LOCKID_MASK
12265   {
12266     struct dsc$descriptor_s dev_desc;
12267     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
12268
12269     /* For cluster-mounted disks, the disk lock identifier is unique, so we
12270        can try that first. */
12271     dev_desc.dsc$w_length =  strlen (dev);
12272     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
12273     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
12274     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
12275     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
12276     if (!$VMS_STATUS_SUCCESS(status)) {
12277       switch (status) {
12278         case SS$_NOSUCHDEV:
12279           SETERRNO(ENODEV, status);
12280           return 0;
12281         default:
12282           _ckvmssts(status);
12283       }
12284     }
12285     if (lockid) return (lockid & ~LOCKID_MASK);
12286   }
12287 #endif
12288
12289   /* Otherwise we try to encode the device name */
12290   enc = 0;
12291   f = 1;
12292   i = 0;
12293   for (q = dev + strlen(dev); q--; q >= dev) {
12294     if (*q == ':')
12295         break;
12296     if (isdigit (*q))
12297       c= (*q) - '0';
12298     else if (isalpha (toupper (*q)))
12299       c= toupper (*q) - 'A' + (char)10;
12300     else
12301       continue; /* Skip '$'s */
12302     i++;
12303     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
12304     if (i>1) f *= 36;
12305     enc += f * (unsigned long int) c;
12306   }
12307   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
12308
12309 }  /* end of encode_dev() */
12310 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12311         device_no = encode_dev(aTHX_ devname)
12312 #else
12313 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12314         device_no = new_dev_no
12315 #endif
12316
12317 static int
12318 is_null_device(name)
12319     const char *name;
12320 {
12321   if (decc_bug_devnull != 0) {
12322     if (strncmp("/dev/null", name, 9) == 0)
12323       return 1;
12324   }
12325     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
12326        The underscore prefix, controller letter, and unit number are
12327        independently optional; for our purposes, the colon punctuation
12328        is not.  The colon can be trailed by optional directory and/or
12329        filename, but two consecutive colons indicates a nodename rather
12330        than a device.  [pr]  */
12331   if (*name == '_') ++name;
12332   if (tolower(*name++) != 'n') return 0;
12333   if (tolower(*name++) != 'l') return 0;
12334   if (tolower(*name) == 'a') ++name;
12335   if (*name == '0') ++name;
12336   return (*name++ == ':') && (*name != ':');
12337 }
12338
12339
12340 static I32
12341 Perl_cando_by_name_int
12342    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
12343 {
12344   char usrname[L_cuserid];
12345   struct dsc$descriptor_s usrdsc =
12346          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
12347   char *vmsname = NULL, *fileified = NULL;
12348   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
12349   unsigned short int retlen, trnlnm_iter_count;
12350   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12351   union prvdef curprv;
12352   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
12353          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
12354          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
12355   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
12356          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
12357          {0,0,0,0}};
12358   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
12359          {0,0,0,0}};
12360   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12361   Stat_t st;
12362   static int profile_context = -1;
12363
12364   if (!fname || !*fname) return FALSE;
12365
12366   /* Make sure we expand logical names, since sys$check_access doesn't */
12367   fileified = PerlMem_malloc(VMS_MAXRSS);
12368   if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12369   if (!strpbrk(fname,"/]>:")) {
12370       strcpy(fileified,fname);
12371       trnlnm_iter_count = 0;
12372       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
12373         trnlnm_iter_count++;
12374         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
12375       }
12376       fname = fileified;
12377   }
12378
12379   vmsname = PerlMem_malloc(VMS_MAXRSS);
12380   if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12381   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
12382     /* Don't know if already in VMS format, so make sure */
12383     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
12384       PerlMem_free(fileified);
12385       PerlMem_free(vmsname);
12386       return FALSE;
12387     }
12388   }
12389   else {
12390     strcpy(vmsname,fname);
12391   }
12392
12393   /* sys$check_access needs a file spec, not a directory spec.
12394    * Don't use flex_stat here, as that depends on thread context
12395    * having been initialized, and we may get here during startup.
12396    */
12397
12398   retlen = namdsc.dsc$w_length = strlen(vmsname);
12399   if (vmsname[retlen-1] == ']'
12400       || vmsname[retlen-1] == '>'
12401       || vmsname[retlen-1] == ':'
12402       || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
12403
12404       if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) {
12405         PerlMem_free(fileified);
12406         PerlMem_free(vmsname);
12407         return FALSE;
12408       }
12409       fname = fileified;
12410   }
12411   else {
12412       fname = vmsname;
12413   }
12414
12415   retlen = namdsc.dsc$w_length = strlen(fname);
12416   namdsc.dsc$a_pointer = (char *)fname;
12417
12418   switch (bit) {
12419     case S_IXUSR: case S_IXGRP: case S_IXOTH:
12420       access = ARM$M_EXECUTE;
12421       flags = CHP$M_READ;
12422       break;
12423     case S_IRUSR: case S_IRGRP: case S_IROTH:
12424       access = ARM$M_READ;
12425       flags = CHP$M_READ | CHP$M_USEREADALL;
12426       break;
12427     case S_IWUSR: case S_IWGRP: case S_IWOTH:
12428       access = ARM$M_WRITE;
12429       flags = CHP$M_READ | CHP$M_WRITE;
12430       break;
12431     case S_IDUSR: case S_IDGRP: case S_IDOTH:
12432       access = ARM$M_DELETE;
12433       flags = CHP$M_READ | CHP$M_WRITE;
12434       break;
12435     default:
12436       if (fileified != NULL)
12437         PerlMem_free(fileified);
12438       if (vmsname != NULL)
12439         PerlMem_free(vmsname);
12440       return FALSE;
12441   }
12442
12443   /* Before we call $check_access, create a user profile with the current
12444    * process privs since otherwise it just uses the default privs from the
12445    * UAF and might give false positives or negatives.  This only works on
12446    * VMS versions v6.0 and later since that's when sys$create_user_profile
12447    * became available.
12448    */
12449
12450   /* get current process privs and username */
12451   _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
12452   _ckvmssts_noperl(iosb[0]);
12453
12454 #if defined(__VMS_VER) && __VMS_VER >= 60000000
12455
12456   /* find out the space required for the profile */
12457   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
12458                                     &usrprodsc.dsc$w_length,&profile_context));
12459
12460   /* allocate space for the profile and get it filled in */
12461   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
12462   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12463   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
12464                                     &usrprodsc.dsc$w_length,&profile_context));
12465
12466   /* use the profile to check access to the file; free profile & analyze results */
12467   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
12468   PerlMem_free(usrprodsc.dsc$a_pointer);
12469   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
12470
12471 #else
12472
12473   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
12474
12475 #endif
12476
12477   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
12478       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
12479       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
12480     set_vaxc_errno(retsts);
12481     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12482     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12483     else set_errno(ENOENT);
12484     if (fileified != NULL)
12485       PerlMem_free(fileified);
12486     if (vmsname != NULL)
12487       PerlMem_free(vmsname);
12488     return FALSE;
12489   }
12490   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12491     if (fileified != NULL)
12492       PerlMem_free(fileified);
12493     if (vmsname != NULL)
12494       PerlMem_free(vmsname);
12495     return TRUE;
12496   }
12497   _ckvmssts_noperl(retsts);
12498
12499   if (fileified != NULL)
12500     PerlMem_free(fileified);
12501   if (vmsname != NULL)
12502     PerlMem_free(vmsname);
12503   return FALSE;  /* Should never get here */
12504
12505 }
12506
12507 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
12508 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12509  * subset of the applicable information.
12510  */
12511 bool
12512 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12513 {
12514   return cando_by_name_int
12515         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12516 }  /* end of cando() */
12517 /*}}}*/
12518
12519
12520 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12521 I32
12522 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12523 {
12524    return cando_by_name_int(bit, effective, fname, 0);
12525
12526 }  /* end of cando_by_name() */
12527 /*}}}*/
12528
12529
12530 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12531 int
12532 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12533 {
12534   if (!fstat(fd,(stat_t *) statbufp)) {
12535     char *cptr;
12536     char *vms_filename;
12537     vms_filename = PerlMem_malloc(VMS_MAXRSS);
12538     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12539
12540     /* Save name for cando by name in VMS format */
12541     cptr = getname(fd, vms_filename, 1);
12542
12543     /* This should not happen, but just in case */
12544     if (cptr == NULL) {
12545         statbufp->st_devnam[0] = 0;
12546     }
12547     else {
12548         /* Make sure that the saved name fits in 255 characters */
12549         cptr = int_rmsexpand_vms
12550                        (vms_filename,
12551                         statbufp->st_devnam,
12552                         0);
12553         if (cptr == NULL)
12554             statbufp->st_devnam[0] = 0;
12555     }
12556     PerlMem_free(vms_filename);
12557
12558     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12559     VMS_DEVICE_ENCODE
12560         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12561
12562 #   ifdef RTL_USES_UTC
12563 #   ifdef VMSISH_TIME
12564     if (VMSISH_TIME) {
12565       statbufp->st_mtime = _toloc(statbufp->st_mtime);
12566       statbufp->st_atime = _toloc(statbufp->st_atime);
12567       statbufp->st_ctime = _toloc(statbufp->st_ctime);
12568     }
12569 #   endif
12570 #   else
12571 #   ifdef VMSISH_TIME
12572     if (!VMSISH_TIME) { /* Return UTC instead of local time */
12573 #   else
12574     if (1) {
12575 #   endif
12576       statbufp->st_mtime = _toutc(statbufp->st_mtime);
12577       statbufp->st_atime = _toutc(statbufp->st_atime);
12578       statbufp->st_ctime = _toutc(statbufp->st_ctime);
12579     }
12580 #endif
12581     return 0;
12582   }
12583   return -1;
12584
12585 }  /* end of flex_fstat() */
12586 /*}}}*/
12587
12588 #if !defined(__VAX) && __CRTL_VER >= 80200000
12589 #ifdef lstat
12590 #undef lstat
12591 #endif
12592 #else
12593 #ifdef lstat
12594 #undef lstat
12595 #endif
12596 #define lstat(_x, _y) stat(_x, _y)
12597 #endif
12598
12599 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
12600
12601 static int
12602 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12603 {
12604     char fileified[VMS_MAXRSS];
12605     char temp_fspec[VMS_MAXRSS];
12606     char *save_spec;
12607     int retval = -1;
12608     dSAVEDERRNO;
12609
12610     if (!fspec) return retval;
12611     SAVE_ERRNO;
12612     strcpy(temp_fspec, fspec);
12613
12614     if (decc_bug_devnull != 0) {
12615       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
12616         memset(statbufp,0,sizeof *statbufp);
12617         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12618         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12619         statbufp->st_uid = 0x00010001;
12620         statbufp->st_gid = 0x0001;
12621         time((time_t *)&statbufp->st_mtime);
12622         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12623         return 0;
12624       }
12625     }
12626
12627     /* Try for a directory name first.  If fspec contains a filename without
12628      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12629      * and sea:[wine.dark]water. exist, we prefer the directory here.
12630      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12631      * not sea:[wine.dark]., if the latter exists.  If the intended target is
12632      * the file with null type, specify this by calling flex_stat() with
12633      * a '.' at the end of fspec.
12634      *
12635      * If we are in Posix filespec mode, accept the filename as is.
12636      */
12637
12638
12639 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12640   /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
12641    * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
12642    */
12643   if (!decc_efs_charset)
12644     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
12645 #endif
12646
12647 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12648   if (decc_posix_compliant_pathnames == 0) {
12649 #endif
12650     if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
12651       if (lstat_flag == 0)
12652         retval = stat(fileified,(stat_t *) statbufp);
12653       else
12654         retval = lstat(fileified,(stat_t *) statbufp);
12655       save_spec = fileified;
12656     }
12657     if (retval) {
12658       if (lstat_flag == 0)
12659         retval = stat(temp_fspec,(stat_t *) statbufp);
12660       else
12661         retval = lstat(temp_fspec,(stat_t *) statbufp);
12662       save_spec = temp_fspec;
12663     }
12664 /*
12665  * In debugging, on 8.3 Alpha, I found a case where stat was returning a
12666  * file not found error for a directory named foo:[bar.t] or /foo/bar/t
12667  * and lstat was working correctly for the same file.
12668  * The only syntax that was working for stat was "foo:[bar]t.dir".
12669  *
12670  * Other directories with the same syntax worked fine.
12671  * So work around the problem when it shows up here.
12672  */
12673     if (retval) {
12674         int save_errno = errno;
12675         if (do_tovmsspec(fspec, temp_fspec, 0, NULL) != NULL) {
12676             if (do_fileify_dirspec(temp_fspec, fileified, 0, NULL) != NULL) {
12677                 retval = stat(fileified, (stat_t *) statbufp);
12678                 save_spec = fileified;
12679             }
12680         }
12681         /* Restore the errno value if third stat does not succeed */
12682         if (retval != 0)
12683             errno = save_errno;
12684     }
12685 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12686   } else {
12687     if (lstat_flag == 0)
12688       retval = stat(temp_fspec,(stat_t *) statbufp);
12689     else
12690       retval = lstat(temp_fspec,(stat_t *) statbufp);
12691       save_spec = temp_fspec;
12692   }
12693 #endif
12694
12695 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12696   /* As you were... */
12697   if (!decc_efs_charset)
12698     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12699 #endif
12700
12701     if (!retval) {
12702     char * cptr;
12703     int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12704
12705       /* If this is an lstat, do not follow the link */
12706       if (lstat_flag)
12707         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12708
12709       cptr = int_rmsexpand_tovms(save_spec, statbufp->st_devnam, rmsex_flags);
12710       if (cptr == NULL)
12711         statbufp->st_devnam[0] = 0;
12712
12713       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12714       VMS_DEVICE_ENCODE
12715         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12716 #     ifdef RTL_USES_UTC
12717 #     ifdef VMSISH_TIME
12718       if (VMSISH_TIME) {
12719         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12720         statbufp->st_atime = _toloc(statbufp->st_atime);
12721         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12722       }
12723 #     endif
12724 #     else
12725 #     ifdef VMSISH_TIME
12726       if (!VMSISH_TIME) { /* Return UTC instead of local time */
12727 #     else
12728       if (1) {
12729 #     endif
12730         statbufp->st_mtime = _toutc(statbufp->st_mtime);
12731         statbufp->st_atime = _toutc(statbufp->st_atime);
12732         statbufp->st_ctime = _toutc(statbufp->st_ctime);
12733       }
12734 #     endif
12735     }
12736     /* If we were successful, leave errno where we found it */
12737     if (retval == 0) RESTORE_ERRNO;
12738     return retval;
12739
12740 }  /* end of flex_stat_int() */
12741
12742
12743 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12744 int
12745 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12746 {
12747    return flex_stat_int(fspec, statbufp, 0);
12748 }
12749 /*}}}*/
12750
12751 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12752 int
12753 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12754 {
12755    return flex_stat_int(fspec, statbufp, 1);
12756 }
12757 /*}}}*/
12758
12759
12760 /*{{{char *my_getlogin()*/
12761 /* VMS cuserid == Unix getlogin, except calling sequence */
12762 char *
12763 my_getlogin(void)
12764 {
12765     static char user[L_cuserid];
12766     return cuserid(user);
12767 }
12768 /*}}}*/
12769
12770
12771 /*  rmscopy - copy a file using VMS RMS routines
12772  *
12773  *  Copies contents and attributes of spec_in to spec_out, except owner
12774  *  and protection information.  Name and type of spec_in are used as
12775  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
12776  *  should try to propagate timestamps from the input file to the output file.
12777  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
12778  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
12779  *  propagated to the output file at creation iff the output file specification
12780  *  did not contain an explicit name or type, and the revision date is always
12781  *  updated at the end of the copy operation.  If it is greater than 0, then
12782  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12783  *  other than the revision date should be propagated, and bit 1 indicates
12784  *  that the revision date should be propagated.
12785  *
12786  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12787  *
12788  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12789  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
12790  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
12791  * as part of the Perl standard distribution under the terms of the
12792  * GNU General Public License or the Perl Artistic License.  Copies
12793  * of each may be found in the Perl standard distribution.
12794  */ /* FIXME */
12795 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12796 int
12797 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12798 {
12799     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12800          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12801     unsigned long int i, sts, sts2;
12802     int dna_len;
12803     struct FAB fab_in, fab_out;
12804     struct RAB rab_in, rab_out;
12805     rms_setup_nam(nam);
12806     rms_setup_nam(nam_out);
12807     struct XABDAT xabdat;
12808     struct XABFHC xabfhc;
12809     struct XABRDT xabrdt;
12810     struct XABSUM xabsum;
12811
12812     vmsin = PerlMem_malloc(VMS_MAXRSS);
12813     if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12814     vmsout = PerlMem_malloc(VMS_MAXRSS);
12815     if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12816     if (!spec_in  || !*spec_in  || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
12817         !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
12818       PerlMem_free(vmsin);
12819       PerlMem_free(vmsout);
12820       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12821       return 0;
12822     }
12823
12824     esa = PerlMem_malloc(VMS_MAXRSS);
12825     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12826     esal = NULL;
12827 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12828     esal = PerlMem_malloc(VMS_MAXRSS);
12829     if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12830 #endif
12831     fab_in = cc$rms_fab;
12832     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12833     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12834     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12835     fab_in.fab$l_fop = FAB$M_SQO;
12836     rms_bind_fab_nam(fab_in, nam);
12837     fab_in.fab$l_xab = (void *) &xabdat;
12838
12839     rsa = PerlMem_malloc(VMS_MAXRSS);
12840     if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12841     rsal = NULL;
12842 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12843     rsal = PerlMem_malloc(VMS_MAXRSS);
12844     if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12845 #endif
12846     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12847     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12848     rms_nam_esl(nam) = 0;
12849     rms_nam_rsl(nam) = 0;
12850     rms_nam_esll(nam) = 0;
12851     rms_nam_rsll(nam) = 0;
12852 #ifdef NAM$M_NO_SHORT_UPCASE
12853     if (decc_efs_case_preserve)
12854         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12855 #endif
12856
12857     xabdat = cc$rms_xabdat;        /* To get creation date */
12858     xabdat.xab$l_nxt = (void *) &xabfhc;
12859
12860     xabfhc = cc$rms_xabfhc;        /* To get record length */
12861     xabfhc.xab$l_nxt = (void *) &xabsum;
12862
12863     xabsum = cc$rms_xabsum;        /* To get key and area information */
12864
12865     if (!((sts = sys$open(&fab_in)) & 1)) {
12866       PerlMem_free(vmsin);
12867       PerlMem_free(vmsout);
12868       PerlMem_free(esa);
12869       if (esal != NULL)
12870         PerlMem_free(esal);
12871       PerlMem_free(rsa);
12872       if (rsal != NULL)
12873         PerlMem_free(rsal);
12874       set_vaxc_errno(sts);
12875       switch (sts) {
12876         case RMS$_FNF: case RMS$_DNF:
12877           set_errno(ENOENT); break;
12878         case RMS$_DIR:
12879           set_errno(ENOTDIR); break;
12880         case RMS$_DEV:
12881           set_errno(ENODEV); break;
12882         case RMS$_SYN:
12883           set_errno(EINVAL); break;
12884         case RMS$_PRV:
12885           set_errno(EACCES); break;
12886         default:
12887           set_errno(EVMSERR);
12888       }
12889       return 0;
12890     }
12891
12892     nam_out = nam;
12893     fab_out = fab_in;
12894     fab_out.fab$w_ifi = 0;
12895     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12896     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12897     fab_out.fab$l_fop = FAB$M_SQO;
12898     rms_bind_fab_nam(fab_out, nam_out);
12899     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12900     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12901     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12902     esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12903     if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12904     rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12905     if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12906     esal_out = NULL;
12907     rsal_out = NULL;
12908 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12909     esal_out = PerlMem_malloc(VMS_MAXRSS);
12910     if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12911     rsal_out = PerlMem_malloc(VMS_MAXRSS);
12912     if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12913 #endif
12914     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12915     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12916
12917     if (preserve_dates == 0) {  /* Act like DCL COPY */
12918       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12919       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
12920       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12921         PerlMem_free(vmsin);
12922         PerlMem_free(vmsout);
12923         PerlMem_free(esa);
12924         if (esal != NULL)
12925             PerlMem_free(esal);
12926         PerlMem_free(rsa);
12927         if (rsal != NULL)
12928             PerlMem_free(rsal);
12929         PerlMem_free(esa_out);
12930         if (esal_out != NULL)
12931             PerlMem_free(esal_out);
12932         PerlMem_free(rsa_out);
12933         if (rsal_out != NULL)
12934             PerlMem_free(rsal_out);
12935         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12936         set_vaxc_errno(sts);
12937         return 0;
12938       }
12939       fab_out.fab$l_xab = (void *) &xabdat;
12940       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12941         preserve_dates = 1;
12942     }
12943     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
12944       preserve_dates =0;      /* bitmask from this point forward   */
12945
12946     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12947     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12948       PerlMem_free(vmsin);
12949       PerlMem_free(vmsout);
12950       PerlMem_free(esa);
12951       if (esal != NULL)
12952           PerlMem_free(esal);
12953       PerlMem_free(rsa);
12954       if (rsal != NULL)
12955           PerlMem_free(rsal);
12956       PerlMem_free(esa_out);
12957       if (esal_out != NULL)
12958           PerlMem_free(esal_out);
12959       PerlMem_free(rsa_out);
12960       if (rsal_out != NULL)
12961           PerlMem_free(rsal_out);
12962       set_vaxc_errno(sts);
12963       switch (sts) {
12964         case RMS$_DNF:
12965           set_errno(ENOENT); break;
12966         case RMS$_DIR:
12967           set_errno(ENOTDIR); break;
12968         case RMS$_DEV:
12969           set_errno(ENODEV); break;
12970         case RMS$_SYN:
12971           set_errno(EINVAL); break;
12972         case RMS$_PRV:
12973           set_errno(EACCES); break;
12974         default:
12975           set_errno(EVMSERR);
12976       }
12977       return 0;
12978     }
12979     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
12980     if (preserve_dates & 2) {
12981       /* sys$close() will process xabrdt, not xabdat */
12982       xabrdt = cc$rms_xabrdt;
12983 #ifndef __GNUC__
12984       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12985 #else
12986       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12987        * is unsigned long[2], while DECC & VAXC use a struct */
12988       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12989 #endif
12990       fab_out.fab$l_xab = (void *) &xabrdt;
12991     }
12992
12993     ubf = PerlMem_malloc(32256);
12994     if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12995     rab_in = cc$rms_rab;
12996     rab_in.rab$l_fab = &fab_in;
12997     rab_in.rab$l_rop = RAB$M_BIO;
12998     rab_in.rab$l_ubf = ubf;
12999     rab_in.rab$w_usz = 32256;
13000     if (!((sts = sys$connect(&rab_in)) & 1)) {
13001       sys$close(&fab_in); sys$close(&fab_out);
13002       PerlMem_free(vmsin);
13003       PerlMem_free(vmsout);
13004       PerlMem_free(ubf);
13005       PerlMem_free(esa);
13006       if (esal != NULL)
13007           PerlMem_free(esal);
13008       PerlMem_free(rsa);
13009       if (rsal != NULL)
13010           PerlMem_free(rsal);
13011       PerlMem_free(esa_out);
13012       if (esal_out != NULL)
13013           PerlMem_free(esal_out);
13014       PerlMem_free(rsa_out);
13015       if (rsal_out != NULL)
13016           PerlMem_free(rsal_out);
13017       set_errno(EVMSERR); set_vaxc_errno(sts);
13018       return 0;
13019     }
13020
13021     rab_out = cc$rms_rab;
13022     rab_out.rab$l_fab = &fab_out;
13023     rab_out.rab$l_rbf = ubf;
13024     if (!((sts = sys$connect(&rab_out)) & 1)) {
13025       sys$close(&fab_in); sys$close(&fab_out);
13026       PerlMem_free(vmsin);
13027       PerlMem_free(vmsout);
13028       PerlMem_free(ubf);
13029       PerlMem_free(esa);
13030       if (esal != NULL)
13031           PerlMem_free(esal);
13032       PerlMem_free(rsa);
13033       if (rsal != NULL)
13034           PerlMem_free(rsal);
13035       PerlMem_free(esa_out);
13036       if (esal_out != NULL)
13037           PerlMem_free(esal_out);
13038       PerlMem_free(rsa_out);
13039       if (rsal_out != NULL)
13040           PerlMem_free(rsal_out);
13041       set_errno(EVMSERR); set_vaxc_errno(sts);
13042       return 0;
13043     }
13044
13045     while ((sts = sys$read(&rab_in))) {  /* always true  */
13046       if (sts == RMS$_EOF) break;
13047       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
13048       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
13049         sys$close(&fab_in); sys$close(&fab_out);
13050         PerlMem_free(vmsin);
13051         PerlMem_free(vmsout);
13052         PerlMem_free(ubf);
13053         PerlMem_free(esa);
13054         if (esal != NULL)
13055             PerlMem_free(esal);
13056         PerlMem_free(rsa);
13057         if (rsal != NULL)
13058             PerlMem_free(rsal);
13059         PerlMem_free(esa_out);
13060         if (esal_out != NULL)
13061             PerlMem_free(esal_out);
13062         PerlMem_free(rsa_out);
13063         if (rsal_out != NULL)
13064             PerlMem_free(rsal_out);
13065         set_errno(EVMSERR); set_vaxc_errno(sts);
13066         return 0;
13067       }
13068     }
13069
13070
13071     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
13072     sys$close(&fab_in);  sys$close(&fab_out);
13073     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
13074
13075     PerlMem_free(vmsin);
13076     PerlMem_free(vmsout);
13077     PerlMem_free(ubf);
13078     PerlMem_free(esa);
13079     if (esal != NULL)
13080         PerlMem_free(esal);
13081     PerlMem_free(rsa);
13082     if (rsal != NULL)
13083         PerlMem_free(rsal);
13084     PerlMem_free(esa_out);
13085     if (esal_out != NULL)
13086         PerlMem_free(esal_out);
13087     PerlMem_free(rsa_out);
13088     if (rsal_out != NULL)
13089         PerlMem_free(rsal_out);
13090
13091     if (!(sts & 1)) {
13092       set_errno(EVMSERR); set_vaxc_errno(sts);
13093       return 0;
13094     }
13095
13096     return 1;
13097
13098 }  /* end of rmscopy() */
13099 /*}}}*/
13100
13101
13102 /***  The following glue provides 'hooks' to make some of the routines
13103  * from this file available from Perl.  These routines are sufficiently
13104  * basic, and are required sufficiently early in the build process,
13105  * that's it's nice to have them available to miniperl as well as the
13106  * full Perl, so they're set up here instead of in an extension.  The
13107  * Perl code which handles importation of these names into a given
13108  * package lives in [.VMS]Filespec.pm in @INC.
13109  */
13110
13111 void
13112 rmsexpand_fromperl(pTHX_ CV *cv)
13113 {
13114   dXSARGS;
13115   char *fspec, *defspec = NULL, *rslt;
13116   STRLEN n_a;
13117   int fs_utf8, dfs_utf8;
13118
13119   fs_utf8 = 0;
13120   dfs_utf8 = 0;
13121   if (!items || items > 2)
13122     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
13123   fspec = SvPV(ST(0),n_a);
13124   fs_utf8 = SvUTF8(ST(0));
13125   if (!fspec || !*fspec) XSRETURN_UNDEF;
13126   if (items == 2) {
13127     defspec = SvPV(ST(1),n_a);
13128     dfs_utf8 = SvUTF8(ST(1));
13129   }
13130   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
13131   ST(0) = sv_newmortal();
13132   if (rslt != NULL) {
13133     sv_usepvn(ST(0),rslt,strlen(rslt));
13134     if (fs_utf8) {
13135         SvUTF8_on(ST(0));
13136     }
13137   }
13138   XSRETURN(1);
13139 }
13140
13141 void
13142 vmsify_fromperl(pTHX_ CV *cv)
13143 {
13144   dXSARGS;
13145   char *vmsified;
13146   STRLEN n_a;
13147   int utf8_fl;
13148
13149   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
13150   utf8_fl = SvUTF8(ST(0));
13151   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13152   ST(0) = sv_newmortal();
13153   if (vmsified != NULL) {
13154     sv_usepvn(ST(0),vmsified,strlen(vmsified));
13155     if (utf8_fl) {
13156         SvUTF8_on(ST(0));
13157     }
13158   }
13159   XSRETURN(1);
13160 }
13161
13162 void
13163 unixify_fromperl(pTHX_ CV *cv)
13164 {
13165   dXSARGS;
13166   char *unixified;
13167   STRLEN n_a;
13168   int utf8_fl;
13169
13170   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
13171   utf8_fl = SvUTF8(ST(0));
13172   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13173   ST(0) = sv_newmortal();
13174   if (unixified != NULL) {
13175     sv_usepvn(ST(0),unixified,strlen(unixified));
13176     if (utf8_fl) {
13177         SvUTF8_on(ST(0));
13178     }
13179   }
13180   XSRETURN(1);
13181 }
13182
13183 void
13184 fileify_fromperl(pTHX_ CV *cv)
13185 {
13186   dXSARGS;
13187   char *fileified;
13188   STRLEN n_a;
13189   int utf8_fl;
13190
13191   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
13192   utf8_fl = SvUTF8(ST(0));
13193   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13194   ST(0) = sv_newmortal();
13195   if (fileified != NULL) {
13196     sv_usepvn(ST(0),fileified,strlen(fileified));
13197     if (utf8_fl) {
13198         SvUTF8_on(ST(0));
13199     }
13200   }
13201   XSRETURN(1);
13202 }
13203
13204 void
13205 pathify_fromperl(pTHX_ CV *cv)
13206 {
13207   dXSARGS;
13208   char *pathified;
13209   STRLEN n_a;
13210   int utf8_fl;
13211
13212   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
13213   utf8_fl = SvUTF8(ST(0));
13214   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13215   ST(0) = sv_newmortal();
13216   if (pathified != NULL) {
13217     sv_usepvn(ST(0),pathified,strlen(pathified));
13218     if (utf8_fl) {
13219         SvUTF8_on(ST(0));
13220     }
13221   }
13222   XSRETURN(1);
13223 }
13224
13225 void
13226 vmspath_fromperl(pTHX_ CV *cv)
13227 {
13228   dXSARGS;
13229   char *vmspath;
13230   STRLEN n_a;
13231   int utf8_fl;
13232
13233   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
13234   utf8_fl = SvUTF8(ST(0));
13235   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13236   ST(0) = sv_newmortal();
13237   if (vmspath != NULL) {
13238     sv_usepvn(ST(0),vmspath,strlen(vmspath));
13239     if (utf8_fl) {
13240         SvUTF8_on(ST(0));
13241     }
13242   }
13243   XSRETURN(1);
13244 }
13245
13246 void
13247 unixpath_fromperl(pTHX_ CV *cv)
13248 {
13249   dXSARGS;
13250   char *unixpath;
13251   STRLEN n_a;
13252   int utf8_fl;
13253
13254   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
13255   utf8_fl = SvUTF8(ST(0));
13256   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13257   ST(0) = sv_newmortal();
13258   if (unixpath != NULL) {
13259     sv_usepvn(ST(0),unixpath,strlen(unixpath));
13260     if (utf8_fl) {
13261         SvUTF8_on(ST(0));
13262     }
13263   }
13264   XSRETURN(1);
13265 }
13266
13267 void
13268 candelete_fromperl(pTHX_ CV *cv)
13269 {
13270   dXSARGS;
13271   char *fspec, *fsp;
13272   SV *mysv;
13273   IO *io;
13274   STRLEN n_a;
13275
13276   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
13277
13278   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13279   Newx(fspec, VMS_MAXRSS, char);
13280   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
13281   if (SvTYPE(mysv) == SVt_PVGV) {
13282     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
13283       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13284       ST(0) = &PL_sv_no;
13285       Safefree(fspec);
13286       XSRETURN(1);
13287     }
13288     fsp = fspec;
13289   }
13290   else {
13291     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
13292       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13293       ST(0) = &PL_sv_no;
13294       Safefree(fspec);
13295       XSRETURN(1);
13296     }
13297   }
13298
13299   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
13300   Safefree(fspec);
13301   XSRETURN(1);
13302 }
13303
13304 void
13305 rmscopy_fromperl(pTHX_ CV *cv)
13306 {
13307   dXSARGS;
13308   char *inspec, *outspec, *inp, *outp;
13309   int date_flag;
13310   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
13311                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13312   unsigned long int sts;
13313   SV *mysv;
13314   IO *io;
13315   STRLEN n_a;
13316
13317   if (items < 2 || items > 3)
13318     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
13319
13320   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13321   Newx(inspec, VMS_MAXRSS, char);
13322   if (SvTYPE(mysv) == SVt_PVGV) {
13323     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
13324       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13325       ST(0) = &PL_sv_no;
13326       Safefree(inspec);
13327       XSRETURN(1);
13328     }
13329     inp = inspec;
13330   }
13331   else {
13332     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
13333       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13334       ST(0) = &PL_sv_no;
13335       Safefree(inspec);
13336       XSRETURN(1);
13337     }
13338   }
13339   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
13340   Newx(outspec, VMS_MAXRSS, char);
13341   if (SvTYPE(mysv) == SVt_PVGV) {
13342     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
13343       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13344       ST(0) = &PL_sv_no;
13345       Safefree(inspec);
13346       Safefree(outspec);
13347       XSRETURN(1);
13348     }
13349     outp = outspec;
13350   }
13351   else {
13352     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
13353       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13354       ST(0) = &PL_sv_no;
13355       Safefree(inspec);
13356       Safefree(outspec);
13357       XSRETURN(1);
13358     }
13359   }
13360   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
13361
13362   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
13363   Safefree(inspec);
13364   Safefree(outspec);
13365   XSRETURN(1);
13366 }
13367
13368 /* The mod2fname is limited to shorter filenames by design, so it should
13369  * not be modified to support longer EFS pathnames
13370  */
13371 void
13372 mod2fname(pTHX_ CV *cv)
13373 {
13374   dXSARGS;
13375   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
13376        workbuff[NAM$C_MAXRSS*1 + 1];
13377   int total_namelen = 3, counter, num_entries;
13378   /* ODS-5 ups this, but we want to be consistent, so... */
13379   int max_name_len = 39;
13380   AV *in_array = (AV *)SvRV(ST(0));
13381
13382   num_entries = av_len(in_array);
13383
13384   /* All the names start with PL_. */
13385   strcpy(ultimate_name, "PL_");
13386
13387   /* Clean up our working buffer */
13388   Zero(work_name, sizeof(work_name), char);
13389
13390   /* Run through the entries and build up a working name */
13391   for(counter = 0; counter <= num_entries; counter++) {
13392     /* If it's not the first name then tack on a __ */
13393     if (counter) {
13394       strcat(work_name, "__");
13395     }
13396     strcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)));
13397   }
13398
13399   /* Check to see if we actually have to bother...*/
13400   if (strlen(work_name) + 3 <= max_name_len) {
13401     strcat(ultimate_name, work_name);
13402   } else {
13403     /* It's too darned big, so we need to go strip. We use the same */
13404     /* algorithm as xsubpp does. First, strip out doubled __ */
13405     char *source, *dest, last;
13406     dest = workbuff;
13407     last = 0;
13408     for (source = work_name; *source; source++) {
13409       if (last == *source && last == '_') {
13410         continue;
13411       }
13412       *dest++ = *source;
13413       last = *source;
13414     }
13415     /* Go put it back */
13416     strcpy(work_name, workbuff);
13417     /* Is it still too big? */
13418     if (strlen(work_name) + 3 > max_name_len) {
13419       /* Strip duplicate letters */
13420       last = 0;
13421       dest = workbuff;
13422       for (source = work_name; *source; source++) {
13423         if (last == toupper(*source)) {
13424         continue;
13425         }
13426         *dest++ = *source;
13427         last = toupper(*source);
13428       }
13429       strcpy(work_name, workbuff);
13430     }
13431
13432     /* Is it *still* too big? */
13433     if (strlen(work_name) + 3 > max_name_len) {
13434       /* Too bad, we truncate */
13435       work_name[max_name_len - 2] = 0;
13436     }
13437     strcat(ultimate_name, work_name);
13438   }
13439
13440   /* Okay, return it */
13441   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
13442   XSRETURN(1);
13443 }
13444
13445 void
13446 hushexit_fromperl(pTHX_ CV *cv)
13447 {
13448     dXSARGS;
13449
13450     if (items > 0) {
13451         VMSISH_HUSHED = SvTRUE(ST(0));
13452     }
13453     ST(0) = boolSV(VMSISH_HUSHED);
13454     XSRETURN(1);
13455 }
13456
13457
13458 PerlIO *
13459 Perl_vms_start_glob
13460    (pTHX_ SV *tmpglob,
13461     IO *io)
13462 {
13463     PerlIO *fp;
13464     struct vs_str_st *rslt;
13465     char *vmsspec;
13466     char *rstr;
13467     char *begin, *cp;
13468     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13469     PerlIO *tmpfp;
13470     STRLEN i;
13471     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13472     struct dsc$descriptor_vs rsdsc;
13473     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13474     unsigned long hasver = 0, isunix = 0;
13475     unsigned long int lff_flags = 0;
13476     int rms_sts;
13477     int vms_old_glob = 1;
13478
13479     if (!SvOK(tmpglob)) {
13480         SETERRNO(ENOENT,RMS$_FNF);
13481         return NULL;
13482     }
13483
13484     vms_old_glob = !decc_filename_unix_report;
13485
13486 #ifdef VMS_LONGNAME_SUPPORT
13487     lff_flags = LIB$M_FIL_LONG_NAMES;
13488 #endif
13489     /* The Newx macro will not allow me to assign a smaller array
13490      * to the rslt pointer, so we will assign it to the begin char pointer
13491      * and then copy the value into the rslt pointer.
13492      */
13493     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13494     rslt = (struct vs_str_st *)begin;
13495     rslt->length = 0;
13496     rstr = &rslt->str[0];
13497     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13498     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13499     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13500     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13501
13502     Newx(vmsspec, VMS_MAXRSS, char);
13503
13504         /* We could find out if there's an explicit dev/dir or version
13505            by peeking into lib$find_file's internal context at
13506            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13507            but that's unsupported, so I don't want to do it now and
13508            have it bite someone in the future. */
13509         /* Fix-me: vms_split_path() is the only way to do this, the
13510            existing method will fail with many legal EFS or UNIX specifications
13511          */
13512
13513     cp = SvPV(tmpglob,i);
13514
13515     for (; i; i--) {
13516         if (cp[i] == ';') hasver = 1;
13517         if (cp[i] == '.') {
13518             if (sts) hasver = 1;
13519             else sts = 1;
13520         }
13521         if (cp[i] == '/') {
13522             hasdir = isunix = 1;
13523             break;
13524         }
13525         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13526             hasdir = 1;
13527             break;
13528         }
13529     }
13530
13531     /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13532     if ((hasdir == 0) && decc_filename_unix_report) {
13533         isunix = 1;
13534     }
13535
13536     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13537         char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13538         int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13539         int wildstar = 0;
13540         int wildquery = 0;
13541         int found = 0;
13542         Stat_t st;
13543         int stat_sts;
13544         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13545         if (!stat_sts && S_ISDIR(st.st_mode)) {
13546             char * vms_dir;
13547             const char * fname;
13548             STRLEN fname_len;
13549
13550             /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13551             /* path delimiter of ':>]', if so, then the old behavior has */
13552             /* obviously been specificially requested */
13553
13554             fname = SvPVX_const(tmpglob);
13555             fname_len = strlen(fname);
13556             vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13557             if (vms_old_glob || (vms_dir != NULL)) {
13558                 wilddsc.dsc$a_pointer = tovmspath_utf8(
13559                                             SvPVX(tmpglob),vmsspec,NULL);
13560                 ok = (wilddsc.dsc$a_pointer != NULL);
13561                 /* maybe passed 'foo' rather than '[.foo]', thus not
13562                    detected above */
13563                 hasdir = 1;
13564             } else {
13565                 /* Operate just on the directory, the special stat/fstat for */
13566                 /* leaves the fileified  specification in the st_devnam */
13567                 /* member. */
13568                 wilddsc.dsc$a_pointer = st.st_devnam;
13569                 ok = 1;
13570             }
13571         }
13572         else {
13573             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13574             ok = (wilddsc.dsc$a_pointer != NULL);
13575         }
13576         if (ok)
13577             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13578
13579         /* If not extended character set, replace ? with % */
13580         /* With extended character set, ? is a wildcard single character */
13581         for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13582             if (*cp == '?') {
13583                 wildquery = 1;
13584                 if (!decc_efs_case_preserve)
13585                     *cp = '%';
13586             } else if (*cp == '%') {
13587                 wildquery = 1;
13588             } else if (*cp == '*') {
13589                 wildstar = 1;
13590             }
13591         }
13592
13593         if (ok) {
13594             wv_sts = vms_split_path(
13595                 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13596                 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13597                 &wvs_spec, &wvs_len);
13598         } else {
13599             wn_spec = NULL;
13600             wn_len = 0;
13601             we_spec = NULL;
13602             we_len = 0;
13603         }
13604
13605         sts = SS$_NORMAL;
13606         while (ok && $VMS_STATUS_SUCCESS(sts)) {
13607          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13608          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13609          int valid_find;
13610
13611             valid_find = 0;
13612             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13613                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
13614             if (!$VMS_STATUS_SUCCESS(sts))
13615                 break;
13616
13617             /* with varying string, 1st word of buffer contains result length */
13618             rstr[rslt->length] = '\0';
13619
13620              /* Find where all the components are */
13621              v_sts = vms_split_path
13622                        (rstr,
13623                         &v_spec,
13624                         &v_len,
13625                         &r_spec,
13626                         &r_len,
13627                         &d_spec,
13628                         &d_len,
13629                         &n_spec,
13630                         &n_len,
13631                         &e_spec,
13632                         &e_len,
13633                         &vs_spec,
13634                         &vs_len);
13635
13636             /* If no version on input, truncate the version on output */
13637             if (!hasver && (vs_len > 0)) {
13638                 *vs_spec = '\0';
13639                 vs_len = 0;
13640             }
13641
13642             if (isunix) {
13643
13644                 /* In Unix report mode, remove the ".dir;1" from the name */
13645                 /* if it is a real directory */
13646                 if (decc_filename_unix_report || decc_efs_charset) {
13647                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13648                         Stat_t statbuf;
13649                         int ret_sts;
13650
13651                         ret_sts = flex_lstat(rstr, &statbuf);
13652                         if ((ret_sts == 0) &&
13653                             S_ISDIR(statbuf.st_mode)) {
13654                             e_len = 0;
13655                             e_spec[0] = 0;
13656                         }
13657                     }
13658                 }
13659
13660                 /* No version & a null extension on UNIX handling */
13661                 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13662                     e_len = 0;
13663                     *e_spec = '\0';
13664                 }
13665             }
13666
13667             if (!decc_efs_case_preserve) {
13668                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13669             }
13670
13671             /* Find File treats a Null extension as return all extensions */
13672             /* This is contrary to Perl expectations */
13673
13674             if (wildstar || wildquery || vms_old_glob) {
13675                 /* really need to see if the returned file name matched */
13676                 /* but for now will assume that it matches */
13677                 valid_find = 1;
13678             } else {
13679                 /* Exact Match requested */
13680                 /* How are directories handled? - like a file */
13681                 if ((e_len == we_len) && (n_len == wn_len)) {
13682                     int t1;
13683                     t1 = e_len;
13684                     if (t1 > 0)
13685                         t1 = strncmp(e_spec, we_spec, e_len);
13686                     if (t1 == 0) {
13687                        t1 = n_len;
13688                        if (t1 > 0)
13689                            t1 = strncmp(n_spec, we_spec, n_len);
13690                        if (t1 == 0)
13691                            valid_find = 1;
13692                     }
13693                 }
13694             }
13695
13696             if (valid_find) {
13697                 found++;
13698
13699                 if (hasdir) {
13700                     if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13701                     begin = rstr;
13702                 }
13703                 else {
13704                     /* Start with the name */
13705                     begin = n_spec;
13706                 }
13707                 strcat(begin,"\n");
13708                 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13709             }
13710         }
13711         if (cxt) (void)lib$find_file_end(&cxt);
13712
13713         if (!found) {
13714             /* Be POSIXish: return the input pattern when no matches */
13715             strcpy(rstr,SvPVX(tmpglob));
13716             strcat(rstr,"\n");
13717             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13718         }
13719
13720         if (ok && sts != RMS$_NMF &&
13721             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13722         if (!ok) {
13723             if (!(sts & 1)) {
13724                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13725             }
13726             PerlIO_close(tmpfp);
13727             fp = NULL;
13728         }
13729         else {
13730             PerlIO_rewind(tmpfp);
13731             IoTYPE(io) = IoTYPE_RDONLY;
13732             IoIFP(io) = fp = tmpfp;
13733             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
13734         }
13735     }
13736     Safefree(vmsspec);
13737     Safefree(rslt);
13738     return fp;
13739 }
13740
13741
13742 static char *
13743 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13744                    int *utf8_fl);
13745
13746 void
13747 unixrealpath_fromperl(pTHX_ CV *cv)
13748 {
13749     dXSARGS;
13750     char *fspec, *rslt_spec, *rslt;
13751     STRLEN n_a;
13752
13753     if (!items || items != 1)
13754         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
13755
13756     fspec = SvPV(ST(0),n_a);
13757     if (!fspec || !*fspec) XSRETURN_UNDEF;
13758
13759     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13760     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13761
13762     ST(0) = sv_newmortal();
13763     if (rslt != NULL)
13764         sv_usepvn(ST(0),rslt,strlen(rslt));
13765     else
13766         Safefree(rslt_spec);
13767         XSRETURN(1);
13768 }
13769
13770 static char *
13771 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13772                    int *utf8_fl);
13773
13774 void
13775 vmsrealpath_fromperl(pTHX_ CV *cv)
13776 {
13777     dXSARGS;
13778     char *fspec, *rslt_spec, *rslt;
13779     STRLEN n_a;
13780
13781     if (!items || items != 1)
13782         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
13783
13784     fspec = SvPV(ST(0),n_a);
13785     if (!fspec || !*fspec) XSRETURN_UNDEF;
13786
13787     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13788     rslt = do_vms_realname(fspec, rslt_spec, NULL);
13789
13790     ST(0) = sv_newmortal();
13791     if (rslt != NULL)
13792         sv_usepvn(ST(0),rslt,strlen(rslt));
13793     else
13794         Safefree(rslt_spec);
13795         XSRETURN(1);
13796 }
13797
13798 #ifdef HAS_SYMLINK
13799 /*
13800  * A thin wrapper around decc$symlink to make sure we follow the
13801  * standard and do not create a symlink with a zero-length name.
13802  *
13803  * Also in ODS-2 mode, existing tests assume that the link target
13804  * will be converted to UNIX format.
13805  */
13806 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
13807 int Perl_my_symlink(pTHX_ const char *contents, const char *link_name) {
13808   if (!link_name || !*link_name) {
13809     SETERRNO(ENOENT, SS$_NOSUCHFILE);
13810     return -1;
13811   }
13812
13813   if (decc_efs_charset) {
13814       return symlink(contents, link_name);
13815   } else {
13816       int sts;
13817       char * utarget;
13818
13819       /* Unless we are in ODS-5 mode, convert the symlink target to UNIX */
13820       /* because in order to work, the symlink target must be in UNIX format */
13821
13822       /* As symbolic links can hold things other than files, we will only do */
13823       /* the conversion in in ODS-2 mode */
13824
13825       Newx(utarget, VMS_MAXRSS + 1, char);
13826       if (int_tounixspec(contents, utarget, NULL) == NULL) {
13827
13828           /* This should not fail, as an untranslatable filename */
13829           /* should be passed through */
13830           utarget = (char *)contents;
13831       }
13832       sts = symlink(utarget, link_name);
13833       Safefree(utarget);
13834       return sts;
13835   }
13836
13837 }
13838 /*}}}*/
13839
13840 #endif /* HAS_SYMLINK */
13841
13842 int do_vms_case_tolerant(void);
13843
13844 void
13845 case_tolerant_process_fromperl(pTHX_ CV *cv)
13846 {
13847   dXSARGS;
13848   ST(0) = boolSV(do_vms_case_tolerant());
13849   XSRETURN(1);
13850 }
13851
13852 #ifdef USE_ITHREADS
13853
13854 void
13855 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13856                           struct interp_intern *dst)
13857 {
13858     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13859
13860     memcpy(dst,src,sizeof(struct interp_intern));
13861 }
13862
13863 #endif
13864
13865 void
13866 Perl_sys_intern_clear(pTHX)
13867 {
13868 }
13869
13870 void
13871 Perl_sys_intern_init(pTHX)
13872 {
13873     unsigned int ix = RAND_MAX;
13874     double x;
13875
13876     VMSISH_HUSHED = 0;
13877
13878     MY_POSIX_EXIT = vms_posix_exit;
13879
13880     x = (float)ix;
13881     MY_INV_RAND_MAX = 1./x;
13882 }
13883
13884 void
13885 init_os_extras(void)
13886 {
13887   dTHX;
13888   char* file = __FILE__;
13889   if (decc_disable_to_vms_logname_translation) {
13890     no_translate_barewords = TRUE;
13891   } else {
13892     no_translate_barewords = FALSE;
13893   }
13894
13895   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13896   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13897   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13898   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13899   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13900   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13901   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13902   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13903   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13904   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13905   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13906   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13907   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13908   newXSproto("VMS::Filespec::case_tolerant_process",
13909       case_tolerant_process_fromperl,file,"");
13910
13911   store_pipelocs(aTHX);         /* will redo any earlier attempts */
13912
13913   return;
13914 }
13915
13916 #if __CRTL_VER == 80200000
13917 /* This missed getting in to the DECC SDK for 8.2 */
13918 char *realpath(const char *file_name, char * resolved_name, ...);
13919 #endif
13920
13921 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13922 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13923  * The perl fallback routine to provide realpath() is not as efficient
13924  * on OpenVMS.
13925  */
13926
13927 /* Hack, use old stat() as fastest way of getting ino_t and device */
13928 int decc$stat(const char *name, void * statbuf);
13929
13930
13931 /* Realpath is fragile.  In 8.3 it does not work if the feature
13932  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13933  * links are implemented in RMS, not the CRTL. It also can fail if the
13934  * user does not have read/execute access to some of the directories.
13935  * So in order for Do What I Mean mode to work, if realpath() fails,
13936  * fall back to looking up the filename by the device name and FID.
13937  */
13938
13939 int vms_fid_to_name(char * outname, int outlen, const char * name)
13940 {
13941 struct statbuf_t {
13942     char           * st_dev;
13943     unsigned short st_ino[3];
13944     unsigned short padw;
13945     unsigned long  padl[30];  /* plenty of room */
13946 } statbuf;
13947 int sts;
13948 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13949 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13950
13951     sts = decc$stat(name, &statbuf);
13952     if (sts == 0) {
13953
13954         dvidsc.dsc$a_pointer=statbuf.st_dev;
13955        dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13956
13957         specdsc.dsc$a_pointer = outname;
13958         specdsc.dsc$w_length = outlen-1;
13959
13960        sts = lib$fid_to_name
13961             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13962        if ($VMS_STATUS_SUCCESS(sts)) {
13963             outname[specdsc.dsc$w_length] = 0;
13964             return 0;
13965         }
13966     }
13967     return sts;
13968 }
13969
13970
13971
13972 static char *
13973 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13974                    int *utf8_fl)
13975 {
13976     char * rslt = NULL;
13977
13978 #ifdef HAS_SYMLINK
13979     if (decc_posix_compliant_pathnames > 0 ) {
13980         /* realpath currently only works if posix compliant pathnames are
13981          * enabled.  It may start working when they are not, but in that
13982          * case we still want the fallback behavior for backwards compatibility
13983          */
13984         rslt = realpath(filespec, outbuf);
13985     }
13986 #endif
13987
13988     if (rslt == NULL) {
13989         char * vms_spec;
13990         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13991         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13992         int file_len;
13993
13994         /* Fall back to fid_to_name */
13995
13996         Newx(vms_spec, VMS_MAXRSS + 1, char);
13997
13998         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec);
13999         if (sts == 0) {
14000
14001
14002             /* Now need to trim the version off */
14003             sts = vms_split_path
14004                   (vms_spec,
14005                    &v_spec,
14006                    &v_len,
14007                    &r_spec,
14008                    &r_len,
14009                    &d_spec,
14010                    &d_len,
14011                    &n_spec,
14012                    &n_len,
14013                    &e_spec,
14014                    &e_len,
14015                    &vs_spec,
14016                    &vs_len);
14017
14018
14019                 if (sts == 0) {
14020                     int haslower = 0;
14021                     const char *cp;
14022
14023                     /* Trim off the version */
14024                     int file_len = v_len + r_len + d_len + n_len + e_len;
14025                     vms_spec[file_len] = 0;
14026
14027                     /* The result is expected to be in UNIX format */
14028                     rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
14029
14030                     /* Downcase if input had any lower case letters and
14031                      * case preservation is not in effect.
14032                      */
14033                     if (!decc_efs_case_preserve) {
14034                         for (cp = filespec; *cp; cp++)
14035                             if (islower(*cp)) { haslower = 1; break; }
14036
14037                         if (haslower) __mystrtolower(rslt);
14038                     }
14039                 }
14040         } else {
14041
14042             /* Now for some hacks to deal with backwards and forward */
14043             /* compatibilty */
14044             if (!decc_efs_charset) {
14045
14046                 /* 1. ODS-2 mode wants to do a syntax only translation */
14047                 rslt = int_rmsexpand(filespec, outbuf,
14048                                     NULL, 0, NULL, utf8_fl);
14049
14050             } else {
14051                 if (decc_filename_unix_report) {
14052                     char * dir_name;
14053                     char * vms_dir_name;
14054                     char * file_name;
14055
14056                     /* 2. ODS-5 / UNIX report mode should return a failure */
14057                     /*    if the parent directory also does not exist */
14058                     /*    Otherwise, get the real path for the parent */
14059                     /*    and add the child to it.
14060
14061                     /* basename / dirname only available for VMS 7.0+ */
14062                     /* So we may need to implement them as common routines */
14063
14064                     Newx(dir_name, VMS_MAXRSS + 1, char);
14065                     Newx(vms_dir_name, VMS_MAXRSS + 1, char);
14066                     dir_name[0] = '\0';
14067                     file_name = NULL;
14068
14069                     /* First try a VMS parse */
14070                     sts = vms_split_path
14071                           (filespec,
14072                            &v_spec,
14073                            &v_len,
14074                            &r_spec,
14075                            &r_len,
14076                            &d_spec,
14077                            &d_len,
14078                            &n_spec,
14079                            &n_len,
14080                            &e_spec,
14081                            &e_len,
14082                            &vs_spec,
14083                            &vs_len);
14084
14085                     if (sts == 0) {
14086                         /* This is VMS */
14087
14088                         int dir_len = v_len + r_len + d_len + n_len;
14089                         if (dir_len > 0) {
14090                            strncpy(dir_name, filespec, dir_len);
14091                            dir_name[dir_len] = '\0';
14092                            file_name = (char *)&filespec[dir_len + 1];
14093                         }
14094                     } else {
14095                         /* This must be UNIX */
14096                         char * tchar;
14097
14098                         tchar = strrchr(filespec, '/');
14099
14100                         if (tchar != NULL) {
14101                             int dir_len = tchar - filespec;
14102                             strncpy(dir_name, filespec, dir_len);
14103                             dir_name[dir_len] = '\0';
14104                             file_name = (char *) &filespec[dir_len + 1];
14105                         }
14106                     }
14107
14108                     /* Dir name is defaulted */
14109                     if (dir_name[0] == 0) {
14110                         dir_name[0] = '.';
14111                         dir_name[1] = '\0';
14112                     }
14113
14114                     /* Need realpath for the directory */
14115                     sts = vms_fid_to_name(vms_dir_name,
14116                                           VMS_MAXRSS + 1,
14117                                           dir_name);
14118
14119                     if (sts == 0) {
14120                         /* Now need to pathify it.
14121                         char *tdir = int_pathify_dirspec(vms_dir_name,
14122                                                          outbuf);
14123
14124                         /* And now add the original filespec to it */
14125                         if (file_name != NULL) {
14126                             strcat(outbuf, file_name);
14127                         }
14128                         return outbuf;
14129                     }
14130                     Safefree(vms_dir_name);
14131                     Safefree(dir_name);
14132                 }
14133             }
14134         }
14135         Safefree(vms_spec);
14136     }
14137     return rslt;
14138 }
14139
14140 static char *
14141 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
14142                    int *utf8_fl)
14143 {
14144     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
14145     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
14146     int file_len;
14147
14148     /* Fall back to fid_to_name */
14149
14150     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec);
14151     if (sts != 0) {
14152         return NULL;
14153     }
14154     else {
14155
14156
14157         /* Now need to trim the version off */
14158         sts = vms_split_path
14159                   (outbuf,
14160                    &v_spec,
14161                    &v_len,
14162                    &r_spec,
14163                    &r_len,
14164                    &d_spec,
14165                    &d_len,
14166                    &n_spec,
14167                    &n_len,
14168                    &e_spec,
14169                    &e_len,
14170                    &vs_spec,
14171                    &vs_len);
14172
14173
14174         if (sts == 0) {
14175             int haslower = 0;
14176             const char *cp;
14177
14178             /* Trim off the version */
14179             int file_len = v_len + r_len + d_len + n_len + e_len;
14180             outbuf[file_len] = 0;
14181
14182             /* Downcase if input had any lower case letters and
14183              * case preservation is not in effect.
14184              */
14185             if (!decc_efs_case_preserve) {
14186                 for (cp = filespec; *cp; cp++)
14187                     if (islower(*cp)) { haslower = 1; break; }
14188
14189                 if (haslower) __mystrtolower(outbuf);
14190             }
14191         }
14192     }
14193     return outbuf;
14194 }
14195
14196
14197 /*}}}*/
14198 /* External entry points */
14199 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
14200 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
14201
14202 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
14203 { return do_vms_realname(filespec, outbuf, utf8_fl); }
14204
14205 /* case_tolerant */
14206
14207 /*{{{int do_vms_case_tolerant(void)*/
14208 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
14209  * controlled by a process setting.
14210  */
14211 int do_vms_case_tolerant(void)
14212 {
14213     return vms_process_case_tolerant;
14214 }
14215 /*}}}*/
14216 /* External entry points */
14217 #if __CRTL_VER >= 70301000 && !defined(__VAX)
14218 int Perl_vms_case_tolerant(void)
14219 { return do_vms_case_tolerant(); }
14220 #else
14221 int Perl_vms_case_tolerant(void)
14222 { return vms_process_case_tolerant; }
14223 #endif
14224
14225
14226  /* Start of DECC RTL Feature handling */
14227
14228 static int sys_trnlnm
14229    (const char * logname,
14230     char * value,
14231     int value_len)
14232 {
14233     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
14234     const unsigned long attr = LNM$M_CASE_BLIND;
14235     struct dsc$descriptor_s name_dsc;
14236     int status;
14237     unsigned short result;
14238     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
14239                                 {0, 0, 0, 0}};
14240
14241     name_dsc.dsc$w_length = strlen(logname);
14242     name_dsc.dsc$a_pointer = (char *)logname;
14243     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14244     name_dsc.dsc$b_class = DSC$K_CLASS_S;
14245
14246     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
14247
14248     if ($VMS_STATUS_SUCCESS(status)) {
14249
14250          /* Null terminate and return the string */
14251         /*--------------------------------------*/
14252         value[result] = 0;
14253     }
14254
14255     return status;
14256 }
14257
14258 static int sys_crelnm
14259    (const char * logname,
14260     const char * value)
14261 {
14262     int ret_val;
14263     const char * proc_table = "LNM$PROCESS_TABLE";
14264     struct dsc$descriptor_s proc_table_dsc;
14265     struct dsc$descriptor_s logname_dsc;
14266     struct itmlst_3 item_list[2];
14267
14268     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
14269     proc_table_dsc.dsc$w_length = strlen(proc_table);
14270     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14271     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
14272
14273     logname_dsc.dsc$a_pointer = (char *) logname;
14274     logname_dsc.dsc$w_length = strlen(logname);
14275     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14276     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
14277
14278     item_list[0].buflen = strlen(value);
14279     item_list[0].itmcode = LNM$_STRING;
14280     item_list[0].bufadr = (char *)value;
14281     item_list[0].retlen = NULL;
14282
14283     item_list[1].buflen = 0;
14284     item_list[1].itmcode = 0;
14285
14286     ret_val = sys$crelnm
14287                        (NULL,
14288                         (const struct dsc$descriptor_s *)&proc_table_dsc,
14289                         (const struct dsc$descriptor_s *)&logname_dsc,
14290                         NULL,
14291                         (const struct item_list_3 *) item_list);
14292
14293     return ret_val;
14294 }
14295
14296 /* C RTL Feature settings */
14297
14298 static int set_features
14299    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
14300     int (* cli_routine)(void),  /* Not documented */
14301     void *image_info)           /* Not documented */
14302 {
14303     int status;
14304     int s;
14305     char* str;
14306     char val_str[10];
14307 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
14308     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
14309     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
14310     unsigned long case_perm;
14311     unsigned long case_image;
14312 #endif
14313
14314     /* Allow an exception to bring Perl into the VMS debugger */
14315     vms_debug_on_exception = 0;
14316     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
14317     if ($VMS_STATUS_SUCCESS(status)) {
14318        val_str[0] = _toupper(val_str[0]);
14319        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14320          vms_debug_on_exception = 1;
14321        else
14322          vms_debug_on_exception = 0;
14323     }
14324
14325     /* Debug unix/vms file translation routines */
14326     vms_debug_fileify = 0;
14327     status = sys_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
14328     if ($VMS_STATUS_SUCCESS(status)) {
14329         val_str[0] = _toupper(val_str[0]);
14330         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14331             vms_debug_fileify = 1;
14332         else
14333             vms_debug_fileify = 0;
14334     }
14335
14336
14337     /* Historically PERL has been doing vmsify / stat differently than */
14338     /* the CRTL.  In particular, under some conditions the CRTL will   */
14339     /* remove some illegal characters like spaces from filenames       */
14340     /* resulting in some differences.  The stat()/lstat() wrapper has  */
14341     /* been reporting such file names as invalid and fails to stat them */
14342     /* fixing this bug so that stat()/lstat() accept these like the     */
14343     /* CRTL does will result in several tests failing.                  */
14344     /* This should really be fixed, but for now, set up a feature to    */
14345     /* enable it so that the impact can be studied.                     */
14346     vms_bug_stat_filename = 0;
14347     status = sys_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
14348     if ($VMS_STATUS_SUCCESS(status)) {
14349         val_str[0] = _toupper(val_str[0]);
14350         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14351             vms_bug_stat_filename = 1;
14352         else
14353             vms_bug_stat_filename = 0;
14354     }
14355
14356
14357     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
14358     vms_vtf7_filenames = 0;
14359     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
14360     if ($VMS_STATUS_SUCCESS(status)) {
14361        val_str[0] = _toupper(val_str[0]);
14362        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14363          vms_vtf7_filenames = 1;
14364        else
14365          vms_vtf7_filenames = 0;
14366     }
14367
14368     /* unlink all versions on unlink() or rename() */
14369     vms_unlink_all_versions = 0;
14370     status = sys_trnlnm
14371         ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
14372     if ($VMS_STATUS_SUCCESS(status)) {
14373        val_str[0] = _toupper(val_str[0]);
14374        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14375          vms_unlink_all_versions = 1;
14376        else
14377          vms_unlink_all_versions = 0;
14378     }
14379
14380     /* Dectect running under GNV Bash or other UNIX like shell */
14381 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14382     gnv_unix_shell = 0;
14383     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
14384     if ($VMS_STATUS_SUCCESS(status)) {
14385          gnv_unix_shell = 1;
14386          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
14387          set_feature_default("DECC$EFS_CHARSET", 1);
14388          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
14389          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
14390          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
14391          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
14392          vms_unlink_all_versions = 1;
14393          vms_posix_exit = 1;
14394     }
14395 #endif
14396
14397     /* hacks to see if known bugs are still present for testing */
14398
14399     /* PCP mode requires creating /dev/null special device file */
14400     decc_bug_devnull = 0;
14401     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14402     if ($VMS_STATUS_SUCCESS(status)) {
14403        val_str[0] = _toupper(val_str[0]);
14404        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14405           decc_bug_devnull = 1;
14406        else
14407           decc_bug_devnull = 0;
14408     }
14409
14410     /* UNIX directory names with no paths are broken in a lot of places */
14411     decc_dir_barename = 1;
14412     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
14413     if ($VMS_STATUS_SUCCESS(status)) {
14414       val_str[0] = _toupper(val_str[0]);
14415       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14416         decc_dir_barename = 1;
14417       else
14418         decc_dir_barename = 0;
14419     }
14420
14421 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14422     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14423     if (s >= 0) {
14424         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14425         if (decc_disable_to_vms_logname_translation < 0)
14426             decc_disable_to_vms_logname_translation = 0;
14427     }
14428
14429     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14430     if (s >= 0) {
14431         decc_efs_case_preserve = decc$feature_get_value(s, 1);
14432         if (decc_efs_case_preserve < 0)
14433             decc_efs_case_preserve = 0;
14434     }
14435
14436     s = decc$feature_get_index("DECC$EFS_CHARSET");
14437     decc_efs_charset_index = s;
14438     if (s >= 0) {
14439         decc_efs_charset = decc$feature_get_value(s, 1);
14440         if (decc_efs_charset < 0)
14441             decc_efs_charset = 0;
14442     }
14443
14444     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14445     if (s >= 0) {
14446         decc_filename_unix_report = decc$feature_get_value(s, 1);
14447         if (decc_filename_unix_report > 0) {
14448             decc_filename_unix_report = 1;
14449             vms_posix_exit = 1;
14450         }
14451         else
14452             decc_filename_unix_report = 0;
14453     }
14454
14455     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14456     if (s >= 0) {
14457         decc_filename_unix_only = decc$feature_get_value(s, 1);
14458         if (decc_filename_unix_only > 0) {
14459             decc_filename_unix_only = 1;
14460         }
14461         else {
14462             decc_filename_unix_only = 0;
14463         }
14464     }
14465
14466     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14467     if (s >= 0) {
14468         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14469         if (decc_filename_unix_no_version < 0)
14470             decc_filename_unix_no_version = 0;
14471     }
14472
14473     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14474     if (s >= 0) {
14475         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14476         if (decc_readdir_dropdotnotype < 0)
14477             decc_readdir_dropdotnotype = 0;
14478     }
14479
14480 #if __CRTL_VER >= 80200000
14481     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14482     if (s >= 0) {
14483         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14484         if (decc_posix_compliant_pathnames < 0)
14485             decc_posix_compliant_pathnames = 0;
14486         if (decc_posix_compliant_pathnames > 4)
14487             decc_posix_compliant_pathnames = 0;
14488     }
14489
14490 #endif
14491 #else
14492     status = sys_trnlnm
14493         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
14494     if ($VMS_STATUS_SUCCESS(status)) {
14495         val_str[0] = _toupper(val_str[0]);
14496         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14497            decc_disable_to_vms_logname_translation = 1;
14498         }
14499     }
14500
14501 #ifndef __VAX
14502     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
14503     if ($VMS_STATUS_SUCCESS(status)) {
14504         val_str[0] = _toupper(val_str[0]);
14505         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14506            decc_efs_case_preserve = 1;
14507         }
14508     }
14509 #endif
14510
14511     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14512     if ($VMS_STATUS_SUCCESS(status)) {
14513         val_str[0] = _toupper(val_str[0]);
14514         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14515            decc_filename_unix_report = 1;
14516         }
14517     }
14518     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14519     if ($VMS_STATUS_SUCCESS(status)) {
14520         val_str[0] = _toupper(val_str[0]);
14521         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14522            decc_filename_unix_only = 1;
14523            decc_filename_unix_report = 1;
14524         }
14525     }
14526     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14527     if ($VMS_STATUS_SUCCESS(status)) {
14528         val_str[0] = _toupper(val_str[0]);
14529         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14530            decc_filename_unix_no_version = 1;
14531         }
14532     }
14533     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
14534     if ($VMS_STATUS_SUCCESS(status)) {
14535         val_str[0] = _toupper(val_str[0]);
14536         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14537            decc_readdir_dropdotnotype = 1;
14538         }
14539     }
14540 #endif
14541
14542 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
14543
14544      /* Report true case tolerance */
14545     /*----------------------------*/
14546     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14547     if (!$VMS_STATUS_SUCCESS(status))
14548         case_perm = PPROP$K_CASE_BLIND;
14549     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14550     if (!$VMS_STATUS_SUCCESS(status))
14551         case_image = PPROP$K_CASE_BLIND;
14552     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14553         (case_image == PPROP$K_CASE_SENSITIVE))
14554         vms_process_case_tolerant = 0;
14555
14556 #endif
14557
14558     /* USE POSIX/DCL Exit codes - Recommended, but needs to default to  */
14559     /* for strict backward compatibilty */
14560     status = sys_trnlnm
14561         ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14562     if ($VMS_STATUS_SUCCESS(status)) {
14563        val_str[0] = _toupper(val_str[0]);
14564        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14565          vms_posix_exit = 1;
14566        else
14567          vms_posix_exit = 0;
14568     }
14569
14570
14571     /* CRTL can be initialized past this point, but not before. */
14572 /*    DECC$CRTL_INIT(); */
14573
14574     return SS$_NORMAL;
14575 }
14576
14577 #ifdef __DECC
14578 #pragma nostandard
14579 #pragma extern_model save
14580 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
14581         const __align (LONGWORD) int spare[8] = {0};
14582
14583 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
14584 #if __DECC_VER >= 60560002
14585 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
14586 #else
14587 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
14588 #endif
14589 #endif /* __DECC */
14590
14591 const long vms_cc_features = (const long)set_features;
14592
14593 /*
14594 ** Force a reference to LIB$INITIALIZE to ensure it
14595 ** exists in the image.
14596 */
14597 int lib$initialize(void);
14598 #ifdef __DECC
14599 #pragma extern_model strict_refdef
14600 #endif
14601     int lib_init_ref = (int) lib$initialize;
14602
14603 #ifdef __DECC
14604 #pragma extern_model restore
14605 #pragma standard
14606 #endif
14607
14608 /*  End of vms.c */