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 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6521 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6522 {
6523     static char __pathify_retbuf[VMS_MAXRSS];
6524     unsigned long int retlen;
6525     char *retpath, *cp1, *cp2, *trndir;
6526     unsigned short int trnlnm_iter_count;
6527     STRLEN trnlen;
6528     int sts;
6529     if (utf8_fl != NULL)
6530         *utf8_fl = 0;
6531
6532     if (!dir || !*dir) {
6533       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6534     }
6535
6536     trndir = PerlMem_malloc(VMS_MAXRSS);
6537     if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6538     if (*dir) strcpy(trndir,dir);
6539     else getcwd(trndir,VMS_MAXRSS - 1);
6540
6541     trnlnm_iter_count = 0;
6542     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6543            && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
6544       trnlnm_iter_count++;
6545       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6546       trnlen = strlen(trndir);
6547
6548       /* Trap simple rooted lnms, and return lnm:[000000] */
6549       if (!strcmp(trndir+trnlen-2,".]")) {
6550         if (buf) retpath = buf;
6551         else if (ts) Newx(retpath,strlen(dir)+10,char);
6552         else retpath = __pathify_retbuf;
6553         strcpy(retpath,dir);
6554         strcat(retpath,":[000000]");
6555         PerlMem_free(trndir);
6556         return retpath;
6557       }
6558     }
6559
6560     /* At this point we do not work with *dir, but the copy in
6561      * *trndir that is modifiable.
6562      */
6563
6564     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
6565       if (*trndir == '.' && (*(trndir+1) == '\0' ||
6566                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
6567         retlen = 2 + (*(trndir+1) != '\0');
6568       else {
6569         if ( !(cp1 = strrchr(trndir,'/')) &&
6570              !(cp1 = strrchr(trndir,']')) &&
6571              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
6572         if ((cp2 = strchr(cp1,'.')) != NULL &&
6573             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
6574              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
6575               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
6576               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
6577           int ver; char *cp3;
6578
6579           /* For EFS or ODS-5 look for the last dot */
6580           if (decc_efs_charset) {
6581             cp2 = strrchr(cp1,'.');
6582           }
6583           if (vms_process_case_tolerant) {
6584               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
6585                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
6586                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6587                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6588                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6589                             (ver || *cp3)))))) {
6590                 PerlMem_free(trndir);
6591                 set_errno(ENOTDIR);
6592                 set_vaxc_errno(RMS$_DIR);
6593                 return NULL;
6594               }
6595           }
6596           else {
6597               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
6598                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
6599                   !*(cp2+3) || *(cp2+3) != 'R' ||
6600                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6601                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6602                             (ver || *cp3)))))) {
6603                 PerlMem_free(trndir);
6604                 set_errno(ENOTDIR);
6605                 set_vaxc_errno(RMS$_DIR);
6606                 return NULL;
6607               }
6608           }
6609           retlen = cp2 - trndir + 1;
6610         }
6611         else {  /* No file type present.  Treat the filename as a directory. */
6612           retlen = strlen(trndir) + 1;
6613         }
6614       }
6615       if (buf) retpath = buf;
6616       else if (ts) Newx(retpath,retlen+1,char);
6617       else retpath = __pathify_retbuf;
6618       strncpy(retpath, trndir, retlen-1);
6619       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
6620         retpath[retlen-1] = '/';      /* with '/', add it. */
6621         retpath[retlen] = '\0';
6622       }
6623       else retpath[retlen-1] = '\0';
6624     }
6625     else {  /* VMS-style directory spec */
6626       char *esa, *esal, *cp;
6627       char *my_esa;
6628       int my_esa_len;
6629       unsigned long int sts, cmplen, haslower;
6630       struct FAB dirfab = cc$rms_fab;
6631       int dirlen;
6632       rms_setup_nam(savnam);
6633       rms_setup_nam(dirnam);
6634
6635       /* If we've got an explicit filename, we can just shuffle the string. */
6636       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
6637              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
6638         if ((cp2 = strchr(cp1,'.')) != NULL) {
6639           int ver; char *cp3;
6640           if (vms_process_case_tolerant) {
6641               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
6642                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
6643                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6644                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6645                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6646                             (ver || *cp3)))))) {
6647                PerlMem_free(trndir);
6648                set_errno(ENOTDIR);
6649                set_vaxc_errno(RMS$_DIR);
6650                return NULL;
6651              }
6652           }
6653           else {
6654               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
6655                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
6656                   !*(cp2+3) || *(cp2+3) != 'R' ||
6657                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6658                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6659                             (ver || *cp3)))))) {
6660                PerlMem_free(trndir);
6661                set_errno(ENOTDIR);
6662                set_vaxc_errno(RMS$_DIR);
6663                return NULL;
6664              }
6665           }
6666         }
6667         else {  /* No file type, so just draw name into directory part */
6668           for (cp2 = cp1; *cp2; cp2++) ;
6669         }
6670         *cp2 = *cp1;
6671         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
6672         *cp1 = '.';
6673         /* We've now got a VMS 'path'; fall through */
6674       }
6675
6676       dirlen = strlen(trndir);
6677       if (trndir[dirlen-1] == ']' ||
6678           trndir[dirlen-1] == '>' ||
6679           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
6680         if (buf) retpath = buf;
6681         else if (ts) Newx(retpath,strlen(trndir)+1,char);
6682         else retpath = __pathify_retbuf;
6683         strcpy(retpath,trndir);
6684         PerlMem_free(trndir);
6685         return retpath;
6686       }
6687       rms_set_fna(dirfab, dirnam, trndir, dirlen);
6688       esa = PerlMem_malloc(VMS_MAXRSS);
6689       if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6690       esal = NULL;
6691 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6692       esal = PerlMem_malloc(VMS_MAXRSS);
6693       if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6694 #endif
6695       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6696       rms_bind_fab_nam(dirfab, dirnam);
6697       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
6698 #ifdef NAM$M_NO_SHORT_UPCASE
6699       if (decc_efs_case_preserve)
6700           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6701 #endif
6702
6703       for (cp = trndir; *cp; cp++)
6704         if (islower(*cp)) { haslower = 1; break; }
6705
6706       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
6707         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
6708           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6709           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
6710         }
6711         if (!sts) {
6712           PerlMem_free(trndir);
6713           PerlMem_free(esa);
6714           if (esal != NULL)
6715             PerlMem_free(esal);
6716           set_errno(EVMSERR);
6717           set_vaxc_errno(dirfab.fab$l_sts);
6718           return NULL;
6719         }
6720       }
6721       else {
6722         savnam = dirnam;
6723         /* Does the file really exist? */
6724         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
6725           if (dirfab.fab$l_sts != RMS$_FNF) {
6726             int sts1;
6727             sts1 = rms_free_search_context(&dirfab);
6728             PerlMem_free(trndir);
6729             PerlMem_free(esa);
6730             if (esal != NULL)
6731                 PerlMem_free(esal);
6732             set_errno(EVMSERR);
6733             set_vaxc_errno(dirfab.fab$l_sts);
6734             return NULL;
6735           }
6736           dirnam = savnam; /* No; just work with potential name */
6737         }
6738       }
6739       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6740         /* Yep; check version while we're at it, if it's there. */
6741         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6742         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
6743           int sts2;
6744           /* Something other than .DIR[;1].  Bzzt. */
6745           sts2 = rms_free_search_context(&dirfab);
6746           PerlMem_free(trndir);
6747           PerlMem_free(esa);
6748           if (esal != NULL)
6749              PerlMem_free(esal);
6750           set_errno(ENOTDIR);
6751           set_vaxc_errno(RMS$_DIR);
6752           return NULL;
6753         }
6754       }
6755       /* Make sure we are using the right buffer */
6756       if (esal != NULL) {
6757         /* We only need one, clean up the other */
6758         my_esa = esal;
6759         my_esa_len = rms_nam_esll(dirnam);
6760       } else {
6761         my_esa = esa;
6762         my_esa_len = rms_nam_esl(dirnam);
6763       }
6764
6765       /* Null terminate the buffer */
6766       my_esa[my_esa_len] = '\0';
6767
6768       /* OK, the type was fine.  Now pull any file name into the
6769          directory path. */
6770       if ((cp1 = strrchr(my_esa,']'))) *(rms_nam_typel(dirnam)) = ']';
6771       else {
6772         cp1 = strrchr(my_esa,'>');
6773         *(rms_nam_typel(dirnam)) = '>';
6774       }
6775       *cp1 = '.';
6776       *(rms_nam_typel(dirnam) + 1) = '\0';
6777       retlen = (rms_nam_typel(dirnam)) - my_esa + 2;
6778       if (buf) retpath = buf;
6779       else if (ts) Newx(retpath,retlen,char);
6780       else retpath = __pathify_retbuf;
6781       strcpy(retpath,my_esa);
6782       PerlMem_free(esa);
6783       if (esal != NULL)
6784           PerlMem_free(esal);
6785       sts = rms_free_search_context(&dirfab);
6786       /* $PARSE may have upcased filespec, so convert output to lower
6787        * case if input contained any lowercase characters. */
6788       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
6789     }
6790
6791     PerlMem_free(trndir);
6792     return retpath;
6793 }  /* end of do_pathify_dirspec() */
6794 /*}}}*/
6795 /* External entry points */
6796 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6797 { return do_pathify_dirspec(dir,buf,0,NULL); }
6798 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6799 { return do_pathify_dirspec(dir,buf,1,NULL); }
6800 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6801 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6802 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6803 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
6804
6805 /* Internal tounixspec routine that does not use a thread context */
6806 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
6807 static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
6808 {
6809   char *dirend, *cp1, *cp3, *tmp;
6810   const char *cp2;
6811   int devlen, dirlen, retlen = VMS_MAXRSS;
6812   int expand = 1; /* guarantee room for leading and trailing slashes */
6813   unsigned short int trnlnm_iter_count;
6814   int cmp_rslt;
6815   if (utf8_fl != NULL)
6816     *utf8_fl = 0;
6817
6818   if (vms_debug_fileify) {
6819       if (spec == NULL)
6820           fprintf(stderr, "int_tounixspec: spec = NULL\n");
6821       else
6822           fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
6823   }
6824
6825
6826   if (spec == NULL) {
6827       set_errno(EINVAL);
6828       set_vaxc_errno(SS$_BADPARAM);
6829       return NULL;
6830   }
6831   if (strlen(spec) > (VMS_MAXRSS-1)) {
6832       set_errno(E2BIG);
6833       set_vaxc_errno(SS$_BUFFEROVF);
6834       return NULL;
6835   }
6836
6837   /* New VMS specific format needs translation
6838    * glob passes filenames with trailing '\n' and expects this preserved.
6839    */
6840   if (decc_posix_compliant_pathnames) {
6841     if (strncmp(spec, "\"^UP^", 5) == 0) {
6842       char * uspec;
6843       char *tunix;
6844       int tunix_len;
6845       int nl_flag;
6846
6847       tunix = PerlMem_malloc(VMS_MAXRSS);
6848       if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6849       strcpy(tunix, spec);
6850       tunix_len = strlen(tunix);
6851       nl_flag = 0;
6852       if (tunix[tunix_len - 1] == '\n') {
6853         tunix[tunix_len - 1] = '\"';
6854         tunix[tunix_len] = '\0';
6855         tunix_len--;
6856         nl_flag = 1;
6857       }
6858       uspec = decc$translate_vms(tunix);
6859       PerlMem_free(tunix);
6860       if ((int)uspec > 0) {
6861         strcpy(rslt,uspec);
6862         if (nl_flag) {
6863           strcat(rslt,"\n");
6864         }
6865         else {
6866           /* If we can not translate it, makemaker wants as-is */
6867           strcpy(rslt, spec);
6868         }
6869         return rslt;
6870       }
6871     }
6872   }
6873
6874   cmp_rslt = 0; /* Presume VMS */
6875   cp1 = strchr(spec, '/');
6876   if (cp1 == NULL)
6877     cmp_rslt = 0;
6878
6879     /* Look for EFS ^/ */
6880     if (decc_efs_charset) {
6881       while (cp1 != NULL) {
6882         cp2 = cp1 - 1;
6883         if (*cp2 != '^') {
6884           /* Found illegal VMS, assume UNIX */
6885           cmp_rslt = 1;
6886           break;
6887         }
6888       cp1++;
6889       cp1 = strchr(cp1, '/');
6890     }
6891   }
6892
6893   /* Look for "." and ".." */
6894   if (decc_filename_unix_report) {
6895     if (spec[0] == '.') {
6896       if ((spec[1] == '\0') || (spec[1] == '\n')) {
6897         cmp_rslt = 1;
6898       }
6899       else {
6900         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
6901           cmp_rslt = 1;
6902         }
6903       }
6904     }
6905   }
6906   /* This is already UNIX or at least nothing VMS understands */
6907   if (cmp_rslt) {
6908     strcpy(rslt,spec);
6909     if (vms_debug_fileify) {
6910         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
6911     }
6912     return rslt;
6913   }
6914
6915   cp1 = rslt;
6916   cp2 = spec;
6917   dirend = strrchr(spec,']');
6918   if (dirend == NULL) dirend = strrchr(spec,'>');
6919   if (dirend == NULL) dirend = strchr(spec,':');
6920   if (dirend == NULL) {
6921     strcpy(rslt,spec);
6922     if (vms_debug_fileify) {
6923         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
6924     }
6925     return rslt;
6926   }
6927
6928   /* Special case 1 - sys$posix_root = / */
6929 #if __CRTL_VER >= 70000000
6930   if (!decc_disable_posix_root) {
6931     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6932       *cp1 = '/';
6933       cp1++;
6934       cp2 = cp2 + 15;
6935       }
6936   }
6937 #endif
6938
6939   /* Special case 2 - Convert NLA0: to /dev/null */
6940 #if __CRTL_VER < 70000000
6941   cmp_rslt = strncmp(spec,"NLA0:", 5);
6942   if (cmp_rslt != 0)
6943      cmp_rslt = strncmp(spec,"nla0:", 5);
6944 #else
6945   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6946 #endif
6947   if (cmp_rslt == 0) {
6948     strcpy(rslt, "/dev/null");
6949     cp1 = cp1 + 9;
6950     cp2 = cp2 + 5;
6951     if (spec[6] != '\0') {
6952       cp1[9] == '/';
6953       cp1++;
6954       cp2++;
6955     }
6956   }
6957
6958    /* Also handle special case "SYS$SCRATCH:" */
6959 #if __CRTL_VER < 70000000
6960   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
6961   if (cmp_rslt != 0)
6962      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
6963 #else
6964   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6965 #endif
6966   tmp = PerlMem_malloc(VMS_MAXRSS);
6967   if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6968   if (cmp_rslt == 0) {
6969   int islnm;
6970
6971     islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
6972     if (!islnm) {
6973       strcpy(rslt, "/tmp");
6974       cp1 = cp1 + 4;
6975       cp2 = cp2 + 12;
6976       if (spec[12] != '\0') {
6977         cp1[4] == '/';
6978         cp1++;
6979         cp2++;
6980       }
6981     }
6982   }
6983
6984   if (*cp2 != '[' && *cp2 != '<') {
6985     *(cp1++) = '/';
6986   }
6987   else {  /* the VMS spec begins with directories */
6988     cp2++;
6989     if (*cp2 == ']' || *cp2 == '>') {
6990       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
6991       PerlMem_free(tmp);
6992       return rslt;
6993     }
6994     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
6995       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
6996         PerlMem_free(tmp);
6997         if (vms_debug_fileify) {
6998             fprintf(stderr, "int_tounixspec: rslt = NULL\n");
6999         }
7000         return NULL;
7001       }
7002       trnlnm_iter_count = 0;
7003       do {
7004         cp3 = tmp;
7005         while (*cp3 != ':' && *cp3) cp3++;
7006         *(cp3++) = '\0';
7007         if (strchr(cp3,']') != NULL) break;
7008         trnlnm_iter_count++;
7009         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7010       } while (vmstrnenv(tmp,tmp,0,fildev,0));
7011       cp1 = rslt;
7012       cp3 = tmp;
7013       *(cp1++) = '/';
7014       while (*cp3) {
7015         *(cp1++) = *(cp3++);
7016         if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7017             PerlMem_free(tmp);
7018             set_errno(ENAMETOOLONG);
7019             set_vaxc_errno(SS$_BUFFEROVF);
7020             if (vms_debug_fileify) {
7021                 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7022             }
7023             return NULL; /* No room */
7024         }
7025       }
7026       *(cp1++) = '/';
7027     }
7028     if ((*cp2 == '^')) {
7029         /* EFS file escape, pass the next character as is */
7030         /* Fix me: HEX encoding for Unicode not implemented */
7031         cp2++;
7032     }
7033     else if ( *cp2 == '.') {
7034       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7035         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7036         cp2 += 3;
7037       }
7038       else cp2++;
7039     }
7040   }
7041   PerlMem_free(tmp);
7042   for (; cp2 <= dirend; cp2++) {
7043     if ((*cp2 == '^')) {
7044         /* EFS file escape, pass the next character as is */
7045         /* Fix me: HEX encoding for Unicode not implemented */
7046         *(cp1++) = *(++cp2);
7047         /* An escaped dot stays as is -- don't convert to slash */
7048         if (*cp2 == '.') cp2++;
7049     }
7050     if (*cp2 == ':') {
7051       *(cp1++) = '/';
7052       if (*(cp2+1) == '[') cp2++;
7053     }
7054     else if (*cp2 == ']' || *cp2 == '>') {
7055       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7056     }
7057     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7058       *(cp1++) = '/';
7059       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7060         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7061                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7062         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7063             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7064       }
7065       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7066         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7067         cp2 += 2;
7068       }
7069     }
7070     else if (*cp2 == '-') {
7071       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7072         while (*cp2 == '-') {
7073           cp2++;
7074           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7075         }
7076         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7077                                                          /* filespecs like */
7078           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
7079           if (vms_debug_fileify) {
7080               fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7081           }
7082           return NULL;
7083         }
7084       }
7085       else *(cp1++) = *cp2;
7086     }
7087     else *(cp1++) = *cp2;
7088   }
7089   /* Translate the rest of the filename. */
7090   while (*cp2) {
7091       int dot_seen;
7092       dot_seen = 0;
7093       switch(*cp2) {
7094       /* Fixme - for compatibility with the CRTL we should be removing */
7095       /* spaces from the file specifications, but this may show that */
7096       /* some tests that were appearing to pass are not really passing */
7097       case '%':
7098           cp2++;
7099           *(cp1++) = '?';
7100           break;
7101       case '^':
7102           /* Fix me hex expansions not implemented */
7103           cp2++;  /* '^.' --> '.' and other. */
7104           if (*cp2) {
7105               if (*cp2 == '_') {
7106                   cp2++;
7107                   *(cp1++) = ' ';
7108               } else {
7109                   *(cp1++) = *(cp2++);
7110               }
7111           }
7112           break;
7113       case ';':
7114           if (decc_filename_unix_no_version) {
7115               /* Easy, drop the version */
7116               while (*cp2)
7117                   cp2++;
7118               break;
7119           } else {
7120               /* Punt - passing the version as a dot will probably */
7121               /* break perl in weird ways, but so did passing */
7122               /* through the ; as a version.  Follow the CRTL and */
7123               /* hope for the best. */
7124               cp2++;
7125               *(cp1++) = '.';
7126           }
7127           break;
7128       case '.':
7129           if (dot_seen) {
7130               /* We will need to fix this properly later */
7131               /* As Perl may be installed on an ODS-5 volume, but not */
7132               /* have the EFS_CHARSET enabled, it still may encounter */
7133               /* filenames with extra dots in them, and a precedent got */
7134               /* set which allowed them to work, that we will uphold here */
7135               /* If extra dots are present in a name and no ^ is on them */
7136               /* VMS assumes that the first one is the extension delimiter */
7137               /* the rest have an implied ^. */
7138
7139               /* this is also a conflict as the . is also a version */
7140               /* delimiter in VMS, */
7141
7142               *(cp1++) = *(cp2++);
7143               break;
7144           }
7145           dot_seen = 1;
7146           /* This is an extension */
7147           if (decc_readdir_dropdotnotype) {
7148               cp2++;
7149               if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7150                   /* Drop the dot for the extension */
7151                   break;
7152               } else {
7153                   *(cp1++) = '.';
7154               }
7155               break;
7156           }
7157       default:
7158           *(cp1++) = *(cp2++);
7159       }
7160   }
7161   *cp1 = '\0';
7162
7163   /* This still leaves /000000/ when working with a
7164    * VMS device root or concealed root.
7165    */
7166   {
7167   int ulen;
7168   char * zeros;
7169
7170       ulen = strlen(rslt);
7171
7172       /* Get rid of "000000/ in rooted filespecs */
7173       if (ulen > 7) {
7174         zeros = strstr(rslt, "/000000/");
7175         if (zeros != NULL) {
7176           int mlen;
7177           mlen = ulen - (zeros - rslt) - 7;
7178           memmove(zeros, &zeros[7], mlen);
7179           ulen = ulen - 7;
7180           rslt[ulen] = '\0';
7181         }
7182       }
7183   }
7184
7185   if (vms_debug_fileify) {
7186       fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7187   }
7188   return rslt;
7189
7190 }  /* end of int_tounixspec() */
7191
7192
7193 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7194 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7195 {
7196     static char __tounixspec_retbuf[VMS_MAXRSS];
7197     char * unixspec, *ret_spec, *ret_buf;
7198
7199     unixspec = NULL;
7200     ret_buf = buf;
7201     if (ret_buf == NULL) {
7202         if (ts) {
7203             Newx(unixspec, VMS_MAXRSS, char);
7204             if (unixspec == NULL)
7205                 _ckvmssts(SS$_INSFMEM);
7206             ret_buf = unixspec;
7207         } else {
7208             ret_buf = __tounixspec_retbuf;
7209         }
7210     }
7211
7212     ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7213
7214     if (ret_spec == NULL) {
7215        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7216        if (unixspec)
7217            Safefree(unixspec);
7218     }
7219
7220     return ret_spec;
7221
7222 }  /* end of do_tounixspec() */
7223 /*}}}*/
7224 /* External entry points */
7225 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
7226   { return do_tounixspec(spec,buf,0, NULL); }
7227 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7228   { return do_tounixspec(spec,buf,1, NULL); }
7229 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7230   { return do_tounixspec(spec,buf,0, utf8_fl); }
7231 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7232   { return do_tounixspec(spec,buf,1, utf8_fl); }
7233
7234 #if __CRTL_VER >= 70200000 && !defined(__VAX)
7235
7236 /*
7237  This procedure is used to identify if a path is based in either
7238  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7239  it returns the OpenVMS format directory for it.
7240
7241  It is expecting specifications of only '/' or '/xxxx/'
7242
7243  If a posix root does not exist, or 'xxxx' is not a directory
7244  in the posix root, it returns a failure.
7245
7246  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7247
7248  It is used only internally by posix_to_vmsspec_hardway().
7249  */
7250
7251 static int posix_root_to_vms
7252   (char *vmspath, int vmspath_len,
7253    const char *unixpath,
7254    const int * utf8_fl)
7255 {
7256 int sts;
7257 struct FAB myfab = cc$rms_fab;
7258 rms_setup_nam(mynam);
7259 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7260 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7261 char * esa, * esal, * rsa, * rsal;
7262 char *vms_delim;
7263 int dir_flag;
7264 int unixlen;
7265
7266     dir_flag = 0;
7267     vmspath[0] = '\0';
7268     unixlen = strlen(unixpath);
7269     if (unixlen == 0) {
7270       return RMS$_FNF;
7271     }
7272
7273 #if __CRTL_VER >= 80200000
7274   /* If not a posix spec already, convert it */
7275   if (decc_posix_compliant_pathnames) {
7276     if (strncmp(unixpath,"\"^UP^",5) != 0) {
7277       sprintf(vmspath,"\"^UP^%s\"",unixpath);
7278     }
7279     else {
7280       /* This is already a VMS specification, no conversion */
7281       unixlen--;
7282       strncpy(vmspath,unixpath, vmspath_len);
7283     }
7284   }
7285   else
7286 #endif
7287   {
7288   int path_len;
7289   int i,j;
7290
7291      /* Check to see if this is under the POSIX root */
7292      if (decc_disable_posix_root) {
7293         return RMS$_FNF;
7294      }
7295
7296      /* Skip leading / */
7297      if (unixpath[0] == '/') {
7298         unixpath++;
7299         unixlen--;
7300      }
7301
7302
7303      strcpy(vmspath,"SYS$POSIX_ROOT:");
7304
7305      /* If this is only the / , or blank, then... */
7306      if (unixpath[0] == '\0') {
7307         /* by definition, this is the answer */
7308         return SS$_NORMAL;
7309      }
7310
7311      /* Need to look up a directory */
7312      vmspath[15] = '[';
7313      vmspath[16] = '\0';
7314
7315      /* Copy and add '^' escape characters as needed */
7316      j = 16;
7317      i = 0;
7318      while (unixpath[i] != 0) {
7319      int k;
7320
7321         j += copy_expand_unix_filename_escape
7322             (&vmspath[j], &unixpath[i], &k, utf8_fl);
7323         i += k;
7324      }
7325
7326      path_len = strlen(vmspath);
7327      if (vmspath[path_len - 1] == '/')
7328         path_len--;
7329      vmspath[path_len] = ']';
7330      path_len++;
7331      vmspath[path_len] = '\0';
7332
7333   }
7334   vmspath[vmspath_len] = 0;
7335   if (unixpath[unixlen - 1] == '/')
7336   dir_flag = 1;
7337   esal = PerlMem_malloc(VMS_MAXRSS);
7338   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7339   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7340   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7341   rsal = PerlMem_malloc(VMS_MAXRSS);
7342   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7343   rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7344   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7345   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7346   rms_bind_fab_nam(myfab, mynam);
7347   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7348   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7349   if (decc_efs_case_preserve)
7350     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7351 #ifdef NAML$M_OPEN_SPECIAL
7352   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7353 #endif
7354
7355   /* Set up the remaining naml fields */
7356   sts = sys$parse(&myfab);
7357
7358   /* It failed! Try again as a UNIX filespec */
7359   if (!(sts & 1)) {
7360     PerlMem_free(esal);
7361     PerlMem_free(esa);
7362     PerlMem_free(rsal);
7363     PerlMem_free(rsa);
7364     return sts;
7365   }
7366
7367    /* get the Device ID and the FID */
7368    sts = sys$search(&myfab);
7369
7370    /* These are no longer needed */
7371    PerlMem_free(esa);
7372    PerlMem_free(rsal);
7373    PerlMem_free(rsa);
7374
7375    /* on any failure, returned the POSIX ^UP^ filespec */
7376    if (!(sts & 1)) {
7377       PerlMem_free(esal);
7378       return sts;
7379    }
7380    specdsc.dsc$a_pointer = vmspath;
7381    specdsc.dsc$w_length = vmspath_len;
7382
7383    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7384    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7385    sts = lib$fid_to_name
7386       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7387
7388   /* on any failure, returned the POSIX ^UP^ filespec */
7389   if (!(sts & 1)) {
7390      /* This can happen if user does not have permission to read directories */
7391      if (strncmp(unixpath,"\"^UP^",5) != 0)
7392        sprintf(vmspath,"\"^UP^%s\"",unixpath);
7393      else
7394        strcpy(vmspath, unixpath);
7395   }
7396   else {
7397     vmspath[specdsc.dsc$w_length] = 0;
7398
7399     /* Are we expecting a directory? */
7400     if (dir_flag != 0) {
7401     int i;
7402     char *eptr;
7403
7404       eptr = NULL;
7405
7406       i = specdsc.dsc$w_length - 1;
7407       while (i > 0) {
7408       int zercnt;
7409         zercnt = 0;
7410         /* Version must be '1' */
7411         if (vmspath[i--] != '1')
7412           break;
7413         /* Version delimiter is one of ".;" */
7414         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7415           break;
7416         i--;
7417         if (vmspath[i--] != 'R')
7418           break;
7419         if (vmspath[i--] != 'I')
7420           break;
7421         if (vmspath[i--] != 'D')
7422           break;
7423         if (vmspath[i--] != '.')
7424           break;
7425         eptr = &vmspath[i+1];
7426         while (i > 0) {
7427           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7428             if (vmspath[i-1] != '^') {
7429               if (zercnt != 6) {
7430                 *eptr = vmspath[i];
7431                 eptr[1] = '\0';
7432                 vmspath[i] = '.';
7433                 break;
7434               }
7435               else {
7436                 /* Get rid of 6 imaginary zero directory filename */
7437                 vmspath[i+1] = '\0';
7438               }
7439             }
7440           }
7441           if (vmspath[i] == '0')
7442             zercnt++;
7443           else
7444             zercnt = 10;
7445           i--;
7446         }
7447         break;
7448       }
7449     }
7450   }
7451   PerlMem_free(esal);
7452   return sts;
7453 }
7454
7455 /* /dev/mumble needs to be handled special.
7456    /dev/null becomes NLA0:, And there is the potential for other stuff
7457    like /dev/tty which may need to be mapped to something.
7458 */
7459
7460 static int
7461 slash_dev_special_to_vms
7462    (const char * unixptr,
7463     char * vmspath,
7464     int vmspath_len)
7465 {
7466 char * nextslash;
7467 int len;
7468 int cmp;
7469 int islnm;
7470
7471     unixptr += 4;
7472     nextslash = strchr(unixptr, '/');
7473     len = strlen(unixptr);
7474     if (nextslash != NULL)
7475         len = nextslash - unixptr;
7476     cmp = strncmp("null", unixptr, 5);
7477     if (cmp == 0) {
7478         if (vmspath_len >= 6) {
7479             strcpy(vmspath, "_NLA0:");
7480             return SS$_NORMAL;
7481         }
7482     }
7483 }
7484
7485
7486 /* The built in routines do not understand perl's special needs, so
7487     doing a manual conversion from UNIX to VMS
7488
7489     If the utf8_fl is not null and points to a non-zero value, then
7490     treat 8 bit characters as UTF-8.
7491
7492     The sequence starting with '$(' and ending with ')' will be passed
7493     through with out interpretation instead of being escaped.
7494
7495   */
7496 static int posix_to_vmsspec_hardway
7497   (char *vmspath, int vmspath_len,
7498    const char *unixpath,
7499    int dir_flag,
7500    int * utf8_fl) {
7501
7502 char *esa;
7503 const char *unixptr;
7504 const char *unixend;
7505 char *vmsptr;
7506 const char *lastslash;
7507 const char *lastdot;
7508 int unixlen;
7509 int vmslen;
7510 int dir_start;
7511 int dir_dot;
7512 int quoted;
7513 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7514 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7515
7516   if (utf8_fl != NULL)
7517     *utf8_fl = 0;
7518
7519   unixptr = unixpath;
7520   dir_dot = 0;
7521
7522   /* Ignore leading "/" characters */
7523   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7524     unixptr++;
7525   }
7526   unixlen = strlen(unixptr);
7527
7528   /* Do nothing with blank paths */
7529   if (unixlen == 0) {
7530     vmspath[0] = '\0';
7531     return SS$_NORMAL;
7532   }
7533
7534   quoted = 0;
7535   /* This could have a "^UP^ on the front */
7536   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7537     quoted = 1;
7538     unixptr+= 5;
7539     unixlen-= 5;
7540   }
7541
7542   lastslash = strrchr(unixptr,'/');
7543   lastdot = strrchr(unixptr,'.');
7544   unixend = strrchr(unixptr,'\"');
7545   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7546     unixend = unixptr + unixlen;
7547   }
7548
7549   /* last dot is last dot or past end of string */
7550   if (lastdot == NULL)
7551     lastdot = unixptr + unixlen;
7552
7553   /* if no directories, set last slash to beginning of string */
7554   if (lastslash == NULL) {
7555     lastslash = unixptr;
7556   }
7557   else {
7558     /* Watch out for trailing "." after last slash, still a directory */
7559     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7560       lastslash = unixptr + unixlen;
7561     }
7562
7563     /* Watch out for traiing ".." after last slash, still a directory */
7564     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7565       lastslash = unixptr + unixlen;
7566     }
7567
7568     /* dots in directories are aways escaped */
7569     if (lastdot < lastslash)
7570       lastdot = unixptr + unixlen;
7571   }
7572
7573   /* if (unixptr < lastslash) then we are in a directory */
7574
7575   dir_start = 0;
7576
7577   vmsptr = vmspath;
7578   vmslen = 0;
7579
7580   /* Start with the UNIX path */
7581   if (*unixptr != '/') {
7582     /* relative paths */
7583
7584     /* If allowing logical names on relative pathnames, then handle here */
7585     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7586         !decc_posix_compliant_pathnames) {
7587     char * nextslash;
7588     int seg_len;
7589     char * trn;
7590     int islnm;
7591
7592         /* Find the next slash */
7593         nextslash = strchr(unixptr,'/');
7594
7595         esa = PerlMem_malloc(vmspath_len);
7596         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7597
7598         trn = PerlMem_malloc(VMS_MAXRSS);
7599         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7600
7601         if (nextslash != NULL) {
7602
7603             seg_len = nextslash - unixptr;
7604             strncpy(esa, unixptr, seg_len);
7605             esa[seg_len] = 0;
7606         }
7607         else {
7608             strcpy(esa, unixptr);
7609             seg_len = strlen(unixptr);
7610         }
7611         /* trnlnm(section) */
7612         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7613
7614         if (islnm) {
7615             /* Now fix up the directory */
7616
7617             /* Split up the path to find the components */
7618             sts = vms_split_path
7619                   (trn,
7620                    &v_spec,
7621                    &v_len,
7622                    &r_spec,
7623                    &r_len,
7624                    &d_spec,
7625                    &d_len,
7626                    &n_spec,
7627                    &n_len,
7628                    &e_spec,
7629                    &e_len,
7630                    &vs_spec,
7631                    &vs_len);
7632
7633             while (sts == 0) {
7634             char * strt;
7635             int cmp;
7636
7637                 /* A logical name must be a directory  or the full
7638                    specification.  It is only a full specification if
7639                    it is the only component */
7640                 if ((unixptr[seg_len] == '\0') ||
7641                     (unixptr[seg_len+1] == '\0')) {
7642
7643                     /* Is a directory being required? */
7644                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7645                         /* Not a logical name */
7646                         break;
7647                     }
7648
7649
7650                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7651                         /* This must be a directory */
7652                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7653                             strcpy(vmsptr, esa);
7654                             vmslen=strlen(vmsptr);
7655                             vmsptr[vmslen] = ':';
7656                             vmslen++;
7657                             vmsptr[vmslen] = '\0';
7658                             return SS$_NORMAL;
7659                         }
7660                     }
7661
7662                 }
7663
7664
7665                 /* must be dev/directory - ignore version */
7666                 if ((n_len + e_len) != 0)
7667                     break;
7668
7669                 /* transfer the volume */
7670                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7671                     strncpy(vmsptr, v_spec, v_len);
7672                     vmsptr += v_len;
7673                     vmsptr[0] = '\0';
7674                     vmslen += v_len;
7675                 }
7676
7677                 /* unroot the rooted directory */
7678                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7679                     r_spec[0] = '[';
7680                     r_spec[r_len - 1] = ']';
7681
7682                     /* This should not be there, but nothing is perfect */
7683                     if (r_len > 9) {
7684                         cmp = strcmp(&r_spec[1], "000000.");
7685                         if (cmp == 0) {
7686                             r_spec += 7;
7687                             r_spec[7] = '[';
7688                             r_len -= 7;
7689                             if (r_len == 2)
7690                                 r_len = 0;
7691                         }
7692                     }
7693                     if (r_len > 0) {
7694                         strncpy(vmsptr, r_spec, r_len);
7695                         vmsptr += r_len;
7696                         vmslen += r_len;
7697                         vmsptr[0] = '\0';
7698                     }
7699                 }
7700                 /* Bring over the directory. */
7701                 if ((d_len > 0) &&
7702                     ((d_len + vmslen) < vmspath_len)) {
7703                     d_spec[0] = '[';
7704                     d_spec[d_len - 1] = ']';
7705                     if (d_len > 9) {
7706                         cmp = strcmp(&d_spec[1], "000000.");
7707                         if (cmp == 0) {
7708                             d_spec += 7;
7709                             d_spec[7] = '[';
7710                             d_len -= 7;
7711                             if (d_len == 2)
7712                                 d_len = 0;
7713                         }
7714                     }
7715
7716                     if (r_len > 0) {
7717                         /* Remove the redundant root */
7718                         if (r_len > 0) {
7719                             /* remove the ][ */
7720                             vmsptr--;
7721                             vmslen--;
7722                             d_spec++;
7723                             d_len--;
7724                         }
7725                         strncpy(vmsptr, d_spec, d_len);
7726                             vmsptr += d_len;
7727                             vmslen += d_len;
7728                             vmsptr[0] = '\0';
7729                     }
7730                 }
7731                 break;
7732             }
7733         }
7734
7735         PerlMem_free(esa);
7736         PerlMem_free(trn);
7737     }
7738
7739     if (lastslash > unixptr) {
7740     int dotdir_seen;
7741
7742       /* skip leading ./ */
7743       dotdir_seen = 0;
7744       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7745         dotdir_seen = 1;
7746         unixptr++;
7747         unixptr++;
7748       }
7749
7750       /* Are we still in a directory? */
7751       if (unixptr <= lastslash) {
7752         *vmsptr++ = '[';
7753         vmslen = 1;
7754         dir_start = 1;
7755
7756         /* if not backing up, then it is relative forward. */
7757         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7758               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7759           *vmsptr++ = '.';
7760           vmslen++;
7761           dir_dot = 1;
7762           }
7763        }
7764        else {
7765          if (dotdir_seen) {
7766            /* Perl wants an empty directory here to tell the difference
7767             * between a DCL commmand and a filename
7768             */
7769           *vmsptr++ = '[';
7770           *vmsptr++ = ']';
7771           vmslen = 2;
7772         }
7773       }
7774     }
7775     else {
7776       /* Handle two special files . and .. */
7777       if (unixptr[0] == '.') {
7778         if (&unixptr[1] == unixend) {
7779           *vmsptr++ = '[';
7780           *vmsptr++ = ']';
7781           vmslen += 2;
7782           *vmsptr++ = '\0';
7783           return SS$_NORMAL;
7784         }
7785         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7786           *vmsptr++ = '[';
7787           *vmsptr++ = '-';
7788           *vmsptr++ = ']';
7789           vmslen += 3;
7790           *vmsptr++ = '\0';
7791           return SS$_NORMAL;
7792         }
7793       }
7794     }
7795   }
7796   else {        /* Absolute PATH handling */
7797   int sts;
7798   char * nextslash;
7799   int seg_len;
7800     /* Need to find out where root is */
7801
7802     /* In theory, this procedure should never get an absolute POSIX pathname
7803      * that can not be found on the POSIX root.
7804      * In practice, that can not be relied on, and things will show up
7805      * here that are a VMS device name or concealed logical name instead.
7806      * So to make things work, this procedure must be tolerant.
7807      */
7808     esa = PerlMem_malloc(vmspath_len);
7809     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7810
7811     sts = SS$_NORMAL;
7812     nextslash = strchr(&unixptr[1],'/');
7813     seg_len = 0;
7814     if (nextslash != NULL) {
7815     int cmp;
7816       seg_len = nextslash - &unixptr[1];
7817       strncpy(vmspath, unixptr, seg_len + 1);
7818       vmspath[seg_len+1] = 0;
7819       cmp = 1;
7820       if (seg_len == 3) {
7821         cmp = strncmp(vmspath, "dev", 4);
7822         if (cmp == 0) {
7823             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7824             if (sts = SS$_NORMAL)
7825                 return SS$_NORMAL;
7826         }
7827       }
7828       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
7829     }
7830
7831     if ($VMS_STATUS_SUCCESS(sts)) {
7832       /* This is verified to be a real path */
7833
7834       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7835       if ($VMS_STATUS_SUCCESS(sts)) {
7836         strcpy(vmspath, esa);
7837         vmslen = strlen(vmspath);
7838         vmsptr = vmspath + vmslen;
7839         unixptr++;
7840         if (unixptr < lastslash) {
7841         char * rptr;
7842           vmsptr--;
7843           *vmsptr++ = '.';
7844           dir_start = 1;
7845           dir_dot = 1;
7846           if (vmslen > 7) {
7847           int cmp;
7848             rptr = vmsptr - 7;
7849             cmp = strcmp(rptr,"000000.");
7850             if (cmp == 0) {
7851               vmslen -= 7;
7852               vmsptr -= 7;
7853               vmsptr[1] = '\0';
7854             } /* removing 6 zeros */
7855           } /* vmslen < 7, no 6 zeros possible */
7856         } /* Not in a directory */
7857       } /* Posix root found */
7858       else {
7859         /* No posix root, fall back to default directory */
7860         strcpy(vmspath, "SYS$DISK:[");
7861         vmsptr = &vmspath[10];
7862         vmslen = 10;
7863         if (unixptr > lastslash) {
7864            *vmsptr = ']';
7865            vmsptr++;
7866            vmslen++;
7867         }
7868         else {
7869            dir_start = 1;
7870         }
7871       }
7872     } /* end of verified real path handling */
7873     else {
7874     int add_6zero;
7875     int islnm;
7876
7877       /* Ok, we have a device or a concealed root that is not in POSIX
7878        * or we have garbage.  Make the best of it.
7879        */
7880
7881       /* Posix to VMS destroyed this, so copy it again */
7882       strncpy(vmspath, &unixptr[1], seg_len);
7883       vmspath[seg_len] = 0;
7884       vmslen = seg_len;
7885       vmsptr = &vmsptr[vmslen];
7886       islnm = 0;
7887
7888       /* Now do we need to add the fake 6 zero directory to it? */
7889       add_6zero = 1;
7890       if ((*lastslash == '/') && (nextslash < lastslash)) {
7891         /* No there is another directory */
7892         add_6zero = 0;
7893       }
7894       else {
7895       int trnend;
7896       int cmp;
7897
7898         /* now we have foo:bar or foo:[000000]bar to decide from */
7899         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
7900
7901         if (!islnm && !decc_posix_compliant_pathnames) {
7902
7903             cmp = strncmp("bin", vmspath, 4);
7904             if (cmp == 0) {
7905                 /* bin => SYS$SYSTEM: */
7906                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7907             }
7908             else {
7909                 /* tmp => SYS$SCRATCH: */
7910                 cmp = strncmp("tmp", vmspath, 4);
7911                 if (cmp == 0) {
7912                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
7913                 }
7914             }
7915         }
7916
7917         trnend = islnm ? islnm - 1 : 0;
7918
7919         /* if this was a logical name, ']' or '>' must be present */
7920         /* if not a logical name, then assume a device and hope. */
7921         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
7922
7923         /* if log name and trailing '.' then rooted - treat as device */
7924         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
7925
7926         /* Fix me, if not a logical name, a device lookup should be
7927          * done to see if the device is file structured.  If the device
7928          * is not file structured, the 6 zeros should not be put on.
7929          *
7930          * As it is, perl is occasionally looking for dev:[000000]tty.
7931          * which looks a little strange.
7932          *
7933          * Not that easy to detect as "/dev" may be file structured with
7934          * special device files.
7935          */
7936
7937         if ((add_6zero == 0) && (*nextslash == '/') &&
7938             (&nextslash[1] == unixend)) {
7939           /* No real directory present */
7940           add_6zero = 1;
7941         }
7942       }
7943
7944       /* Put the device delimiter on */
7945       *vmsptr++ = ':';
7946       vmslen++;
7947       unixptr = nextslash;
7948       unixptr++;
7949
7950       /* Start directory if needed */
7951       if (!islnm || add_6zero) {
7952         *vmsptr++ = '[';
7953         vmslen++;
7954         dir_start = 1;
7955       }
7956
7957       /* add fake 000000] if needed */
7958       if (add_6zero) {
7959         *vmsptr++ = '0';
7960         *vmsptr++ = '0';
7961         *vmsptr++ = '0';
7962         *vmsptr++ = '0';
7963         *vmsptr++ = '0';
7964         *vmsptr++ = '0';
7965         *vmsptr++ = ']';
7966         vmslen += 7;
7967         dir_start = 0;
7968       }
7969
7970     } /* non-POSIX translation */
7971     PerlMem_free(esa);
7972   } /* End of relative/absolute path handling */
7973
7974   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
7975   int dash_flag;
7976   int in_cnt;
7977   int out_cnt;
7978
7979     dash_flag = 0;
7980
7981     if (dir_start != 0) {
7982
7983       /* First characters in a directory are handled special */
7984       while ((*unixptr == '/') ||
7985              ((*unixptr == '.') &&
7986               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
7987                 (&unixptr[1]==unixend)))) {
7988       int loop_flag;
7989
7990         loop_flag = 0;
7991
7992         /* Skip redundant / in specification */
7993         while ((*unixptr == '/') && (dir_start != 0)) {
7994           loop_flag = 1;
7995           unixptr++;
7996           if (unixptr == lastslash)
7997             break;
7998         }
7999         if (unixptr == lastslash)
8000           break;
8001
8002         /* Skip redundant ./ characters */
8003         while ((*unixptr == '.') &&
8004                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8005           loop_flag = 1;
8006           unixptr++;
8007           if (unixptr == lastslash)
8008             break;
8009           if (*unixptr == '/')
8010             unixptr++;
8011         }
8012         if (unixptr == lastslash)
8013           break;
8014
8015         /* Skip redundant ../ characters */
8016         while ((*unixptr == '.') && (unixptr[1] == '.') &&
8017              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8018           /* Set the backing up flag */
8019           loop_flag = 1;
8020           dir_dot = 0;
8021           dash_flag = 1;
8022           *vmsptr++ = '-';
8023           vmslen++;
8024           unixptr++; /* first . */
8025           unixptr++; /* second . */
8026           if (unixptr == lastslash)
8027             break;
8028           if (*unixptr == '/') /* The slash */
8029             unixptr++;
8030         }
8031         if (unixptr == lastslash)
8032           break;
8033
8034         /* To do: Perl expects /.../ to be translated to [...] on VMS */
8035         /* Not needed when VMS is pretending to be UNIX. */
8036
8037         /* Is this loop stuck because of too many dots? */
8038         if (loop_flag == 0) {
8039           /* Exit the loop and pass the rest through */
8040           break;
8041         }
8042       }
8043
8044       /* Are we done with directories yet? */
8045       if (unixptr >= lastslash) {
8046
8047         /* Watch out for trailing dots */
8048         if (dir_dot != 0) {
8049             vmslen --;
8050             vmsptr--;
8051         }
8052         *vmsptr++ = ']';
8053         vmslen++;
8054         dash_flag = 0;
8055         dir_start = 0;
8056         if (*unixptr == '/')
8057           unixptr++;
8058       }
8059       else {
8060         /* Have we stopped backing up? */
8061         if (dash_flag) {
8062           *vmsptr++ = '.';
8063           vmslen++;
8064           dash_flag = 0;
8065           /* dir_start continues to be = 1 */
8066         }
8067         if (*unixptr == '-') {
8068           *vmsptr++ = '^';
8069           *vmsptr++ = *unixptr++;
8070           vmslen += 2;
8071           dir_start = 0;
8072
8073           /* Now are we done with directories yet? */
8074           if (unixptr >= lastslash) {
8075
8076             /* Watch out for trailing dots */
8077             if (dir_dot != 0) {
8078               vmslen --;
8079               vmsptr--;
8080             }
8081
8082             *vmsptr++ = ']';
8083             vmslen++;
8084             dash_flag = 0;
8085             dir_start = 0;
8086           }
8087         }
8088       }
8089     }
8090
8091     /* All done? */
8092     if (unixptr >= unixend)
8093       break;
8094
8095     /* Normal characters - More EFS work probably needed */
8096     dir_start = 0;
8097     dir_dot = 0;
8098
8099     switch(*unixptr) {
8100     case '/':
8101         /* remove multiple / */
8102         while (unixptr[1] == '/') {
8103            unixptr++;
8104         }
8105         if (unixptr == lastslash) {
8106           /* Watch out for trailing dots */
8107           if (dir_dot != 0) {
8108             vmslen --;
8109             vmsptr--;
8110           }
8111           *vmsptr++ = ']';
8112         }
8113         else {
8114           dir_start = 1;
8115           *vmsptr++ = '.';
8116           dir_dot = 1;
8117
8118           /* To do: Perl expects /.../ to be translated to [...] on VMS */
8119           /* Not needed when VMS is pretending to be UNIX. */
8120
8121         }
8122         dash_flag = 0;
8123         if (unixptr != unixend)
8124           unixptr++;
8125         vmslen++;
8126         break;
8127     case '.':
8128         if ((unixptr < lastdot) || (unixptr < lastslash) ||
8129             (&unixptr[1] == unixend)) {
8130           *vmsptr++ = '^';
8131           *vmsptr++ = '.';
8132           vmslen += 2;
8133           unixptr++;
8134
8135           /* trailing dot ==> '^..' on VMS */
8136           if (unixptr == unixend) {
8137             *vmsptr++ = '.';
8138             vmslen++;
8139             unixptr++;
8140           }
8141           break;
8142         }
8143
8144         *vmsptr++ = *unixptr++;
8145         vmslen ++;
8146         break;
8147     case '"':
8148         if (quoted && (&unixptr[1] == unixend)) {
8149             unixptr++;
8150             break;
8151         }
8152         in_cnt = copy_expand_unix_filename_escape
8153                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8154         vmsptr += out_cnt;
8155         unixptr += in_cnt;
8156         break;
8157     case '~':
8158     case ';':
8159     case '\\':
8160     case '?':
8161     case ' ':
8162     default:
8163         in_cnt = copy_expand_unix_filename_escape
8164                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8165         vmsptr += out_cnt;
8166         unixptr += in_cnt;
8167         break;
8168     }
8169   }
8170
8171   /* Make sure directory is closed */
8172   if (unixptr == lastslash) {
8173     char *vmsptr2;
8174     vmsptr2 = vmsptr - 1;
8175
8176     if (*vmsptr2 != ']') {
8177       *vmsptr2--;
8178
8179       /* directories do not end in a dot bracket */
8180       if (*vmsptr2 == '.') {
8181         vmsptr2--;
8182
8183         /* ^. is allowed */
8184         if (*vmsptr2 != '^') {
8185           vmsptr--; /* back up over the dot */
8186         }
8187       }
8188       *vmsptr++ = ']';
8189     }
8190   }
8191   else {
8192     char *vmsptr2;
8193     /* Add a trailing dot if a file with no extension */
8194     vmsptr2 = vmsptr - 1;
8195     if ((vmslen > 1) &&
8196         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8197         (*vmsptr2 != ')') && (*lastdot != '.')) {
8198         *vmsptr++ = '.';
8199         vmslen++;
8200     }
8201   }
8202
8203   *vmsptr = '\0';
8204   return SS$_NORMAL;
8205 }
8206 #endif
8207
8208  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
8209 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
8210 {
8211 char * result;
8212 int utf8_flag;
8213
8214    /* If a UTF8 flag is being passed, honor it */
8215    utf8_flag = 0;
8216    if (utf8_fl != NULL) {
8217      utf8_flag = *utf8_fl;
8218     *utf8_fl = 0;
8219    }
8220
8221    if (utf8_flag) {
8222      /* If there is a possibility of UTF8, then if any UTF8 characters
8223         are present, then they must be converted to VTF-7
8224       */
8225      result = strcpy(rslt, path); /* FIX-ME */
8226    }
8227    else
8228      result = strcpy(rslt, path);
8229
8230    return result;
8231 }
8232
8233
8234
8235 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8236 static char *int_tovmsspec
8237    (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
8238   char *dirend;
8239   char *lastdot;
8240   char *vms_delim;
8241   register char *cp1;
8242   const char *cp2;
8243   unsigned long int infront = 0, hasdir = 1;
8244   int rslt_len;
8245   int no_type_seen;
8246   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8247   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8248
8249   if (vms_debug_fileify) {
8250       if (path == NULL)
8251           fprintf(stderr, "int_tovmsspec: path = NULL\n");
8252       else
8253           fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8254   }
8255
8256   if (path == NULL) {
8257       /* If we fail, we should be setting errno */
8258       set_errno(EINVAL);
8259       set_vaxc_errno(SS$_BADPARAM);
8260       return NULL;
8261   }
8262   rslt_len = VMS_MAXRSS-1;
8263
8264   /* '.' and '..' are "[]" and "[-]" for a quick check */
8265   if (path[0] == '.') {
8266     if (path[1] == '\0') {
8267       strcpy(rslt,"[]");
8268       if (utf8_flag != NULL)
8269         *utf8_flag = 0;
8270       return rslt;
8271     }
8272     else {
8273       if (path[1] == '.' && path[2] == '\0') {
8274         strcpy(rslt,"[-]");
8275         if (utf8_flag != NULL)
8276            *utf8_flag = 0;
8277         return rslt;
8278       }
8279     }
8280   }
8281
8282    /* Posix specifications are now a native VMS format */
8283   /*--------------------------------------------------*/
8284 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8285   if (decc_posix_compliant_pathnames) {
8286     if (strncmp(path,"\"^UP^",5) == 0) {
8287       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8288       return rslt;
8289     }
8290   }
8291 #endif
8292
8293   /* This is really the only way to see if this is already in VMS format */
8294   sts = vms_split_path
8295        (path,
8296         &v_spec,
8297         &v_len,
8298         &r_spec,
8299         &r_len,
8300         &d_spec,
8301         &d_len,
8302         &n_spec,
8303         &n_len,
8304         &e_spec,
8305         &e_len,
8306         &vs_spec,
8307         &vs_len);
8308   if (sts == 0) {
8309     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8310        replacement, because the above parse just took care of most of
8311        what is needed to do vmspath when the specification is already
8312        in VMS format.
8313
8314        And if it is not already, it is easier to do the conversion as
8315        part of this routine than to call this routine and then work on
8316        the result.
8317      */
8318
8319     /* If VMS punctuation was found, it is already VMS format */
8320     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8321       if (utf8_flag != NULL)
8322         *utf8_flag = 0;
8323       strcpy(rslt, path);
8324       if (vms_debug_fileify) {
8325           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8326       }
8327       return rslt;
8328     }
8329     /* Now, what to do with trailing "." cases where there is no
8330        extension?  If this is a UNIX specification, and EFS characters
8331        are enabled, then the trailing "." should be converted to a "^.".
8332        But if this was already a VMS specification, then it should be
8333        left alone.
8334
8335        So in the case of ambiguity, leave the specification alone.
8336      */
8337
8338
8339     /* If there is a possibility of UTF8, then if any UTF8 characters
8340         are present, then they must be converted to VTF-7
8341      */
8342     if (utf8_flag != NULL)
8343       *utf8_flag = 0;
8344     strcpy(rslt, path);
8345     if (vms_debug_fileify) {
8346         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8347     }
8348     return rslt;
8349   }
8350
8351   dirend = strrchr(path,'/');
8352
8353   if (dirend == NULL) {
8354      char *macro_start;
8355      int has_macro;
8356
8357      /* If we get here with no UNIX directory delimiters, then this is
8358         not a complete file specification, either garbage a UNIX glob
8359         specification that can not be converted to a VMS wildcard, or
8360         it a UNIX shell macro.  MakeMaker wants shell macros passed
8361         through AS-IS,
8362
8363         utf8 flag setting needs to be preserved.
8364       */
8365       hasdir = 0;
8366
8367       has_macro = 0;
8368       macro_start = strchr(path,'$');
8369       if (macro_start != NULL) {
8370           if (macro_start[1] == '(') {
8371               has_macro = 1;
8372           }
8373       }
8374       if ((decc_efs_charset == 0) || (has_macro)) {
8375           strcpy(rslt, path);
8376           if (vms_debug_fileify) {
8377               fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8378           }
8379           return rslt;
8380       }
8381   }
8382
8383 /* If POSIX mode active, handle the conversion */
8384 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8385   if (decc_efs_charset) {
8386     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8387     if (vms_debug_fileify) {
8388         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8389     }
8390     return rslt;
8391   }
8392 #endif
8393
8394   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
8395     if (!*(dirend+2)) dirend +=2;
8396     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8397     if (decc_efs_charset == 0) {
8398       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8399     }
8400   }
8401
8402   cp1 = rslt;
8403   cp2 = path;
8404   lastdot = strrchr(cp2,'.');
8405   if (*cp2 == '/') {
8406     char *trndev;
8407     int islnm, rooted;
8408     STRLEN trnend;
8409
8410     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8411     if (!*(cp2+1)) {
8412       if (decc_disable_posix_root) {
8413         strcpy(rslt,"sys$disk:[000000]");
8414       }
8415       else {
8416         strcpy(rslt,"sys$posix_root:[000000]");
8417       }
8418       if (utf8_flag != NULL)
8419         *utf8_flag = 0;
8420       if (vms_debug_fileify) {
8421           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8422       }
8423       return rslt;
8424     }
8425     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8426     *cp1 = '\0';
8427     trndev = PerlMem_malloc(VMS_MAXRSS);
8428     if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8429     islnm =  simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8430
8431      /* DECC special handling */
8432     if (!islnm) {
8433       if (strcmp(rslt,"bin") == 0) {
8434         strcpy(rslt,"sys$system");
8435         cp1 = rslt + 10;
8436         *cp1 = 0;
8437         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8438       }
8439       else if (strcmp(rslt,"tmp") == 0) {
8440         strcpy(rslt,"sys$scratch");
8441         cp1 = rslt + 11;
8442         *cp1 = 0;
8443         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8444       }
8445       else if (!decc_disable_posix_root) {
8446         strcpy(rslt, "sys$posix_root");
8447         cp1 = rslt + 14;
8448         *cp1 = 0;
8449         cp2 = path;
8450         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8451         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8452       }
8453       else if (strcmp(rslt,"dev") == 0) {
8454         if (strncmp(cp2,"/null", 5) == 0) {
8455           if ((cp2[5] == 0) || (cp2[5] == '/')) {
8456             strcpy(rslt,"NLA0");
8457             cp1 = rslt + 4;
8458             *cp1 = 0;
8459             cp2 = cp2 + 5;
8460             islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8461           }
8462         }
8463       }
8464     }
8465
8466     trnend = islnm ? strlen(trndev) - 1 : 0;
8467     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8468     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8469     /* If the first element of the path is a logical name, determine
8470      * whether it has to be translated so we can add more directories. */
8471     if (!islnm || rooted) {
8472       *(cp1++) = ':';
8473       *(cp1++) = '[';
8474       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8475       else cp2++;
8476     }
8477     else {
8478       if (cp2 != dirend) {
8479         strcpy(rslt,trndev);
8480         cp1 = rslt + trnend;
8481         if (*cp2 != 0) {
8482           *(cp1++) = '.';
8483           cp2++;
8484         }
8485       }
8486       else {
8487         if (decc_disable_posix_root) {
8488           *(cp1++) = ':';
8489           hasdir = 0;
8490         }
8491       }
8492     }
8493     PerlMem_free(trndev);
8494   }
8495   else {
8496     *(cp1++) = '[';
8497     if (*cp2 == '.') {
8498       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8499         cp2 += 2;         /* skip over "./" - it's redundant */
8500         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8501       }
8502       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8503         *(cp1++) = '-';                                 /* "../" --> "-" */
8504         cp2 += 3;
8505       }
8506       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8507                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8508         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8509         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8510         cp2 += 4;
8511       }
8512       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8513         /* Escape the extra dots in EFS file specifications */
8514         *(cp1++) = '^';
8515       }
8516       if (cp2 > dirend) cp2 = dirend;
8517     }
8518     else *(cp1++) = '.';
8519   }
8520   for (; cp2 < dirend; cp2++) {
8521     if (*cp2 == '/') {
8522       if (*(cp2-1) == '/') continue;
8523       if (*(cp1-1) != '.') *(cp1++) = '.';
8524       infront = 0;
8525     }
8526     else if (!infront && *cp2 == '.') {
8527       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8528       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8529       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8530         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8531         else if (*(cp1-2) == '[') *(cp1-1) = '-';
8532         else {  /* back up over previous directory name */
8533           cp1--;
8534           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
8535           if (*(cp1-1) == '[') {
8536             memcpy(cp1,"000000.",7);
8537             cp1 += 7;
8538           }
8539         }
8540         cp2 += 2;
8541         if (cp2 == dirend) break;
8542       }
8543       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8544                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8545         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8546         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8547         if (!*(cp2+3)) {
8548           *(cp1++) = '.';  /* Simulate trailing '/' */
8549           cp2 += 2;  /* for loop will incr this to == dirend */
8550         }
8551         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8552       }
8553       else {
8554         if (decc_efs_charset == 0)
8555           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8556         else {
8557           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
8558           *(cp1++) = '.';
8559         }
8560       }
8561     }
8562     else {
8563       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
8564       if (*cp2 == '.') {
8565         if (decc_efs_charset == 0)
8566           *(cp1++) = '_';
8567         else {
8568           *(cp1++) = '^';
8569           *(cp1++) = '.';
8570         }
8571       }
8572       else                  *(cp1++) =  *cp2;
8573       infront = 1;
8574     }
8575   }
8576   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8577   if (hasdir) *(cp1++) = ']';
8578   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
8579   /* fixme for ODS5 */
8580   no_type_seen = 0;
8581   if (cp2 > lastdot)
8582     no_type_seen = 1;
8583   while (*cp2) {
8584     switch(*cp2) {
8585     case '?':
8586         if (decc_efs_charset == 0)
8587           *(cp1++) = '%';
8588         else
8589           *(cp1++) = '?';
8590         cp2++;
8591     case ' ':
8592         *(cp1)++ = '^';
8593         *(cp1)++ = '_';
8594         cp2++;
8595         break;
8596     case '.':
8597         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8598             decc_readdir_dropdotnotype) {
8599           *(cp1)++ = '^';
8600           *(cp1)++ = '.';
8601           cp2++;
8602
8603           /* trailing dot ==> '^..' on VMS */
8604           if (*cp2 == '\0') {
8605             *(cp1++) = '.';
8606             no_type_seen = 0;
8607           }
8608         }
8609         else {
8610           *(cp1++) = *(cp2++);
8611           no_type_seen = 0;
8612         }
8613         break;
8614     case '$':
8615          /* This could be a macro to be passed through */
8616         *(cp1++) = *(cp2++);
8617         if (*cp2 == '(') {
8618         const char * save_cp2;
8619         char * save_cp1;
8620         int is_macro;
8621
8622             /* paranoid check */
8623             save_cp2 = cp2;
8624             save_cp1 = cp1;
8625             is_macro = 0;
8626
8627             /* Test through */
8628             *(cp1++) = *(cp2++);
8629             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8630                 *(cp1++) = *(cp2++);
8631                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8632                     *(cp1++) = *(cp2++);
8633                 }
8634                 if (*cp2 == ')') {
8635                     *(cp1++) = *(cp2++);
8636                     is_macro = 1;
8637                 }
8638             }
8639             if (is_macro == 0) {
8640                 /* Not really a macro - never mind */
8641                 cp2 = save_cp2;
8642                 cp1 = save_cp1;
8643             }
8644         }
8645         break;
8646     case '\"':
8647     case '~':
8648     case '`':
8649     case '!':
8650     case '#':
8651     case '%':
8652     case '^':
8653         /* Don't escape again if following character is
8654          * already something we escape.
8655          */
8656         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8657             *(cp1++) = *(cp2++);
8658             break;
8659         }
8660         /* But otherwise fall through and escape it. */
8661     case '&':
8662     case '(':
8663     case ')':
8664     case '=':
8665     case '+':
8666     case '\'':
8667     case '@':
8668     case '[':
8669     case ']':
8670     case '{':
8671     case '}':
8672     case ':':
8673     case '\\':
8674     case '|':
8675     case '<':
8676     case '>':
8677         *(cp1++) = '^';
8678         *(cp1++) = *(cp2++);
8679         break;
8680     case ';':
8681         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8682          * which is wrong.  UNIX notation should be ".dir." unless
8683          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8684          * changing this behavior could break more things at this time.
8685          * efs character set effectively does not allow "." to be a version
8686          * delimiter as a further complication about changing this.
8687          */
8688         if (decc_filename_unix_report != 0) {
8689           *(cp1++) = '^';
8690         }
8691         *(cp1++) = *(cp2++);
8692         break;
8693     default:
8694         *(cp1++) = *(cp2++);
8695     }
8696   }
8697   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8698   char *lcp1;
8699     lcp1 = cp1;
8700     lcp1--;
8701      /* Fix me for "^]", but that requires making sure that you do
8702       * not back up past the start of the filename
8703       */
8704     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8705       *cp1++ = '.';
8706   }
8707   *cp1 = '\0';
8708
8709   if (utf8_flag != NULL)
8710     *utf8_flag = 0;
8711   if (vms_debug_fileify) {
8712       fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8713   }
8714   return rslt;
8715
8716 }  /* end of int_tovmsspec() */
8717
8718
8719 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8720 static char *mp_do_tovmsspec
8721    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
8722   static char __tovmsspec_retbuf[VMS_MAXRSS];
8723     char * vmsspec, *ret_spec, *ret_buf;
8724
8725     vmsspec = NULL;
8726     ret_buf = buf;
8727     if (ret_buf == NULL) {
8728         if (ts) {
8729             Newx(vmsspec, VMS_MAXRSS, char);
8730             if (vmsspec == NULL)
8731                 _ckvmssts(SS$_INSFMEM);
8732             ret_buf = vmsspec;
8733         } else {
8734             ret_buf = __tovmsspec_retbuf;
8735         }
8736     }
8737
8738     ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
8739
8740     if (ret_spec == NULL) {
8741        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
8742        if (vmsspec)
8743            Safefree(vmsspec);
8744     }
8745
8746     return ret_spec;
8747
8748 }  /* end of mp_do_tovmsspec() */
8749 /*}}}*/
8750 /* External entry points */
8751 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8752   { return do_tovmsspec(path,buf,0,NULL); }
8753 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8754   { return do_tovmsspec(path,buf,1,NULL); }
8755 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8756   { return do_tovmsspec(path,buf,0,utf8_fl); }
8757 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8758   { return do_tovmsspec(path,buf,1,utf8_fl); }
8759
8760 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8761 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8762   static char __tovmspath_retbuf[VMS_MAXRSS];
8763   int vmslen;
8764   char *pathified, *vmsified, *cp;
8765
8766   if (path == NULL) return NULL;
8767   pathified = PerlMem_malloc(VMS_MAXRSS);
8768   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8769   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
8770     PerlMem_free(pathified);
8771     return NULL;
8772   }
8773
8774   vmsified = NULL;
8775   if (buf == NULL)
8776      Newx(vmsified, VMS_MAXRSS, char);
8777   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8778     PerlMem_free(pathified);
8779     if (vmsified) Safefree(vmsified);
8780     return NULL;
8781   }
8782   PerlMem_free(pathified);
8783   if (buf) {
8784     return buf;
8785   }
8786   else if (ts) {
8787     vmslen = strlen(vmsified);
8788     Newx(cp,vmslen+1,char);
8789     memcpy(cp,vmsified,vmslen);
8790     cp[vmslen] = '\0';
8791     Safefree(vmsified);
8792     return cp;
8793   }
8794   else {
8795     strcpy(__tovmspath_retbuf,vmsified);
8796     Safefree(vmsified);
8797     return __tovmspath_retbuf;
8798   }
8799
8800 }  /* end of do_tovmspath() */
8801 /*}}}*/
8802 /* External entry points */
8803 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8804   { return do_tovmspath(path,buf,0, NULL); }
8805 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8806   { return do_tovmspath(path,buf,1, NULL); }
8807 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8808   { return do_tovmspath(path,buf,0,utf8_fl); }
8809 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8810   { return do_tovmspath(path,buf,1,utf8_fl); }
8811
8812
8813 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8814 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8815   static char __tounixpath_retbuf[VMS_MAXRSS];
8816   int unixlen;
8817   char *pathified, *unixified, *cp;
8818
8819   if (path == NULL) return NULL;
8820   pathified = PerlMem_malloc(VMS_MAXRSS);
8821   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8822   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
8823     PerlMem_free(pathified);
8824     return NULL;
8825   }
8826
8827   unixified = NULL;
8828   if (buf == NULL) {
8829       Newx(unixified, VMS_MAXRSS, char);
8830   }
8831   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
8832     PerlMem_free(pathified);
8833     if (unixified) Safefree(unixified);
8834     return NULL;
8835   }
8836   PerlMem_free(pathified);
8837   if (buf) {
8838     return buf;
8839   }
8840   else if (ts) {
8841     unixlen = strlen(unixified);
8842     Newx(cp,unixlen+1,char);
8843     memcpy(cp,unixified,unixlen);
8844     cp[unixlen] = '\0';
8845     Safefree(unixified);
8846     return cp;
8847   }
8848   else {
8849     strcpy(__tounixpath_retbuf,unixified);
8850     Safefree(unixified);
8851     return __tounixpath_retbuf;
8852   }
8853
8854 }  /* end of do_tounixpath() */
8855 /*}}}*/
8856 /* External entry points */
8857 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8858   { return do_tounixpath(path,buf,0,NULL); }
8859 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8860   { return do_tounixpath(path,buf,1,NULL); }
8861 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8862   { return do_tounixpath(path,buf,0,utf8_fl); }
8863 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8864   { return do_tounixpath(path,buf,1,utf8_fl); }
8865
8866 /*
8867  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
8868  *
8869  *****************************************************************************
8870  *                                                                           *
8871  *  Copyright (C) 1989-1994, 2007 by                                         *
8872  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
8873  *                                                                           *
8874  *  Permission is hereby granted for the reproduction of this software       *
8875  *  on condition that this copyright notice is included in source            *
8876  *  distributions of the software.  The code may be modified and             *
8877  *  distributed under the same terms as Perl itself.                         *
8878  *                                                                           *
8879  *  27-Aug-1994 Modified for inclusion in perl5                              *
8880  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
8881  *****************************************************************************
8882  */
8883
8884 /*
8885  * getredirection() is intended to aid in porting C programs
8886  * to VMS (Vax-11 C).  The native VMS environment does not support
8887  * '>' and '<' I/O redirection, or command line wild card expansion,
8888  * or a command line pipe mechanism using the '|' AND background
8889  * command execution '&'.  All of these capabilities are provided to any
8890  * C program which calls this procedure as the first thing in the
8891  * main program.
8892  * The piping mechanism will probably work with almost any 'filter' type
8893  * of program.  With suitable modification, it may useful for other
8894  * portability problems as well.
8895  *
8896  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
8897  */
8898 struct list_item
8899     {
8900     struct list_item *next;
8901     char *value;
8902     };
8903
8904 static void add_item(struct list_item **head,
8905                      struct list_item **tail,
8906                      char *value,
8907                      int *count);
8908
8909 static void mp_expand_wild_cards(pTHX_ char *item,
8910                                 struct list_item **head,
8911                                 struct list_item **tail,
8912                                 int *count);
8913
8914 static int background_process(pTHX_ int argc, char **argv);
8915
8916 static void pipe_and_fork(pTHX_ char **cmargv);
8917
8918 /*{{{ void getredirection(int *ac, char ***av)*/
8919 static void
8920 mp_getredirection(pTHX_ int *ac, char ***av)
8921 /*
8922  * Process vms redirection arg's.  Exit if any error is seen.
8923  * If getredirection() processes an argument, it is erased
8924  * from the vector.  getredirection() returns a new argc and argv value.
8925  * In the event that a background command is requested (by a trailing "&"),
8926  * this routine creates a background subprocess, and simply exits the program.
8927  *
8928  * Warning: do not try to simplify the code for vms.  The code
8929  * presupposes that getredirection() is called before any data is
8930  * read from stdin or written to stdout.
8931  *
8932  * Normal usage is as follows:
8933  *
8934  *      main(argc, argv)
8935  *      int             argc;
8936  *      char            *argv[];
8937  *      {
8938  *              getredirection(&argc, &argv);
8939  *      }
8940  */
8941 {
8942     int                 argc = *ac;     /* Argument Count         */
8943     char                **argv = *av;   /* Argument Vector        */
8944     char                *ap;            /* Argument pointer       */
8945     int                 j;              /* argv[] index           */
8946     int                 item_count = 0; /* Count of Items in List */
8947     struct list_item    *list_head = 0; /* First Item in List       */
8948     struct list_item    *list_tail;     /* Last Item in List        */
8949     char                *in = NULL;     /* Input File Name          */
8950     char                *out = NULL;    /* Output File Name         */
8951     char                *outmode = "w"; /* Mode to Open Output File */
8952     char                *err = NULL;    /* Error File Name          */
8953     char                *errmode = "w"; /* Mode to Open Error File  */
8954     int                 cmargc = 0;     /* Piped Command Arg Count  */
8955     char                **cmargv = NULL;/* Piped Command Arg Vector */
8956
8957     /*
8958      * First handle the case where the last thing on the line ends with
8959      * a '&'.  This indicates the desire for the command to be run in a
8960      * subprocess, so we satisfy that desire.
8961      */
8962     ap = argv[argc-1];
8963     if (0 == strcmp("&", ap))
8964        exit(background_process(aTHX_ --argc, argv));
8965     if (*ap && '&' == ap[strlen(ap)-1])
8966         {
8967         ap[strlen(ap)-1] = '\0';
8968        exit(background_process(aTHX_ argc, argv));
8969         }
8970     /*
8971      * Now we handle the general redirection cases that involve '>', '>>',
8972      * '<', and pipes '|'.
8973      */
8974     for (j = 0; j < argc; ++j)
8975         {
8976         if (0 == strcmp("<", argv[j]))
8977             {
8978             if (j+1 >= argc)
8979                 {
8980                 fprintf(stderr,"No input file after < on command line");
8981                 exit(LIB$_WRONUMARG);
8982                 }
8983             in = argv[++j];
8984             continue;
8985             }
8986         if ('<' == *(ap = argv[j]))
8987             {
8988             in = 1 + ap;
8989             continue;
8990             }
8991         if (0 == strcmp(">", ap))
8992             {
8993             if (j+1 >= argc)
8994                 {
8995                 fprintf(stderr,"No output file after > on command line");
8996                 exit(LIB$_WRONUMARG);
8997                 }
8998             out = argv[++j];
8999             continue;
9000             }
9001         if ('>' == *ap)
9002             {
9003             if ('>' == ap[1])
9004                 {
9005                 outmode = "a";
9006                 if ('\0' == ap[2])
9007                     out = argv[++j];
9008                 else
9009                     out = 2 + ap;
9010                 }
9011             else
9012                 out = 1 + ap;
9013             if (j >= argc)
9014                 {
9015                 fprintf(stderr,"No output file after > or >> on command line");
9016                 exit(LIB$_WRONUMARG);
9017                 }
9018             continue;
9019             }
9020         if (('2' == *ap) && ('>' == ap[1]))
9021             {
9022             if ('>' == ap[2])
9023                 {
9024                 errmode = "a";
9025                 if ('\0' == ap[3])
9026                     err = argv[++j];
9027                 else
9028                     err = 3 + ap;
9029                 }
9030             else
9031                 if ('\0' == ap[2])
9032                     err = argv[++j];
9033                 else
9034                     err = 2 + ap;
9035             if (j >= argc)
9036                 {
9037                 fprintf(stderr,"No output file after 2> or 2>> on command line");
9038                 exit(LIB$_WRONUMARG);
9039                 }
9040             continue;
9041             }
9042         if (0 == strcmp("|", argv[j]))
9043             {
9044             if (j+1 >= argc)
9045                 {
9046                 fprintf(stderr,"No command into which to pipe on command line");
9047                 exit(LIB$_WRONUMARG);
9048                 }
9049             cmargc = argc-(j+1);
9050             cmargv = &argv[j+1];
9051             argc = j;
9052             continue;
9053             }
9054         if ('|' == *(ap = argv[j]))
9055             {
9056             ++argv[j];
9057             cmargc = argc-j;
9058             cmargv = &argv[j];
9059             argc = j;
9060             continue;
9061             }
9062         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9063         }
9064     /*
9065      * Allocate and fill in the new argument vector, Some Unix's terminate
9066      * the list with an extra null pointer.
9067      */
9068     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9069     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9070     *av = argv;
9071     for (j = 0; j < item_count; ++j, list_head = list_head->next)
9072         argv[j] = list_head->value;
9073     *ac = item_count;
9074     if (cmargv != NULL)
9075         {
9076         if (out != NULL)
9077             {
9078             fprintf(stderr,"'|' and '>' may not both be specified on command line");
9079             exit(LIB$_INVARGORD);
9080             }
9081         pipe_and_fork(aTHX_ cmargv);
9082         }
9083
9084     /* Check for input from a pipe (mailbox) */
9085
9086     if (in == NULL && 1 == isapipe(0))
9087         {
9088         char mbxname[L_tmpnam];
9089         long int bufsize;
9090         long int dvi_item = DVI$_DEVBUFSIZ;
9091         $DESCRIPTOR(mbxnam, "");
9092         $DESCRIPTOR(mbxdevnam, "");
9093
9094         /* Input from a pipe, reopen it in binary mode to disable       */
9095         /* carriage control processing.                                 */
9096
9097         fgetname(stdin, mbxname);
9098         mbxnam.dsc$a_pointer = mbxname;
9099         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9100         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9101         mbxdevnam.dsc$a_pointer = mbxname;
9102         mbxdevnam.dsc$w_length = sizeof(mbxname);
9103         dvi_item = DVI$_DEVNAM;
9104         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9105         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9106         set_errno(0);
9107         set_vaxc_errno(1);
9108         freopen(mbxname, "rb", stdin);
9109         if (errno != 0)
9110             {
9111             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9112             exit(vaxc$errno);
9113             }
9114         }
9115     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9116         {
9117         fprintf(stderr,"Can't open input file %s as stdin",in);
9118         exit(vaxc$errno);
9119         }
9120     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9121         {
9122         fprintf(stderr,"Can't open output file %s as stdout",out);
9123         exit(vaxc$errno);
9124         }
9125         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
9126
9127     if (err != NULL) {
9128         if (strcmp(err,"&1") == 0) {
9129             dup2(fileno(stdout), fileno(stderr));
9130             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
9131         } else {
9132         FILE *tmperr;
9133         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9134             {
9135             fprintf(stderr,"Can't open error file %s as stderr",err);
9136             exit(vaxc$errno);
9137             }
9138             fclose(tmperr);
9139            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9140                 {
9141                 exit(vaxc$errno);
9142                 }
9143             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
9144         }
9145         }
9146 #ifdef ARGPROC_DEBUG
9147     PerlIO_printf(Perl_debug_log, "Arglist:\n");
9148     for (j = 0; j < *ac;  ++j)
9149         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9150 #endif
9151    /* Clear errors we may have hit expanding wildcards, so they don't
9152       show up in Perl's $! later */
9153    set_errno(0); set_vaxc_errno(1);
9154 }  /* end of getredirection() */
9155 /*}}}*/
9156
9157 static void add_item(struct list_item **head,
9158                      struct list_item **tail,
9159                      char *value,
9160                      int *count)
9161 {
9162     if (*head == 0)
9163         {
9164         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9165         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9166         *tail = *head;
9167         }
9168     else {
9169         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9170         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9171         *tail = (*tail)->next;
9172         }
9173     (*tail)->value = value;
9174     ++(*count);
9175 }
9176
9177 static void mp_expand_wild_cards(pTHX_ char *item,
9178                               struct list_item **head,
9179                               struct list_item **tail,
9180                               int *count)
9181 {
9182 int expcount = 0;
9183 unsigned long int context = 0;
9184 int isunix = 0;
9185 int item_len = 0;
9186 char *had_version;
9187 char *had_device;
9188 int had_directory;
9189 char *devdir,*cp;
9190 char *vmsspec;
9191 $DESCRIPTOR(filespec, "");
9192 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9193 $DESCRIPTOR(resultspec, "");
9194 unsigned long int lff_flags = 0;
9195 int sts;
9196 int rms_sts;
9197
9198 #ifdef VMS_LONGNAME_SUPPORT
9199     lff_flags = LIB$M_FIL_LONG_NAMES;
9200 #endif
9201
9202     for (cp = item; *cp; cp++) {
9203         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9204         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9205     }
9206     if (!*cp || isspace(*cp))
9207         {
9208         add_item(head, tail, item, count);
9209         return;
9210         }
9211     else
9212         {
9213      /* "double quoted" wild card expressions pass as is */
9214      /* From DCL that means using e.g.:                  */
9215      /* perl program """perl.*"""                        */
9216      item_len = strlen(item);
9217      if ( '"' == *item && '"' == item[item_len-1] )
9218        {
9219        item++;
9220        item[item_len-2] = '\0';
9221        add_item(head, tail, item, count);
9222        return;
9223        }
9224      }
9225     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9226     resultspec.dsc$b_class = DSC$K_CLASS_D;
9227     resultspec.dsc$a_pointer = NULL;
9228     vmsspec = PerlMem_malloc(VMS_MAXRSS);
9229     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9230     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9231       filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9232     if (!isunix || !filespec.dsc$a_pointer)
9233       filespec.dsc$a_pointer = item;
9234     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9235     /*
9236      * Only return version specs, if the caller specified a version
9237      */
9238     had_version = strchr(item, ';');
9239     /*
9240      * Only return device and directory specs, if the caller specifed either.
9241      */
9242     had_device = strchr(item, ':');
9243     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9244
9245     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9246                                  (&filespec, &resultspec, &context,
9247                                   &defaultspec, 0, &rms_sts, &lff_flags)))
9248         {
9249         char *string;
9250         char *c;
9251
9252         string = PerlMem_malloc(resultspec.dsc$w_length+1);
9253         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9254         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
9255         string[resultspec.dsc$w_length] = '\0';
9256         if (NULL == had_version)
9257             *(strrchr(string, ';')) = '\0';
9258         if ((!had_directory) && (had_device == NULL))
9259             {
9260             if (NULL == (devdir = strrchr(string, ']')))
9261                 devdir = strrchr(string, '>');
9262             strcpy(string, devdir + 1);
9263             }
9264         /*
9265          * Be consistent with what the C RTL has already done to the rest of
9266          * the argv items and lowercase all of these names.
9267          */
9268         if (!decc_efs_case_preserve) {
9269             for (c = string; *c; ++c)
9270             if (isupper(*c))
9271                 *c = tolower(*c);
9272         }
9273         if (isunix) trim_unixpath(string,item,1);
9274         add_item(head, tail, string, count);
9275         ++expcount;
9276     }
9277     PerlMem_free(vmsspec);
9278     if (sts != RMS$_NMF)
9279         {
9280         set_vaxc_errno(sts);
9281         switch (sts)
9282             {
9283             case RMS$_FNF: case RMS$_DNF:
9284                 set_errno(ENOENT); break;
9285             case RMS$_DIR:
9286                 set_errno(ENOTDIR); break;
9287             case RMS$_DEV:
9288                 set_errno(ENODEV); break;
9289             case RMS$_FNM: case RMS$_SYN:
9290                 set_errno(EINVAL); break;
9291             case RMS$_PRV:
9292                 set_errno(EACCES); break;
9293             default:
9294                 _ckvmssts_noperl(sts);
9295             }
9296         }
9297     if (expcount == 0)
9298         add_item(head, tail, item, count);
9299     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9300     _ckvmssts_noperl(lib$find_file_end(&context));
9301 }
9302
9303 static int child_st[2];/* Event Flag set when child process completes   */
9304
9305 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
9306
9307 static unsigned long int exit_handler(int *status)
9308 {
9309 short iosb[4];
9310
9311     if (0 == child_st[0])
9312         {
9313 #ifdef ARGPROC_DEBUG
9314         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
9315 #endif
9316         fflush(stdout);     /* Have to flush pipe for binary data to    */
9317                             /* terminate properly -- <tp@mccall.com>    */
9318         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
9319         sys$dassgn(child_chan);
9320         fclose(stdout);
9321         sys$synch(0, child_st);
9322         }
9323     return(1);
9324 }
9325
9326 static void sig_child(int chan)
9327 {
9328 #ifdef ARGPROC_DEBUG
9329     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
9330 #endif
9331     if (child_st[0] == 0)
9332         child_st[0] = 1;
9333 }
9334
9335 static struct exit_control_block exit_block =
9336     {
9337     0,
9338     exit_handler,
9339     1,
9340     &exit_block.exit_status,
9341     0
9342     };
9343
9344 static void
9345 pipe_and_fork(pTHX_ char **cmargv)
9346 {
9347     PerlIO *fp;
9348     struct dsc$descriptor_s *vmscmd;
9349     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9350     int sts, j, l, ismcr, quote, tquote = 0;
9351
9352     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9353     vms_execfree(vmscmd);
9354
9355     j = l = 0;
9356     p = subcmd;
9357     q = cmargv[0];
9358     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
9359               && toupper(*(q+2)) == 'R' && !*(q+3);
9360
9361     while (q && l < MAX_DCL_LINE_LENGTH) {
9362         if (!*q) {
9363             if (j > 0 && quote) {
9364                 *p++ = '"';
9365                 l++;
9366             }
9367             q = cmargv[++j];
9368             if (q) {
9369                 if (ismcr && j > 1) quote = 1;
9370                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
9371                 *p++ = ' ';
9372                 l++;
9373                 if (quote || tquote) {
9374                     *p++ = '"';
9375                     l++;
9376                 }
9377             }
9378         } else {
9379             if ((quote||tquote) && *q == '"') {
9380                 *p++ = '"';
9381                 l++;
9382             }
9383             *p++ = *q++;
9384             l++;
9385         }
9386     }
9387     *p = '\0';
9388
9389     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9390     if (fp == NULL) {
9391         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9392     }
9393 }
9394
9395 static int background_process(pTHX_ int argc, char **argv)
9396 {
9397 char command[MAX_DCL_SYMBOL + 1] = "$";
9398 $DESCRIPTOR(value, "");
9399 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9400 static $DESCRIPTOR(null, "NLA0:");
9401 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9402 char pidstring[80];
9403 $DESCRIPTOR(pidstr, "");
9404 int pid;
9405 unsigned long int flags = 17, one = 1, retsts;
9406 int len;
9407
9408     strcat(command, argv[0]);
9409     len = strlen(command);
9410     while (--argc && (len < MAX_DCL_SYMBOL))
9411         {
9412         strcat(command, " \"");
9413         strcat(command, *(++argv));
9414         strcat(command, "\"");
9415         len = strlen(command);
9416         }
9417     value.dsc$a_pointer = command;
9418     value.dsc$w_length = strlen(value.dsc$a_pointer);
9419     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9420     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9421     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9422         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9423     }
9424     else {
9425         _ckvmssts_noperl(retsts);
9426     }
9427 #ifdef ARGPROC_DEBUG
9428     PerlIO_printf(Perl_debug_log, "%s\n", command);
9429 #endif
9430     sprintf(pidstring, "%08X", pid);
9431     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9432     pidstr.dsc$a_pointer = pidstring;
9433     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9434     lib$set_symbol(&pidsymbol, &pidstr);
9435     return(SS$_NORMAL);
9436 }
9437 /*}}}*/
9438 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9439
9440
9441 /* OS-specific initialization at image activation (not thread startup) */
9442 /* Older VAXC header files lack these constants */
9443 #ifndef JPI$_RIGHTS_SIZE
9444 #  define JPI$_RIGHTS_SIZE 817
9445 #endif
9446 #ifndef KGB$M_SUBSYSTEM
9447 #  define KGB$M_SUBSYSTEM 0x8
9448 #endif
9449
9450 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9451
9452 /*{{{void vms_image_init(int *, char ***)*/
9453 void
9454 vms_image_init(int *argcp, char ***argvp)
9455 {
9456   int status;
9457   char eqv[LNM$C_NAMLENGTH+1] = "";
9458   unsigned int len, tabct = 8, tabidx = 0;
9459   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9460   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9461   unsigned short int dummy, rlen;
9462   struct dsc$descriptor_s **tabvec;
9463 #if defined(PERL_IMPLICIT_CONTEXT)
9464   pTHX = NULL;
9465 #endif
9466   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
9467                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
9468                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9469                                  {          0,                0,    0,      0} };
9470
9471 #ifdef KILL_BY_SIGPRC
9472     Perl_csighandler_init();
9473 #endif
9474
9475     /* This was moved from the pre-image init handler because on threaded */
9476     /* Perl it was always returning 0 for the default value. */
9477     status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9478     if (status > 0) {
9479         int s;
9480         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9481         if (s > 0) {
9482             int initial;
9483             initial = decc$feature_get_value(s, 4);
9484             if (initial > 0) {
9485                 /* initial is: 0 if nothing has set the feature */
9486                 /*            -1 if initialized to default */
9487                 /*             1 if set by logical name */
9488                 /*             2 if set by decc$feature_set_value */
9489                 decc_disable_posix_root = decc$feature_get_value(s, 1);
9490
9491                 /* If the value is not valid, force the feature off */
9492                 if (decc_disable_posix_root < 0) {
9493                     decc$feature_set_value(s, 1, 1);
9494                     decc_disable_posix_root = 1;
9495                 }
9496             }
9497             else {
9498                 /* Nothing has asked for it explicitly, so use our own default. */
9499                 decc_disable_posix_root = 1;
9500                 decc$feature_set_value(s, 1, 1);
9501             }
9502         }
9503     }
9504
9505
9506   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9507   _ckvmssts_noperl(iosb[0]);
9508   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9509     if (iprv[i]) {           /* Running image installed with privs? */
9510       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
9511       will_taint = TRUE;
9512       break;
9513     }
9514   }
9515   /* Rights identifiers might trigger tainting as well. */
9516   if (!will_taint && (rlen || rsz)) {
9517     while (rlen < rsz) {
9518       /* We didn't get all the identifiers on the first pass.  Allocate a
9519        * buffer much larger than $GETJPI wants (rsz is size in bytes that
9520        * were needed to hold all identifiers at time of last call; we'll
9521        * allocate that many unsigned long ints), and go back and get 'em.
9522        * If it gave us less than it wanted to despite ample buffer space,
9523        * something's broken.  Is your system missing a system identifier?
9524        */
9525       if (rsz <= jpilist[1].buflen) {
9526          /* Perl_croak accvios when used this early in startup. */
9527          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9528                          rsz, (unsigned long) jpilist[1].buflen,
9529                          "Check your rights database for corruption.\n");
9530          exit(SS$_ABORT);
9531       }
9532       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9533       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9534       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9535       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9536       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9537       _ckvmssts_noperl(iosb[0]);
9538     }
9539     mask = jpilist[1].bufadr;
9540     /* Check attribute flags for each identifier (2nd longword); protected
9541      * subsystem identifiers trigger tainting.
9542      */
9543     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9544       if (mask[i] & KGB$M_SUBSYSTEM) {
9545         will_taint = TRUE;
9546         break;
9547       }
9548     }
9549     if (mask != rlst) PerlMem_free(mask);
9550   }
9551
9552   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9553    * logical, some versions of the CRTL will add a phanthom /000000/
9554    * directory.  This needs to be removed.
9555    */
9556   if (decc_filename_unix_report) {
9557   char * zeros;
9558   int ulen;
9559     ulen = strlen(argvp[0][0]);
9560     if (ulen > 7) {
9561       zeros = strstr(argvp[0][0], "/000000/");
9562       if (zeros != NULL) {
9563         int mlen;
9564         mlen = ulen - (zeros - argvp[0][0]) - 7;
9565         memmove(zeros, &zeros[7], mlen);
9566         ulen = ulen - 7;
9567         argvp[0][0][ulen] = '\0';
9568       }
9569     }
9570     /* It also may have a trailing dot that needs to be removed otherwise
9571      * it will be converted to VMS mode incorrectly.
9572      */
9573     ulen--;
9574     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9575       argvp[0][0][ulen] = '\0';
9576   }
9577
9578   /* We need to use this hack to tell Perl it should run with tainting,
9579    * since its tainting flag may be part of the PL_curinterp struct, which
9580    * hasn't been allocated when vms_image_init() is called.
9581    */
9582   if (will_taint) {
9583     char **newargv, **oldargv;
9584     oldargv = *argvp;
9585     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9586     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9587     newargv[0] = oldargv[0];
9588     newargv[1] = PerlMem_malloc(3 * sizeof(char));
9589     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9590     strcpy(newargv[1], "-T");
9591     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9592     (*argcp)++;
9593     newargv[*argcp] = NULL;
9594     /* We orphan the old argv, since we don't know where it's come from,
9595      * so we don't know how to free it.
9596      */
9597     *argvp = newargv;
9598   }
9599   else {  /* Did user explicitly request tainting? */
9600     int i;
9601     char *cp, **av = *argvp;
9602     for (i = 1; i < *argcp; i++) {
9603       if (*av[i] != '-') break;
9604       for (cp = av[i]+1; *cp; cp++) {
9605         if (*cp == 'T') { will_taint = 1; break; }
9606         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9607                   strchr("DFIiMmx",*cp)) break;
9608       }
9609       if (will_taint) break;
9610     }
9611   }
9612
9613   for (tabidx = 0;
9614        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9615        tabidx++) {
9616     if (!tabidx) {
9617       tabvec = (struct dsc$descriptor_s **)
9618             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9619       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9620     }
9621     else if (tabidx >= tabct) {
9622       tabct += 8;
9623       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9624       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9625     }
9626     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9627     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9628     tabvec[tabidx]->dsc$w_length  = 0;
9629     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9630     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
9631     tabvec[tabidx]->dsc$a_pointer = NULL;
9632     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9633   }
9634   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9635
9636   getredirection(argcp,argvp);
9637 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9638   {
9639 # include <reentrancy.h>
9640   decc$set_reentrancy(C$C_MULTITHREAD);
9641   }
9642 #endif
9643   return;
9644 }
9645 /*}}}*/
9646
9647
9648 /* trim_unixpath()
9649  * Trim Unix-style prefix off filespec, so it looks like what a shell
9650  * glob expansion would return (i.e. from specified prefix on, not
9651  * full path).  Note that returned filespec is Unix-style, regardless
9652  * of whether input filespec was VMS-style or Unix-style.
9653  *
9654  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9655  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9656  * vector of options; at present, only bit 0 is used, and if set tells
9657  * trim unixpath to try the current default directory as a prefix when
9658  * presented with a possibly ambiguous ... wildcard.
9659  *
9660  * Returns !=0 on success, with trimmed filespec replacing contents of
9661  * fspec, and 0 on failure, with contents of fpsec unchanged.
9662  */
9663 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9664 int
9665 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9666 {
9667   char *unixified, *unixwild,
9668        *template, *base, *end, *cp1, *cp2;
9669   register int tmplen, reslen = 0, dirs = 0;
9670
9671   if (!wildspec || !fspec) return 0;
9672
9673   unixwild = PerlMem_malloc(VMS_MAXRSS);
9674   if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9675   template = unixwild;
9676   if (strpbrk(wildspec,"]>:") != NULL) {
9677     if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
9678         PerlMem_free(unixwild);
9679         return 0;
9680     }
9681   }
9682   else {
9683     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
9684     unixwild[VMS_MAXRSS-1] = 0;
9685   }
9686   unixified = PerlMem_malloc(VMS_MAXRSS);
9687   if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9688   if (strpbrk(fspec,"]>:") != NULL) {
9689     if (int_tounixspec(fspec, unixified, NULL) == NULL) {
9690         PerlMem_free(unixwild);
9691         PerlMem_free(unixified);
9692         return 0;
9693     }
9694     else base = unixified;
9695     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9696      * check to see that final result fits into (isn't longer than) fspec */
9697     reslen = strlen(fspec);
9698   }
9699   else base = fspec;
9700
9701   /* No prefix or absolute path on wildcard, so nothing to remove */
9702   if (!*template || *template == '/') {
9703     PerlMem_free(unixwild);
9704     if (base == fspec) {
9705         PerlMem_free(unixified);
9706         return 1;
9707     }
9708     tmplen = strlen(unixified);
9709     if (tmplen > reslen) {
9710         PerlMem_free(unixified);
9711         return 0;  /* not enough space */
9712     }
9713     /* Copy unixified resultant, including trailing NUL */
9714     memmove(fspec,unixified,tmplen+1);
9715     PerlMem_free(unixified);
9716     return 1;
9717   }
9718
9719   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
9720   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
9721     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
9722     for (cp1 = end ;cp1 >= base; cp1--)
9723       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9724         { cp1++; break; }
9725     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9726     PerlMem_free(unixified);
9727     PerlMem_free(unixwild);
9728     return 1;
9729   }
9730   else {
9731     char *tpl, *lcres;
9732     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9733     int ells = 1, totells, segdirs, match;
9734     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9735                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9736
9737     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9738     totells = ells;
9739     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9740     tpl = PerlMem_malloc(VMS_MAXRSS);
9741     if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9742     if (ellipsis == template && opts & 1) {
9743       /* Template begins with an ellipsis.  Since we can't tell how many
9744        * directory names at the front of the resultant to keep for an
9745        * arbitrary starting point, we arbitrarily choose the current
9746        * default directory as a starting point.  If it's there as a prefix,
9747        * clip it off.  If not, fall through and act as if the leading
9748        * ellipsis weren't there (i.e. return shortest possible path that
9749        * could match template).
9750        */
9751       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9752           PerlMem_free(tpl);
9753           PerlMem_free(unixified);
9754           PerlMem_free(unixwild);
9755           return 0;
9756       }
9757       if (!decc_efs_case_preserve) {
9758         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9759           if (_tolower(*cp1) != _tolower(*cp2)) break;
9760       }
9761       segdirs = dirs - totells;  /* Min # of dirs we must have left */
9762       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9763       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9764         memmove(fspec,cp2+1,end - cp2);
9765         PerlMem_free(tpl);
9766         PerlMem_free(unixified);
9767         PerlMem_free(unixwild);
9768         return 1;
9769       }
9770     }
9771     /* First off, back up over constant elements at end of path */
9772     if (dirs) {
9773       for (front = end ; front >= base; front--)
9774          if (*front == '/' && !dirs--) { front++; break; }
9775     }
9776     lcres = PerlMem_malloc(VMS_MAXRSS);
9777     if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9778     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9779          cp1++,cp2++) {
9780             if (!decc_efs_case_preserve) {
9781                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
9782             }
9783             else {
9784                 *cp2 = *cp1;
9785             }
9786     }
9787     if (cp1 != '\0') {
9788         PerlMem_free(tpl);
9789         PerlMem_free(unixified);
9790         PerlMem_free(unixwild);
9791         PerlMem_free(lcres);
9792         return 0;  /* Path too long. */
9793     }
9794     lcend = cp2;
9795     *cp2 = '\0';  /* Pick up with memcpy later */
9796     lcfront = lcres + (front - base);
9797     /* Now skip over each ellipsis and try to match the path in front of it. */
9798     while (ells--) {
9799       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
9800         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
9801             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
9802       if (cp1 < template) break; /* template started with an ellipsis */
9803       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9804         ellipsis = cp1; continue;
9805       }
9806       wilddsc.dsc$a_pointer = tpl;
9807       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9808       nextell = cp1;
9809       for (segdirs = 0, cp2 = tpl;
9810            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9811            cp1++, cp2++) {
9812          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9813          else {
9814             if (!decc_efs_case_preserve) {
9815               *cp2 = _tolower(*cp1);  /* else lowercase for match */
9816             }
9817             else {
9818               *cp2 = *cp1;  /* else preserve case for match */
9819             }
9820          }
9821          if (*cp2 == '/') segdirs++;
9822       }
9823       if (cp1 != ellipsis - 1) {
9824           PerlMem_free(tpl);
9825           PerlMem_free(unixified);
9826           PerlMem_free(unixwild);
9827           PerlMem_free(lcres);
9828           return 0; /* Path too long */
9829       }
9830       /* Back up at least as many dirs as in template before matching */
9831       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9832         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9833       for (match = 0; cp1 > lcres;) {
9834         resdsc.dsc$a_pointer = cp1;
9835         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9836           match++;
9837           if (match == 1) lcfront = cp1;
9838         }
9839         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9840       }
9841       if (!match) {
9842         PerlMem_free(tpl);
9843         PerlMem_free(unixified);
9844         PerlMem_free(unixwild);
9845         PerlMem_free(lcres);
9846         return 0;  /* Can't find prefix ??? */
9847       }
9848       if (match > 1 && opts & 1) {
9849         /* This ... wildcard could cover more than one set of dirs (i.e.
9850          * a set of similar dir names is repeated).  If the template
9851          * contains more than 1 ..., upstream elements could resolve the
9852          * ambiguity, but it's not worth a full backtracking setup here.
9853          * As a quick heuristic, clip off the current default directory
9854          * if it's present to find the trimmed spec, else use the
9855          * shortest string that this ... could cover.
9856          */
9857         char def[NAM$C_MAXRSS+1], *st;
9858
9859         if (getcwd(def, sizeof def,0) == NULL) {
9860             PerlMem_free(unixified);
9861             PerlMem_free(unixwild);
9862             PerlMem_free(lcres);
9863             PerlMem_free(tpl);
9864             return 0;
9865         }
9866         if (!decc_efs_case_preserve) {
9867           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9868             if (_tolower(*cp1) != _tolower(*cp2)) break;
9869         }
9870         segdirs = dirs - totells;  /* Min # of dirs we must have left */
9871         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9872         if (*cp1 == '\0' && *cp2 == '/') {
9873           memmove(fspec,cp2+1,end - cp2);
9874           PerlMem_free(tpl);
9875           PerlMem_free(unixified);
9876           PerlMem_free(unixwild);
9877           PerlMem_free(lcres);
9878           return 1;
9879         }
9880         /* Nope -- stick with lcfront from above and keep going. */
9881       }
9882     }
9883     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
9884     PerlMem_free(tpl);
9885     PerlMem_free(unixified);
9886     PerlMem_free(unixwild);
9887     PerlMem_free(lcres);
9888     return 1;
9889     ellipsis = nextell;
9890   }
9891
9892 }  /* end of trim_unixpath() */
9893 /*}}}*/
9894
9895
9896 /*
9897  *  VMS readdir() routines.
9898  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
9899  *
9900  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
9901  *  Minor modifications to original routines.
9902  */
9903
9904 /* readdir may have been redefined by reentr.h, so make sure we get
9905  * the local version for what we do here.
9906  */
9907 #ifdef readdir
9908 # undef readdir
9909 #endif
9910 #if !defined(PERL_IMPLICIT_CONTEXT)
9911 # define readdir Perl_readdir
9912 #else
9913 # define readdir(a) Perl_readdir(aTHX_ a)
9914 #endif
9915
9916     /* Number of elements in vms_versions array */
9917 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
9918
9919 /*
9920  *  Open a directory, return a handle for later use.
9921  */
9922 /*{{{ DIR *opendir(char*name) */
9923 DIR *
9924 Perl_opendir(pTHX_ const char *name)
9925 {
9926     DIR *dd;
9927     char *dir;
9928     Stat_t sb;
9929
9930     Newx(dir, VMS_MAXRSS, char);
9931     if (do_tovmspath(name,dir,0,NULL) == NULL) {
9932       Safefree(dir);
9933       return NULL;
9934     }
9935     /* Check access before stat; otherwise stat does not
9936      * accurately report whether it's a directory.
9937      */
9938     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
9939       /* cando_by_name has already set errno */
9940       Safefree(dir);
9941       return NULL;
9942     }
9943     if (flex_stat(dir,&sb) == -1) return NULL;
9944     if (!S_ISDIR(sb.st_mode)) {
9945       Safefree(dir);
9946       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
9947       return NULL;
9948     }
9949     /* Get memory for the handle, and the pattern. */
9950     Newx(dd,1,DIR);
9951     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
9952
9953     /* Fill in the fields; mainly playing with the descriptor. */
9954     sprintf(dd->pattern, "%s*.*",dir);
9955     Safefree(dir);
9956     dd->context = 0;
9957     dd->count = 0;
9958     dd->flags = 0;
9959     /* By saying we always want the result of readdir() in unix format, we
9960      * are really saying we want all the escapes removed.  Otherwise the caller,
9961      * having no way to know whether it's already in VMS format, might send it
9962      * through tovmsspec again, thus double escaping.
9963      */
9964     dd->flags = PERL_VMSDIR_M_UNIXSPECS;
9965     dd->pat.dsc$a_pointer = dd->pattern;
9966     dd->pat.dsc$w_length = strlen(dd->pattern);
9967     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
9968     dd->pat.dsc$b_class = DSC$K_CLASS_S;
9969 #if defined(USE_ITHREADS)
9970     Newx(dd->mutex,1,perl_mutex);
9971     MUTEX_INIT( (perl_mutex *) dd->mutex );
9972 #else
9973     dd->mutex = NULL;
9974 #endif
9975
9976     return dd;
9977 }  /* end of opendir() */
9978 /*}}}*/
9979
9980 /*
9981  *  Set the flag to indicate we want versions or not.
9982  */
9983 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
9984 void
9985 vmsreaddirversions(DIR *dd, int flag)
9986 {
9987     if (flag)
9988         dd->flags |= PERL_VMSDIR_M_VERSIONS;
9989     else
9990         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9991 }
9992 /*}}}*/
9993
9994 /*
9995  *  Free up an opened directory.
9996  */
9997 /*{{{ void closedir(DIR *dd)*/
9998 void
9999 Perl_closedir(DIR *dd)
10000 {
10001     int sts;
10002
10003     sts = lib$find_file_end(&dd->context);
10004     Safefree(dd->pattern);
10005 #if defined(USE_ITHREADS)
10006     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10007     Safefree(dd->mutex);
10008 #endif
10009     Safefree(dd);
10010 }
10011 /*}}}*/
10012
10013 /*
10014  *  Collect all the version numbers for the current file.
10015  */
10016 static void
10017 collectversions(pTHX_ DIR *dd)
10018 {
10019     struct dsc$descriptor_s     pat;
10020     struct dsc$descriptor_s     res;
10021     struct dirent *e;
10022     char *p, *text, *buff;
10023     int i;
10024     unsigned long context, tmpsts;
10025
10026     /* Convenient shorthand. */
10027     e = &dd->entry;
10028
10029     /* Add the version wildcard, ignoring the "*.*" put on before */
10030     i = strlen(dd->pattern);
10031     Newx(text,i + e->d_namlen + 3,char);
10032     strcpy(text, dd->pattern);
10033     sprintf(&text[i - 3], "%s;*", e->d_name);
10034
10035     /* Set up the pattern descriptor. */
10036     pat.dsc$a_pointer = text;
10037     pat.dsc$w_length = i + e->d_namlen - 1;
10038     pat.dsc$b_dtype = DSC$K_DTYPE_T;
10039     pat.dsc$b_class = DSC$K_CLASS_S;
10040
10041     /* Set up result descriptor. */
10042     Newx(buff, VMS_MAXRSS, char);
10043     res.dsc$a_pointer = buff;
10044     res.dsc$w_length = VMS_MAXRSS - 1;
10045     res.dsc$b_dtype = DSC$K_DTYPE_T;
10046     res.dsc$b_class = DSC$K_CLASS_S;
10047
10048     /* Read files, collecting versions. */
10049     for (context = 0, e->vms_verscount = 0;
10050          e->vms_verscount < VERSIZE(e);
10051          e->vms_verscount++) {
10052         unsigned long rsts;
10053         unsigned long flags = 0;
10054
10055 #ifdef VMS_LONGNAME_SUPPORT
10056         flags = LIB$M_FIL_LONG_NAMES;
10057 #endif
10058         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10059         if (tmpsts == RMS$_NMF || context == 0) break;
10060         _ckvmssts(tmpsts);
10061         buff[VMS_MAXRSS - 1] = '\0';
10062         if ((p = strchr(buff, ';')))
10063             e->vms_versions[e->vms_verscount] = atoi(p + 1);
10064         else
10065             e->vms_versions[e->vms_verscount] = -1;
10066     }
10067
10068     _ckvmssts(lib$find_file_end(&context));
10069     Safefree(text);
10070     Safefree(buff);
10071
10072 }  /* end of collectversions() */
10073
10074 /*
10075  *  Read the next entry from the directory.
10076  */
10077 /*{{{ struct dirent *readdir(DIR *dd)*/
10078 struct dirent *
10079 Perl_readdir(pTHX_ DIR *dd)
10080 {
10081     struct dsc$descriptor_s     res;
10082     char *p, *buff;
10083     unsigned long int tmpsts;
10084     unsigned long rsts;
10085     unsigned long flags = 0;
10086     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10087     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10088
10089     /* Set up result descriptor, and get next file. */
10090     Newx(buff, VMS_MAXRSS, char);
10091     res.dsc$a_pointer = buff;
10092     res.dsc$w_length = VMS_MAXRSS - 1;
10093     res.dsc$b_dtype = DSC$K_DTYPE_T;
10094     res.dsc$b_class = DSC$K_CLASS_S;
10095
10096 #ifdef VMS_LONGNAME_SUPPORT
10097     flags = LIB$M_FIL_LONG_NAMES;
10098 #endif
10099
10100     tmpsts = lib$find_file
10101         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10102     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
10103     if (!(tmpsts & 1)) {
10104       set_vaxc_errno(tmpsts);
10105       switch (tmpsts) {
10106         case RMS$_PRV:
10107           set_errno(EACCES); break;
10108         case RMS$_DEV:
10109           set_errno(ENODEV); break;
10110         case RMS$_DIR:
10111           set_errno(ENOTDIR); break;
10112         case RMS$_FNF: case RMS$_DNF:
10113           set_errno(ENOENT); break;
10114         default:
10115           set_errno(EVMSERR);
10116       }
10117       Safefree(buff);
10118       return NULL;
10119     }
10120     dd->count++;
10121     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10122     buff[res.dsc$w_length] = '\0';
10123     p = buff + res.dsc$w_length;
10124     while (--p >= buff) if (!isspace(*p)) break;
10125     *p = '\0';
10126     if (!decc_efs_case_preserve) {
10127       for (p = buff; *p; p++) *p = _tolower(*p);
10128     }
10129
10130     /* Skip any directory component and just copy the name. */
10131     sts = vms_split_path
10132        (buff,
10133         &v_spec,
10134         &v_len,
10135         &r_spec,
10136         &r_len,
10137         &d_spec,
10138         &d_len,
10139         &n_spec,
10140         &n_len,
10141         &e_spec,
10142         &e_len,
10143         &vs_spec,
10144         &vs_len);
10145
10146     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10147
10148         /* In Unix report mode, remove the ".dir;1" from the name */
10149         /* if it is a real directory. */
10150         if (decc_filename_unix_report || decc_efs_charset) {
10151             if ((e_len == 4) && (vs_len == 2) && (vs_spec[1] == '1')) {
10152                 if ((toupper(e_spec[1]) == 'D') &&
10153                     (toupper(e_spec[2]) == 'I') &&
10154                     (toupper(e_spec[3]) == 'R')) {
10155                     Stat_t statbuf;
10156                     int ret_sts;
10157
10158                     ret_sts = stat(buff, (stat_t *)&statbuf);
10159                     if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10160                         e_len = 0;
10161                         e_spec[0] = 0;
10162                     }
10163                 }
10164             }
10165         }
10166
10167         /* Drop NULL extensions on UNIX file specification */
10168         if ((e_len == 1) && decc_readdir_dropdotnotype) {
10169             e_len = 0;
10170             e_spec[0] = '\0';
10171         }
10172     }
10173
10174     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
10175     dd->entry.d_name[n_len + e_len] = '\0';
10176     dd->entry.d_namlen = strlen(dd->entry.d_name);
10177
10178     /* Convert the filename to UNIX format if needed */
10179     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10180
10181         /* Translate the encoded characters. */
10182         /* Fixme: Unicode handling could result in embedded 0 characters */
10183         if (strchr(dd->entry.d_name, '^') != NULL) {
10184             char new_name[256];
10185             char * q;
10186             p = dd->entry.d_name;
10187             q = new_name;
10188             while (*p != 0) {
10189                 int inchars_read, outchars_added;
10190                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10191                 p += inchars_read;
10192                 q += outchars_added;
10193                 /* fix-me */
10194                 /* if outchars_added > 1, then this is a wide file specification */
10195                 /* Wide file specifications need to be passed in Perl */
10196                 /* counted strings apparently with a Unicode flag */
10197             }
10198             *q = 0;
10199             strcpy(dd->entry.d_name, new_name);
10200             dd->entry.d_namlen = strlen(dd->entry.d_name);
10201         }
10202     }
10203
10204     dd->entry.vms_verscount = 0;
10205     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10206     Safefree(buff);
10207     return &dd->entry;
10208
10209 }  /* end of readdir() */
10210 /*}}}*/
10211
10212 /*
10213  *  Read the next entry from the directory -- thread-safe version.
10214  */
10215 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10216 int
10217 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10218 {
10219     int retval;
10220
10221     MUTEX_LOCK( (perl_mutex *) dd->mutex );
10222
10223     entry = readdir(dd);
10224     *result = entry;
10225     retval = ( *result == NULL ? errno : 0 );
10226
10227     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10228
10229     return retval;
10230
10231 }  /* end of readdir_r() */
10232 /*}}}*/
10233
10234 /*
10235  *  Return something that can be used in a seekdir later.
10236  */
10237 /*{{{ long telldir(DIR *dd)*/
10238 long
10239 Perl_telldir(DIR *dd)
10240 {
10241     return dd->count;
10242 }
10243 /*}}}*/
10244
10245 /*
10246  *  Return to a spot where we used to be.  Brute force.
10247  */
10248 /*{{{ void seekdir(DIR *dd,long count)*/
10249 void
10250 Perl_seekdir(pTHX_ DIR *dd, long count)
10251 {
10252     int old_flags;
10253
10254     /* If we haven't done anything yet... */
10255     if (dd->count == 0)
10256         return;
10257
10258     /* Remember some state, and clear it. */
10259     old_flags = dd->flags;
10260     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10261     _ckvmssts(lib$find_file_end(&dd->context));
10262     dd->context = 0;
10263
10264     /* The increment is in readdir(). */
10265     for (dd->count = 0; dd->count < count; )
10266         readdir(dd);
10267
10268     dd->flags = old_flags;
10269
10270 }  /* end of seekdir() */
10271 /*}}}*/
10272
10273 /* VMS subprocess management
10274  *
10275  * my_vfork() - just a vfork(), after setting a flag to record that
10276  * the current script is trying a Unix-style fork/exec.
10277  *
10278  * vms_do_aexec() and vms_do_exec() are called in response to the
10279  * perl 'exec' function.  If this follows a vfork call, then they
10280  * call out the regular perl routines in doio.c which do an
10281  * execvp (for those who really want to try this under VMS).
10282  * Otherwise, they do exactly what the perl docs say exec should
10283  * do - terminate the current script and invoke a new command
10284  * (See below for notes on command syntax.)
10285  *
10286  * do_aspawn() and do_spawn() implement the VMS side of the perl
10287  * 'system' function.
10288  *
10289  * Note on command arguments to perl 'exec' and 'system': When handled
10290  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10291  * are concatenated to form a DCL command string.  If the first non-numeric
10292  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10293  * the command string is handed off to DCL directly.  Otherwise,
10294  * the first token of the command is taken as the filespec of an image
10295  * to run.  The filespec is expanded using a default type of '.EXE' and
10296  * the process defaults for device, directory, etc., and if found, the resultant
10297  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10298  * the command string as parameters.  This is perhaps a bit complicated,
10299  * but I hope it will form a happy medium between what VMS folks expect
10300  * from lib$spawn and what Unix folks expect from exec.
10301  */
10302
10303 static int vfork_called;
10304
10305 /*{{{int my_vfork()*/
10306 int
10307 my_vfork()
10308 {
10309   vfork_called++;
10310   return vfork();
10311 }
10312 /*}}}*/
10313
10314
10315 static void
10316 vms_execfree(struct dsc$descriptor_s *vmscmd)
10317 {
10318   if (vmscmd) {
10319       if (vmscmd->dsc$a_pointer) {
10320           PerlMem_free(vmscmd->dsc$a_pointer);
10321       }
10322       PerlMem_free(vmscmd);
10323   }
10324 }
10325
10326 static char *
10327 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10328 {
10329   char *junk, *tmps = NULL;
10330   register size_t cmdlen = 0;
10331   size_t rlen;
10332   register SV **idx;
10333   STRLEN n_a;
10334
10335   idx = mark;
10336   if (really) {
10337     tmps = SvPV(really,rlen);
10338     if (*tmps) {
10339       cmdlen += rlen + 1;
10340       idx++;
10341     }
10342   }
10343
10344   for (idx++; idx <= sp; idx++) {
10345     if (*idx) {
10346       junk = SvPVx(*idx,rlen);
10347       cmdlen += rlen ? rlen + 1 : 0;
10348     }
10349   }
10350   Newx(PL_Cmd, cmdlen+1, char);
10351
10352   if (tmps && *tmps) {
10353     strcpy(PL_Cmd,tmps);
10354     mark++;
10355   }
10356   else *PL_Cmd = '\0';
10357   while (++mark <= sp) {
10358     if (*mark) {
10359       char *s = SvPVx(*mark,n_a);
10360       if (!*s) continue;
10361       if (*PL_Cmd) strcat(PL_Cmd," ");
10362       strcat(PL_Cmd,s);
10363     }
10364   }
10365   return PL_Cmd;
10366
10367 }  /* end of setup_argstr() */
10368
10369
10370 static unsigned long int
10371 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10372                    struct dsc$descriptor_s **pvmscmd)
10373 {
10374   char * vmsspec;
10375   char * resspec;
10376   char image_name[NAM$C_MAXRSS+1];
10377   char image_argv[NAM$C_MAXRSS+1];
10378   $DESCRIPTOR(defdsc,".EXE");
10379   $DESCRIPTOR(defdsc2,".");
10380   struct dsc$descriptor_s resdsc;
10381   struct dsc$descriptor_s *vmscmd;
10382   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10383   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10384   register char *s, *rest, *cp, *wordbreak;
10385   char * cmd;
10386   int cmdlen;
10387   register int isdcl;
10388
10389   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10390   if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10391
10392   /* vmsspec is a DCL command buffer, not just a filename */
10393   vmsspec = PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10394   if (vmsspec == NULL)
10395       _ckvmssts_noperl(SS$_INSFMEM);
10396
10397   resspec = PerlMem_malloc(VMS_MAXRSS);
10398   if (resspec == NULL)
10399       _ckvmssts_noperl(SS$_INSFMEM);
10400
10401   /* Make a copy for modification */
10402   cmdlen = strlen(incmd);
10403   cmd = PerlMem_malloc(cmdlen+1);
10404   if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10405   strncpy(cmd, incmd, cmdlen);
10406   cmd[cmdlen] = 0;
10407   image_name[0] = 0;
10408   image_argv[0] = 0;
10409
10410   resdsc.dsc$a_pointer = resspec;
10411   resdsc.dsc$b_dtype  = DSC$K_DTYPE_T;
10412   resdsc.dsc$b_class  = DSC$K_CLASS_S;
10413   resdsc.dsc$w_length = VMS_MAXRSS - 1;
10414
10415   vmscmd->dsc$a_pointer = NULL;
10416   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
10417   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
10418   vmscmd->dsc$w_length = 0;
10419   if (pvmscmd) *pvmscmd = vmscmd;
10420
10421   if (suggest_quote) *suggest_quote = 0;
10422
10423   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10424     PerlMem_free(cmd);
10425     PerlMem_free(vmsspec);
10426     PerlMem_free(resspec);
10427     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
10428   }
10429
10430   s = cmd;
10431
10432   while (*s && isspace(*s)) s++;
10433
10434   if (*s == '@' || *s == '$') {
10435     vmsspec[0] = *s;  rest = s + 1;
10436     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10437   }
10438   else { cp = vmsspec; rest = s; }
10439   if (*rest == '.' || *rest == '/') {
10440     char *cp2;
10441     for (cp2 = resspec;
10442          *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10443          rest++, cp2++) *cp2 = *rest;
10444     *cp2 = '\0';
10445     if (int_tovmsspec(resspec, cp, 0, NULL)) {
10446       s = vmsspec;
10447
10448       /* When a UNIX spec with no file type is translated to VMS, */
10449       /* A trailing '.' is appended under ODS-5 rules.            */
10450       /* Here we do not want that trailing "." as it prevents     */
10451       /* Looking for a implied ".exe" type. */
10452       if (decc_efs_charset) {
10453           int i;
10454           i = strlen(vmsspec);
10455           if (vmsspec[i-1] == '.') {
10456               vmsspec[i-1] = '\0';
10457           }
10458       }
10459
10460       if (*rest) {
10461         for (cp2 = vmsspec + strlen(vmsspec);
10462              *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10463              rest++, cp2++) *cp2 = *rest;
10464         *cp2 = '\0';
10465       }
10466     }
10467   }
10468   /* Intuit whether verb (first word of cmd) is a DCL command:
10469    *   - if first nonspace char is '@', it's a DCL indirection
10470    * otherwise
10471    *   - if verb contains a filespec separator, it's not a DCL command
10472    *   - if it doesn't, caller tells us whether to default to a DCL
10473    *     command, or to a local image unless told it's DCL (by leading '$')
10474    */
10475   if (*s == '@') {
10476       isdcl = 1;
10477       if (suggest_quote) *suggest_quote = 1;
10478   } else {
10479     register char *filespec = strpbrk(s,":<[.;");
10480     rest = wordbreak = strpbrk(s," \"\t/");
10481     if (!wordbreak) wordbreak = s + strlen(s);
10482     if (*s == '$') check_img = 0;
10483     if (filespec && (filespec < wordbreak)) isdcl = 0;
10484     else isdcl = !check_img;
10485   }
10486
10487   if (!isdcl) {
10488     int rsts;
10489     imgdsc.dsc$a_pointer = s;
10490     imgdsc.dsc$w_length = wordbreak - s;
10491     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10492     if (!(retsts&1)) {
10493         _ckvmssts_noperl(lib$find_file_end(&cxt));
10494         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10495       if (!(retsts & 1) && *s == '$') {
10496         _ckvmssts_noperl(lib$find_file_end(&cxt));
10497         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10498         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10499         if (!(retsts&1)) {
10500           _ckvmssts_noperl(lib$find_file_end(&cxt));
10501           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10502         }
10503       }
10504     }
10505     _ckvmssts_noperl(lib$find_file_end(&cxt));
10506
10507     if (retsts & 1) {
10508       FILE *fp;
10509       s = resspec;
10510       while (*s && !isspace(*s)) s++;
10511       *s = '\0';
10512
10513       /* check that it's really not DCL with no file extension */
10514       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10515       if (fp) {
10516         char b[256] = {0,0,0,0};
10517         read(fileno(fp), b, 256);
10518         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10519         if (isdcl) {
10520           int shebang_len;
10521
10522           /* Check for script */
10523           shebang_len = 0;
10524           if ((b[0] == '#') && (b[1] == '!'))
10525              shebang_len = 2;
10526 #ifdef ALTERNATE_SHEBANG
10527           else {
10528             shebang_len = strlen(ALTERNATE_SHEBANG);
10529             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10530               char * perlstr;
10531                 perlstr = strstr("perl",b);
10532                 if (perlstr == NULL)
10533                   shebang_len = 0;
10534             }
10535             else
10536               shebang_len = 0;
10537           }
10538 #endif
10539
10540           if (shebang_len > 0) {
10541           int i;
10542           int j;
10543           char tmpspec[NAM$C_MAXRSS + 1];
10544
10545             i = shebang_len;
10546              /* Image is following after white space */
10547             /*--------------------------------------*/
10548             while (isprint(b[i]) && isspace(b[i]))
10549                 i++;
10550
10551             j = 0;
10552             while (isprint(b[i]) && !isspace(b[i])) {
10553                 tmpspec[j++] = b[i++];
10554                 if (j >= NAM$C_MAXRSS)
10555                    break;
10556             }
10557             tmpspec[j] = '\0';
10558
10559              /* There may be some default parameters to the image */
10560             /*---------------------------------------------------*/
10561             j = 0;
10562             while (isprint(b[i])) {
10563                 image_argv[j++] = b[i++];
10564                 if (j >= NAM$C_MAXRSS)
10565                    break;
10566             }
10567             while ((j > 0) && !isprint(image_argv[j-1]))
10568                 j--;
10569             image_argv[j] = 0;
10570
10571             /* It will need to be converted to VMS format and validated */
10572             if (tmpspec[0] != '\0') {
10573               char * iname;
10574
10575                /* Try to find the exact program requested to be run */
10576               /*---------------------------------------------------*/
10577               iname = int_rmsexpand
10578                  (tmpspec, image_name, ".exe",
10579                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10580               if (iname != NULL) {
10581                 if (cando_by_name_int
10582                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10583                   /* MCR prefix needed */
10584                   isdcl = 0;
10585                 }
10586                 else {
10587                    /* Try again with a null type */
10588                   /*----------------------------*/
10589                   iname = int_rmsexpand
10590                     (tmpspec, image_name, ".",
10591                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10592                   if (iname != NULL) {
10593                     if (cando_by_name_int
10594                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10595                       /* MCR prefix needed */
10596                       isdcl = 0;
10597                     }
10598                   }
10599                 }
10600
10601                  /* Did we find the image to run the script? */
10602                 /*------------------------------------------*/
10603                 if (isdcl) {
10604                   char *tchr;
10605
10606                    /* Assume DCL or foreign command exists */
10607                   /*--------------------------------------*/
10608                   tchr = strrchr(tmpspec, '/');
10609                   if (tchr != NULL) {
10610                     tchr++;
10611                   }
10612                   else {
10613                     tchr = tmpspec;
10614                   }
10615                   strcpy(image_name, tchr);
10616                 }
10617               }
10618             }
10619           }
10620         }
10621         fclose(fp);
10622       }
10623       if (check_img && isdcl) {
10624           PerlMem_free(cmd);
10625           PerlMem_free(resspec);
10626           PerlMem_free(vmsspec);
10627           return RMS$_FNF;
10628       }
10629
10630       if (cando_by_name(S_IXUSR,0,resspec)) {
10631         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10632         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10633         if (!isdcl) {
10634             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
10635             if (image_name[0] != 0) {
10636                 strcat(vmscmd->dsc$a_pointer, image_name);
10637                 strcat(vmscmd->dsc$a_pointer, " ");
10638             }
10639         } else if (image_name[0] != 0) {
10640             strcpy(vmscmd->dsc$a_pointer, image_name);
10641             strcat(vmscmd->dsc$a_pointer, " ");
10642         } else {
10643             strcpy(vmscmd->dsc$a_pointer,"@");
10644         }
10645         if (suggest_quote) *suggest_quote = 1;
10646
10647         /* If there is an image name, use original command */
10648         if (image_name[0] == 0)
10649             strcat(vmscmd->dsc$a_pointer,resspec);
10650         else {
10651             rest = cmd;
10652             while (*rest && isspace(*rest)) rest++;
10653         }
10654
10655         if (image_argv[0] != 0) {
10656           strcat(vmscmd->dsc$a_pointer,image_argv);
10657           strcat(vmscmd->dsc$a_pointer, " ");
10658         }
10659         if (rest) {
10660            int rest_len;
10661            int vmscmd_len;
10662
10663            rest_len = strlen(rest);
10664            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10665            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10666               strcat(vmscmd->dsc$a_pointer,rest);
10667            else
10668              retsts = CLI$_BUFOVF;
10669         }
10670         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10671         PerlMem_free(cmd);
10672         PerlMem_free(vmsspec);
10673         PerlMem_free(resspec);
10674         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10675       }
10676       else
10677         retsts = RMS$_PRV;
10678     }
10679   }
10680   /* It's either a DCL command or we couldn't find a suitable image */
10681   vmscmd->dsc$w_length = strlen(cmd);
10682
10683   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
10684   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
10685   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
10686
10687   PerlMem_free(cmd);
10688   PerlMem_free(resspec);
10689   PerlMem_free(vmsspec);
10690
10691   /* check if it's a symbol (for quoting purposes) */
10692   if (suggest_quote && !*suggest_quote) {
10693     int iss;
10694     char equiv[LNM$C_NAMLENGTH];
10695     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10696     eqvdsc.dsc$a_pointer = equiv;
10697
10698     iss = lib$get_symbol(vmscmd,&eqvdsc);
10699     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10700   }
10701   if (!(retsts & 1)) {
10702     /* just hand off status values likely to be due to user error */
10703     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10704         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10705        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10706     else { _ckvmssts_noperl(retsts); }
10707   }
10708
10709   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10710
10711 }  /* end of setup_cmddsc() */
10712
10713
10714 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10715 bool
10716 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10717 {
10718 bool exec_sts;
10719 char * cmd;
10720
10721   if (sp > mark) {
10722     if (vfork_called) {           /* this follows a vfork - act Unixish */
10723       vfork_called--;
10724       if (vfork_called < 0) {
10725         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10726         vfork_called = 0;
10727       }
10728       else return do_aexec(really,mark,sp);
10729     }
10730                                            /* no vfork - act VMSish */
10731     cmd = setup_argstr(aTHX_ really,mark,sp);
10732     exec_sts = vms_do_exec(cmd);
10733     Safefree(cmd);  /* Clean up from setup_argstr() */
10734     return exec_sts;
10735   }
10736
10737   return FALSE;
10738 }  /* end of vms_do_aexec() */
10739 /*}}}*/
10740
10741 /* {{{bool vms_do_exec(char *cmd) */
10742 bool
10743 Perl_vms_do_exec(pTHX_ const char *cmd)
10744 {
10745   struct dsc$descriptor_s *vmscmd;
10746
10747   if (vfork_called) {             /* this follows a vfork - act Unixish */
10748     vfork_called--;
10749     if (vfork_called < 0) {
10750       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10751       vfork_called = 0;
10752     }
10753     else return do_exec(cmd);
10754   }
10755
10756   {                               /* no vfork - act VMSish */
10757     unsigned long int retsts;
10758
10759     TAINT_ENV();
10760     TAINT_PROPER("exec");
10761     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10762       retsts = lib$do_command(vmscmd);
10763
10764     switch (retsts) {
10765       case RMS$_FNF: case RMS$_DNF:
10766         set_errno(ENOENT); break;
10767       case RMS$_DIR:
10768         set_errno(ENOTDIR); break;
10769       case RMS$_DEV:
10770         set_errno(ENODEV); break;
10771       case RMS$_PRV:
10772         set_errno(EACCES); break;
10773       case RMS$_SYN:
10774         set_errno(EINVAL); break;
10775       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10776         set_errno(E2BIG); break;
10777       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10778         _ckvmssts_noperl(retsts); /* fall through */
10779       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10780         set_errno(EVMSERR);
10781     }
10782     set_vaxc_errno(retsts);
10783     if (ckWARN(WARN_EXEC)) {
10784       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10785              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10786     }
10787     vms_execfree(vmscmd);
10788   }
10789
10790   return FALSE;
10791
10792 }  /* end of vms_do_exec() */
10793 /*}}}*/
10794
10795 int do_spawn2(pTHX_ const char *, int);
10796
10797 int
10798 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
10799 {
10800 unsigned long int sts;
10801 char * cmd;
10802 int flags = 0;
10803
10804   if (sp > mark) {
10805
10806     /* We'll copy the (undocumented?) Win32 behavior and allow a
10807      * numeric first argument.  But the only value we'll support
10808      * through do_aspawn is a value of 1, which means spawn without
10809      * waiting for completion -- other values are ignored.
10810      */
10811     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
10812         ++mark;
10813         flags = SvIVx(*mark);
10814     }
10815
10816     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
10817         flags = CLI$M_NOWAIT;
10818     else
10819         flags = 0;
10820
10821     cmd = setup_argstr(aTHX_ really, mark, sp);
10822     sts = do_spawn2(aTHX_ cmd, flags);
10823     /* pp_sys will clean up cmd */
10824     return sts;
10825   }
10826   return SS$_ABORT;
10827 }  /* end of do_aspawn() */
10828 /*}}}*/
10829
10830
10831 /* {{{int do_spawn(char* cmd) */
10832 int
10833 Perl_do_spawn(pTHX_ char* cmd)
10834 {
10835     PERL_ARGS_ASSERT_DO_SPAWN;
10836
10837     return do_spawn2(aTHX_ cmd, 0);
10838 }
10839 /*}}}*/
10840
10841 /* {{{int do_spawn_nowait(char* cmd) */
10842 int
10843 Perl_do_spawn_nowait(pTHX_ char* cmd)
10844 {
10845     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
10846
10847     return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
10848 }
10849 /*}}}*/
10850
10851 /* {{{int do_spawn2(char *cmd) */
10852 int
10853 do_spawn2(pTHX_ const char *cmd, int flags)
10854 {
10855   unsigned long int sts, substs;
10856
10857   /* The caller of this routine expects to Safefree(PL_Cmd) */
10858   Newx(PL_Cmd,10,char);
10859
10860   TAINT_ENV();
10861   TAINT_PROPER("spawn");
10862   if (!cmd || !*cmd) {
10863     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
10864     if (!(sts & 1)) {
10865       switch (sts) {
10866         case RMS$_FNF:  case RMS$_DNF:
10867           set_errno(ENOENT); break;
10868         case RMS$_DIR:
10869           set_errno(ENOTDIR); break;
10870         case RMS$_DEV:
10871           set_errno(ENODEV); break;
10872         case RMS$_PRV:
10873           set_errno(EACCES); break;
10874         case RMS$_SYN:
10875           set_errno(EINVAL); break;
10876         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10877           set_errno(E2BIG); break;
10878         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10879           _ckvmssts_noperl(sts); /* fall through */
10880         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10881           set_errno(EVMSERR);
10882       }
10883       set_vaxc_errno(sts);
10884       if (ckWARN(WARN_EXEC)) {
10885         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
10886                     Strerror(errno));
10887       }
10888     }
10889     sts = substs;
10890   }
10891   else {
10892     char mode[3];
10893     PerlIO * fp;
10894     if (flags & CLI$M_NOWAIT)
10895         strcpy(mode, "n");
10896     else
10897         strcpy(mode, "nW");
10898
10899     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
10900     if (fp != NULL)
10901       my_pclose(fp);
10902     /* sts will be the pid in the nowait case */
10903   }
10904   return sts;
10905 }  /* end of do_spawn2() */
10906 /*}}}*/
10907
10908
10909 static unsigned int *sockflags, sockflagsize;
10910
10911 /*
10912  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
10913  * routines found in some versions of the CRTL can't deal with sockets.
10914  * We don't shim the other file open routines since a socket isn't
10915  * likely to be opened by a name.
10916  */
10917 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
10918 FILE *my_fdopen(int fd, const char *mode)
10919 {
10920   FILE *fp = fdopen(fd, mode);
10921
10922   if (fp) {
10923     unsigned int fdoff = fd / sizeof(unsigned int);
10924     Stat_t sbuf; /* native stat; we don't need flex_stat */
10925     if (!sockflagsize || fdoff > sockflagsize) {
10926       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
10927       else           Newx  (sockflags,fdoff+2,unsigned int);
10928       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
10929       sockflagsize = fdoff + 2;
10930     }
10931     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
10932       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
10933   }
10934   return fp;
10935
10936 }
10937 /*}}}*/
10938
10939
10940 /*
10941  * Clear the corresponding bit when the (possibly) socket stream is closed.
10942  * There still a small hole: we miss an implicit close which might occur
10943  * via freopen().  >> Todo
10944  */
10945 /*{{{ int my_fclose(FILE *fp)*/
10946 int my_fclose(FILE *fp) {
10947   if (fp) {
10948     unsigned int fd = fileno(fp);
10949     unsigned int fdoff = fd / sizeof(unsigned int);
10950
10951     if (sockflagsize && fdoff < sockflagsize)
10952       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
10953   }
10954   return fclose(fp);
10955 }
10956 /*}}}*/
10957
10958
10959 /*
10960  * A simple fwrite replacement which outputs itmsz*nitm chars without
10961  * introducing record boundaries every itmsz chars.
10962  * We are using fputs, which depends on a terminating null.  We may
10963  * well be writing binary data, so we need to accommodate not only
10964  * data with nulls sprinkled in the middle but also data with no null
10965  * byte at the end.
10966  */
10967 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
10968 int
10969 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
10970 {
10971   register char *cp, *end, *cpd, *data;
10972   register unsigned int fd = fileno(dest);
10973   register unsigned int fdoff = fd / sizeof(unsigned int);
10974   int retval;
10975   int bufsize = itmsz * nitm + 1;
10976
10977   if (fdoff < sockflagsize &&
10978       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
10979     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
10980     return nitm;
10981   }
10982
10983   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
10984   memcpy( data, src, itmsz*nitm );
10985   data[itmsz*nitm] = '\0';
10986
10987   end = data + itmsz * nitm;
10988   retval = (int) nitm; /* on success return # items written */
10989
10990   cpd = data;
10991   while (cpd <= end) {
10992     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
10993     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
10994     if (cp < end)
10995       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
10996     cpd = cp + 1;
10997   }
10998
10999   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11000   return retval;
11001
11002 }  /* end of my_fwrite() */
11003 /*}}}*/
11004
11005 /*{{{ int my_flush(FILE *fp)*/
11006 int
11007 Perl_my_flush(pTHX_ FILE *fp)
11008 {
11009     int res;
11010     if ((res = fflush(fp)) == 0 && fp) {
11011 #ifdef VMS_DO_SOCKETS
11012         Stat_t s;
11013         if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11014 #endif
11015             res = fsync(fileno(fp));
11016     }
11017 /*
11018  * If the flush succeeded but set end-of-file, we need to clear
11019  * the error because our caller may check ferror().  BTW, this
11020  * probably means we just flushed an empty file.
11021  */
11022     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11023
11024     return res;
11025 }
11026 /*}}}*/
11027
11028 /*
11029  * Here are replacements for the following Unix routines in the VMS environment:
11030  *      getpwuid    Get information for a particular UIC or UID
11031  *      getpwnam    Get information for a named user
11032  *      getpwent    Get information for each user in the rights database
11033  *      setpwent    Reset search to the start of the rights database
11034  *      endpwent    Finish searching for users in the rights database
11035  *
11036  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11037  * (defined in pwd.h), which contains the following fields:-
11038  *      struct passwd {
11039  *              char        *pw_name;    Username (in lower case)
11040  *              char        *pw_passwd;  Hashed password
11041  *              unsigned int pw_uid;     UIC
11042  *              unsigned int pw_gid;     UIC group  number
11043  *              char        *pw_unixdir; Default device/directory (VMS-style)
11044  *              char        *pw_gecos;   Owner name
11045  *              char        *pw_dir;     Default device/directory (Unix-style)
11046  *              char        *pw_shell;   Default CLI name (eg. DCL)
11047  *      };
11048  * If the specified user does not exist, getpwuid and getpwnam return NULL.
11049  *
11050  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11051  * not the UIC member number (eg. what's returned by getuid()),
11052  * getpwuid() can accept either as input (if uid is specified, the caller's
11053  * UIC group is used), though it won't recognise gid=0.
11054  *
11055  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11056  * information about other users in your group or in other groups, respectively.
11057  * If the required privilege is not available, then these routines fill only
11058  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11059  * string).
11060  *
11061  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11062  */
11063
11064 /* sizes of various UAF record fields */
11065 #define UAI$S_USERNAME 12
11066 #define UAI$S_IDENT    31
11067 #define UAI$S_OWNER    31
11068 #define UAI$S_DEFDEV   31
11069 #define UAI$S_DEFDIR   63
11070 #define UAI$S_DEFCLI   31
11071 #define UAI$S_PWD       8
11072
11073 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
11074                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11075                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
11076
11077 static char __empty[]= "";
11078 static struct passwd __passwd_empty=
11079     {(char *) __empty, (char *) __empty, 0, 0,
11080      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11081 static int contxt= 0;
11082 static struct passwd __pwdcache;
11083 static char __pw_namecache[UAI$S_IDENT+1];
11084
11085 /*
11086  * This routine does most of the work extracting the user information.
11087  */
11088 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11089 {
11090     static struct {
11091         unsigned char length;
11092         char pw_gecos[UAI$S_OWNER+1];
11093     } owner;
11094     static union uicdef uic;
11095     static struct {
11096         unsigned char length;
11097         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11098     } defdev;
11099     static struct {
11100         unsigned char length;
11101         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11102     } defdir;
11103     static struct {
11104         unsigned char length;
11105         char pw_shell[UAI$S_DEFCLI+1];
11106     } defcli;
11107     static char pw_passwd[UAI$S_PWD+1];
11108
11109     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11110     struct dsc$descriptor_s name_desc;
11111     unsigned long int sts;
11112
11113     static struct itmlst_3 itmlst[]= {
11114         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
11115         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
11116         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
11117         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
11118         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
11119         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
11120         {0,                0,           NULL,    NULL}};
11121
11122     name_desc.dsc$w_length=  strlen(name);
11123     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11124     name_desc.dsc$b_class=   DSC$K_CLASS_S;
11125     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11126
11127 /*  Note that sys$getuai returns many fields as counted strings. */
11128     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11129     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11130       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11131     }
11132     else { _ckvmssts(sts); }
11133     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
11134
11135     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
11136     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11137     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11138     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11139     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11140     owner.pw_gecos[lowner]=            '\0';
11141     defdev.pw_dir[ldefdev+ldefdir]= '\0';
11142     defcli.pw_shell[ldefcli]=          '\0';
11143     if (valid_uic(uic)) {
11144         pwd->pw_uid= uic.uic$l_uic;
11145         pwd->pw_gid= uic.uic$v_group;
11146     }
11147     else
11148       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11149     pwd->pw_passwd=  pw_passwd;
11150     pwd->pw_gecos=   owner.pw_gecos;
11151     pwd->pw_dir=     defdev.pw_dir;
11152     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11153     pwd->pw_shell=   defcli.pw_shell;
11154     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11155         int ldir;
11156         ldir= strlen(pwd->pw_unixdir) - 1;
11157         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11158     }
11159     else
11160         strcpy(pwd->pw_unixdir, pwd->pw_dir);
11161     if (!decc_efs_case_preserve)
11162         __mystrtolower(pwd->pw_unixdir);
11163     return 1;
11164 }
11165
11166 /*
11167  * Get information for a named user.
11168 */
11169 /*{{{struct passwd *getpwnam(char *name)*/
11170 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
11171 {
11172     struct dsc$descriptor_s name_desc;
11173     union uicdef uic;
11174     unsigned long int status, sts;
11175
11176     __pwdcache = __passwd_empty;
11177     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11178       /* We still may be able to determine pw_uid and pw_gid */
11179       name_desc.dsc$w_length=  strlen(name);
11180       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11181       name_desc.dsc$b_class=   DSC$K_CLASS_S;
11182       name_desc.dsc$a_pointer= (char *) name;
11183       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11184         __pwdcache.pw_uid= uic.uic$l_uic;
11185         __pwdcache.pw_gid= uic.uic$v_group;
11186       }
11187       else {
11188         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11189           set_vaxc_errno(sts);
11190           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11191           return NULL;
11192         }
11193         else { _ckvmssts(sts); }
11194       }
11195     }
11196     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
11197     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
11198     __pwdcache.pw_name= __pw_namecache;
11199     return &__pwdcache;
11200 }  /* end of my_getpwnam() */
11201 /*}}}*/
11202
11203 /*
11204  * Get information for a particular UIC or UID.
11205  * Called by my_getpwent with uid=-1 to list all users.
11206 */
11207 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11208 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
11209 {
11210     const $DESCRIPTOR(name_desc,__pw_namecache);
11211     unsigned short lname;
11212     union uicdef uic;
11213     unsigned long int status;
11214
11215     if (uid == (unsigned int) -1) {
11216       do {
11217         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11218         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11219           set_vaxc_errno(status);
11220           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11221           my_endpwent();
11222           return NULL;
11223         }
11224         else { _ckvmssts(status); }
11225       } while (!valid_uic (uic));
11226     }
11227     else {
11228       uic.uic$l_uic= uid;
11229       if (!uic.uic$v_group)
11230         uic.uic$v_group= PerlProc_getgid();
11231       if (valid_uic(uic))
11232         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11233       else status = SS$_IVIDENT;
11234       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11235           status == RMS$_PRV) {
11236         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11237         return NULL;
11238       }
11239       else { _ckvmssts(status); }
11240     }
11241     __pw_namecache[lname]= '\0';
11242     __mystrtolower(__pw_namecache);
11243
11244     __pwdcache = __passwd_empty;
11245     __pwdcache.pw_name = __pw_namecache;
11246
11247 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11248     The identifier's value is usually the UIC, but it doesn't have to be,
11249     so if we can, we let fillpasswd update this. */
11250     __pwdcache.pw_uid =  uic.uic$l_uic;
11251     __pwdcache.pw_gid =  uic.uic$v_group;
11252
11253     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11254     return &__pwdcache;
11255
11256 }  /* end of my_getpwuid() */
11257 /*}}}*/
11258
11259 /*
11260  * Get information for next user.
11261 */
11262 /*{{{struct passwd *my_getpwent()*/
11263 struct passwd *Perl_my_getpwent(pTHX)
11264 {
11265     return (my_getpwuid((unsigned int) -1));
11266 }
11267 /*}}}*/
11268
11269 /*
11270  * Finish searching rights database for users.
11271 */
11272 /*{{{void my_endpwent()*/
11273 void Perl_my_endpwent(pTHX)
11274 {
11275     if (contxt) {
11276       _ckvmssts(sys$finish_rdb(&contxt));
11277       contxt= 0;
11278     }
11279 }
11280 /*}}}*/
11281
11282 #ifdef HOMEGROWN_POSIX_SIGNALS
11283   /* Signal handling routines, pulled into the core from POSIX.xs.
11284    *
11285    * We need these for threads, so they've been rolled into the core,
11286    * rather than left in POSIX.xs.
11287    *
11288    * (DRS, Oct 23, 1997)
11289    */
11290
11291   /* sigset_t is atomic under VMS, so these routines are easy */
11292 /*{{{int my_sigemptyset(sigset_t *) */
11293 int my_sigemptyset(sigset_t *set) {
11294     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11295     *set = 0; return 0;
11296 }
11297 /*}}}*/
11298
11299
11300 /*{{{int my_sigfillset(sigset_t *)*/
11301 int my_sigfillset(sigset_t *set) {
11302     int i;
11303     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11304     for (i = 0; i < NSIG; i++) *set |= (1 << i);
11305     return 0;
11306 }
11307 /*}}}*/
11308
11309
11310 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
11311 int my_sigaddset(sigset_t *set, int sig) {
11312     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11313     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11314     *set |= (1 << (sig - 1));
11315     return 0;
11316 }
11317 /*}}}*/
11318
11319
11320 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
11321 int my_sigdelset(sigset_t *set, int sig) {
11322     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11323     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11324     *set &= ~(1 << (sig - 1));
11325     return 0;
11326 }
11327 /*}}}*/
11328
11329
11330 /*{{{int my_sigismember(sigset_t *set, int sig)*/
11331 int my_sigismember(sigset_t *set, int sig) {
11332     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11333     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11334     return *set & (1 << (sig - 1));
11335 }
11336 /*}}}*/
11337
11338
11339 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
11340 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
11341     sigset_t tempmask;
11342
11343     /* If set and oset are both null, then things are badly wrong. Bail out. */
11344     if ((oset == NULL) && (set == NULL)) {
11345       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
11346       return -1;
11347     }
11348
11349     /* If set's null, then we're just handling a fetch. */
11350     if (set == NULL) {
11351         tempmask = sigblock(0);
11352     }
11353     else {
11354       switch (how) {
11355       case SIG_SETMASK:
11356         tempmask = sigsetmask(*set);
11357         break;
11358       case SIG_BLOCK:
11359         tempmask = sigblock(*set);
11360         break;
11361       case SIG_UNBLOCK:
11362         tempmask = sigblock(0);
11363         sigsetmask(*oset & ~tempmask);
11364         break;
11365       default:
11366         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11367         return -1;
11368       }
11369     }
11370
11371     /* Did they pass us an oset? If so, stick our holding mask into it */
11372     if (oset)
11373       *oset = tempmask;
11374
11375     return 0;
11376 }
11377 /*}}}*/
11378 #endif  /* HOMEGROWN_POSIX_SIGNALS */
11379
11380
11381 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11382  * my_utime(), and flex_stat(), all of which operate on UTC unless
11383  * VMSISH_TIMES is true.
11384  */
11385 /* method used to handle UTC conversions:
11386  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
11387  */
11388 static int gmtime_emulation_type;
11389 /* number of secs to add to UTC POSIX-style time to get local time */
11390 static long int utc_offset_secs;
11391
11392 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11393  * in vmsish.h.  #undef them here so we can call the CRTL routines
11394  * directly.
11395  */
11396 #undef gmtime
11397 #undef localtime
11398 #undef time
11399
11400
11401 /*
11402  * DEC C previous to 6.0 corrupts the behavior of the /prefix
11403  * qualifier with the extern prefix pragma.  This provisional
11404  * hack circumvents this prefix pragma problem in previous
11405  * precompilers.
11406  */
11407 #if defined(__VMS_VER) && __VMS_VER >= 70000000
11408 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
11409 #    pragma __extern_prefix save
11410 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
11411 #    define gmtime decc$__utctz_gmtime
11412 #    define localtime decc$__utctz_localtime
11413 #    define time decc$__utc_time
11414 #    pragma __extern_prefix restore
11415
11416      struct tm *gmtime(), *localtime();
11417
11418 #  endif
11419 #endif
11420
11421
11422 static time_t toutc_dst(time_t loc) {
11423   struct tm *rsltmp;
11424
11425   if ((rsltmp = localtime(&loc)) == NULL) return -1;
11426   loc -= utc_offset_secs;
11427   if (rsltmp->tm_isdst) loc -= 3600;
11428   return loc;
11429 }
11430 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11431        ((gmtime_emulation_type || my_time(NULL)), \
11432        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11433        ((secs) - utc_offset_secs))))
11434
11435 static time_t toloc_dst(time_t utc) {
11436   struct tm *rsltmp;
11437
11438   utc += utc_offset_secs;
11439   if ((rsltmp = localtime(&utc)) == NULL) return -1;
11440   if (rsltmp->tm_isdst) utc += 3600;
11441   return utc;
11442 }
11443 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11444        ((gmtime_emulation_type || my_time(NULL)), \
11445        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11446        ((secs) + utc_offset_secs))))
11447
11448 #ifndef RTL_USES_UTC
11449 /*
11450
11451     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
11452         DST starts on 1st sun of april      at 02:00  std time
11453             ends on last sun of october     at 02:00  dst time
11454     see the UCX management command reference, SET CONFIG TIMEZONE
11455     for formatting info.
11456
11457     No, it's not as general as it should be, but then again, NOTHING
11458     will handle UK times in a sensible way.
11459 */
11460
11461
11462 /*
11463     parse the DST start/end info:
11464     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
11465 */
11466
11467 static char *
11468 tz_parse_startend(char *s, struct tm *w, int *past)
11469 {
11470     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
11471     int ly, dozjd, d, m, n, hour, min, sec, j, k;
11472     time_t g;
11473
11474     if (!s)    return 0;
11475     if (!w) return 0;
11476     if (!past) return 0;
11477
11478     ly = 0;
11479     if (w->tm_year % 4        == 0) ly = 1;
11480     if (w->tm_year % 100      == 0) ly = 0;
11481     if (w->tm_year+1900 % 400 == 0) ly = 1;
11482     if (ly) dinm[1]++;
11483
11484     dozjd = isdigit(*s);
11485     if (*s == 'J' || *s == 'j' || dozjd) {
11486         if (!dozjd && !isdigit(*++s)) return 0;
11487         d = *s++ - '0';
11488         if (isdigit(*s)) {
11489             d = d*10 + *s++ - '0';
11490             if (isdigit(*s)) {
11491                 d = d*10 + *s++ - '0';
11492             }
11493         }
11494         if (d == 0) return 0;
11495         if (d > 366) return 0;
11496         d--;
11497         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
11498         g = d * 86400;
11499         dozjd = 1;
11500     } else if (*s == 'M' || *s == 'm') {
11501         if (!isdigit(*++s)) return 0;
11502         m = *s++ - '0';
11503         if (isdigit(*s)) m = 10*m + *s++ - '0';
11504         if (*s != '.') return 0;
11505         if (!isdigit(*++s)) return 0;
11506         n = *s++ - '0';
11507         if (n < 1 || n > 5) return 0;
11508         if (*s != '.') return 0;
11509         if (!isdigit(*++s)) return 0;
11510         d = *s++ - '0';
11511         if (d > 6) return 0;
11512     }
11513
11514     if (*s == '/') {
11515         if (!isdigit(*++s)) return 0;
11516         hour = *s++ - '0';
11517         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
11518         if (*s == ':') {
11519             if (!isdigit(*++s)) return 0;
11520             min = *s++ - '0';
11521             if (isdigit(*s)) min = 10*min + *s++ - '0';
11522             if (*s == ':') {
11523                 if (!isdigit(*++s)) return 0;
11524                 sec = *s++ - '0';
11525                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
11526             }
11527         }
11528     } else {
11529         hour = 2;
11530         min = 0;
11531         sec = 0;
11532     }
11533
11534     if (dozjd) {
11535         if (w->tm_yday < d) goto before;
11536         if (w->tm_yday > d) goto after;
11537     } else {
11538         if (w->tm_mon+1 < m) goto before;
11539         if (w->tm_mon+1 > m) goto after;
11540
11541         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
11542         k = d - j; /* mday of first d */
11543         if (k <= 0) k += 7;
11544         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
11545         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
11546         if (w->tm_mday < k) goto before;
11547         if (w->tm_mday > k) goto after;
11548     }
11549
11550     if (w->tm_hour < hour) goto before;
11551     if (w->tm_hour > hour) goto after;
11552     if (w->tm_min  < min)  goto before;
11553     if (w->tm_min  > min)  goto after;
11554     if (w->tm_sec  < sec)  goto before;
11555     goto after;
11556
11557 before:
11558     *past = 0;
11559     return s;
11560 after:
11561     *past = 1;
11562     return s;
11563 }
11564
11565
11566
11567
11568 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
11569
11570 static char *
11571 tz_parse_offset(char *s, int *offset)
11572 {
11573     int hour = 0, min = 0, sec = 0;
11574     int neg = 0;
11575     if (!s) return 0;
11576     if (!offset) return 0;
11577
11578     if (*s == '-') {neg++; s++;}
11579     if (*s == '+') s++;
11580     if (!isdigit(*s)) return 0;
11581     hour = *s++ - '0';
11582     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
11583     if (hour > 24) return 0;
11584     if (*s == ':') {
11585         if (!isdigit(*++s)) return 0;
11586         min = *s++ - '0';
11587         if (isdigit(*s)) min = min*10 + (*s++ - '0');
11588         if (min > 59) return 0;
11589         if (*s == ':') {
11590             if (!isdigit(*++s)) return 0;
11591             sec = *s++ - '0';
11592             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
11593             if (sec > 59) return 0;
11594         }
11595     }
11596
11597     *offset = (hour*60+min)*60 + sec;
11598     if (neg) *offset = -*offset;
11599     return s;
11600 }
11601
11602 /*
11603     input time is w, whatever type of time the CRTL localtime() uses.
11604     sets dst, the zone, and the gmtoff (seconds)
11605
11606     caches the value of TZ and UCX$TZ env variables; note that
11607     my_setenv looks for these and sets a flag if they're changed
11608     for efficiency.
11609
11610     We have to watch out for the "australian" case (dst starts in
11611     october, ends in april)...flagged by "reverse" and checked by
11612     scanning through the months of the previous year.
11613
11614 */
11615
11616 static int
11617 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
11618 {
11619     time_t when;
11620     struct tm *w2;
11621     char *s,*s2;
11622     char *dstzone, *tz, *s_start, *s_end;
11623     int std_off, dst_off, isdst;
11624     int y, dststart, dstend;
11625     static char envtz[1025];  /* longer than any logical, symbol, ... */
11626     static char ucxtz[1025];
11627     static char reversed = 0;
11628
11629     if (!w) return 0;
11630
11631     if (tz_updated) {
11632         tz_updated = 0;
11633         reversed = -1;  /* flag need to check  */
11634         envtz[0] = ucxtz[0] = '\0';
11635         tz = my_getenv("TZ",0);
11636         if (tz) strcpy(envtz, tz);
11637         tz = my_getenv("UCX$TZ",0);
11638         if (tz) strcpy(ucxtz, tz);
11639         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
11640     }
11641     tz = envtz;
11642     if (!*tz) tz = ucxtz;
11643
11644     s = tz;
11645     while (isalpha(*s)) s++;
11646     s = tz_parse_offset(s, &std_off);
11647     if (!s) return 0;
11648     if (!*s) {                  /* no DST, hurray we're done! */
11649         isdst = 0;
11650         goto done;
11651     }
11652
11653     dstzone = s;
11654     while (isalpha(*s)) s++;
11655     s2 = tz_parse_offset(s, &dst_off);
11656     if (s2) {
11657         s = s2;
11658     } else {
11659         dst_off = std_off - 3600;
11660     }
11661
11662     if (!*s) {      /* default dst start/end?? */
11663         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
11664             s = strchr(ucxtz,',');
11665         }
11666         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
11667     }
11668     if (*s != ',') return 0;
11669
11670     when = *w;
11671     when = _toutc(when);      /* convert to utc */
11672     when = when - std_off;    /* convert to pseudolocal time*/
11673
11674     w2 = localtime(&when);
11675     y = w2->tm_year;
11676     s_start = s+1;
11677     s = tz_parse_startend(s_start,w2,&dststart);
11678     if (!s) return 0;
11679     if (*s != ',') return 0;
11680
11681     when = *w;
11682     when = _toutc(when);      /* convert to utc */
11683     when = when - dst_off;    /* convert to pseudolocal time*/
11684     w2 = localtime(&when);
11685     if (w2->tm_year != y) {   /* spans a year, just check one time */
11686         when += dst_off - std_off;
11687         w2 = localtime(&when);
11688     }
11689     s_end = s+1;
11690     s = tz_parse_startend(s_end,w2,&dstend);
11691     if (!s) return 0;
11692
11693     if (reversed == -1) {  /* need to check if start later than end */
11694         int j, ds, de;
11695
11696         when = *w;
11697         if (when < 2*365*86400) {
11698             when += 2*365*86400;
11699         } else {
11700             when -= 365*86400;
11701         }
11702         w2 =localtime(&when);
11703         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
11704
11705         for (j = 0; j < 12; j++) {
11706             w2 =localtime(&when);
11707             tz_parse_startend(s_start,w2,&ds);
11708             tz_parse_startend(s_end,w2,&de);
11709             if (ds != de) break;
11710             when += 30*86400;
11711         }
11712         reversed = 0;
11713         if (de && !ds) reversed = 1;
11714     }
11715
11716     isdst = dststart && !dstend;
11717     if (reversed) isdst = dststart  || !dstend;
11718
11719 done:
11720     if (dst)    *dst = isdst;
11721     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
11722     if (isdst)  tz = dstzone;
11723     if (zone) {
11724         while(isalpha(*tz))  *zone++ = *tz++;
11725         *zone = '\0';
11726     }
11727     return 1;
11728 }
11729
11730 #endif /* !RTL_USES_UTC */
11731
11732 /* my_time(), my_localtime(), my_gmtime()
11733  * By default traffic in UTC time values, using CRTL gmtime() or
11734  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11735  * Note: We need to use these functions even when the CRTL has working
11736  * UTC support, since they also handle C<use vmsish qw(times);>
11737  *
11738  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
11739  * Modified by Charles Bailey <bailey@newman.upenn.edu>
11740  */
11741
11742 /*{{{time_t my_time(time_t *timep)*/
11743 time_t Perl_my_time(pTHX_ time_t *timep)
11744 {
11745   time_t when;
11746   struct tm *tm_p;
11747
11748   if (gmtime_emulation_type == 0) {
11749     int dstnow;
11750     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
11751                               /* results of calls to gmtime() and localtime() */
11752                               /* for same &base */
11753
11754     gmtime_emulation_type++;
11755     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11756       char off[LNM$C_NAMLENGTH+1];;
11757
11758       gmtime_emulation_type++;
11759       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11760         gmtime_emulation_type++;
11761         utc_offset_secs = 0;
11762         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11763       }
11764       else { utc_offset_secs = atol(off); }
11765     }
11766     else { /* We've got a working gmtime() */
11767       struct tm gmt, local;
11768
11769       gmt = *tm_p;
11770       tm_p = localtime(&base);
11771       local = *tm_p;
11772       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
11773       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11774       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
11775       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
11776     }
11777   }
11778
11779   when = time(NULL);
11780 # ifdef VMSISH_TIME
11781 # ifdef RTL_USES_UTC
11782   if (VMSISH_TIME) when = _toloc(when);
11783 # else
11784   if (!VMSISH_TIME) when = _toutc(when);
11785 # endif
11786 # endif
11787   if (timep != NULL) *timep = when;
11788   return when;
11789
11790 }  /* end of my_time() */
11791 /*}}}*/
11792
11793
11794 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11795 struct tm *
11796 Perl_my_gmtime(pTHX_ const time_t *timep)
11797 {
11798   char *p;
11799   time_t when;
11800   struct tm *rsltmp;
11801
11802   if (timep == NULL) {
11803     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11804     return NULL;
11805   }
11806   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11807
11808   when = *timep;
11809 # ifdef VMSISH_TIME
11810   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11811 #  endif
11812 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
11813   return gmtime(&when);
11814 # else
11815   /* CRTL localtime() wants local time as input, so does no tz correction */
11816   rsltmp = localtime(&when);
11817   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
11818   return rsltmp;
11819 #endif
11820 }  /* end of my_gmtime() */
11821 /*}}}*/
11822
11823
11824 /*{{{struct tm *my_localtime(const time_t *timep)*/
11825 struct tm *
11826 Perl_my_localtime(pTHX_ const time_t *timep)
11827 {
11828   time_t when, whenutc;
11829   struct tm *rsltmp;
11830   int dst, offset;
11831
11832   if (timep == NULL) {
11833     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11834     return NULL;
11835   }
11836   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11837   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11838
11839   when = *timep;
11840 # ifdef RTL_USES_UTC
11841 # ifdef VMSISH_TIME
11842   if (VMSISH_TIME) when = _toutc(when);
11843 # endif
11844   /* CRTL localtime() wants UTC as input, does tz correction itself */
11845   return localtime(&when);
11846
11847 # else /* !RTL_USES_UTC */
11848   whenutc = when;
11849 # ifdef VMSISH_TIME
11850   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
11851   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
11852 # endif
11853   dst = -1;
11854 #ifndef RTL_USES_UTC
11855   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
11856       when = whenutc - offset;                   /* pseudolocal time*/
11857   }
11858 # endif
11859   /* CRTL localtime() wants local time as input, so does no tz correction */
11860   rsltmp = localtime(&when);
11861   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
11862   return rsltmp;
11863 # endif
11864
11865 } /*  end of my_localtime() */
11866 /*}}}*/
11867
11868 /* Reset definitions for later calls */
11869 #define gmtime(t)    my_gmtime(t)
11870 #define localtime(t) my_localtime(t)
11871 #define time(t)      my_time(t)
11872
11873
11874 /* my_utime - update modification/access time of a file
11875  *
11876  * VMS 7.3 and later implementation
11877  * Only the UTC translation is home-grown. The rest is handled by the
11878  * CRTL utime(), which will take into account the relevant feature
11879  * logicals and ODS-5 volume characteristics for true access times.
11880  *
11881  * pre VMS 7.3 implementation:
11882  * The calling sequence is identical to POSIX utime(), but under
11883  * VMS with ODS-2, only the modification time is changed; ODS-2 does
11884  * not maintain access times.  Restrictions differ from the POSIX
11885  * definition in that the time can be changed as long as the
11886  * caller has permission to execute the necessary IO$_MODIFY $QIO;
11887  * no separate checks are made to insure that the caller is the
11888  * owner of the file or has special privs enabled.
11889  * Code here is based on Joe Meadows' FILE utility.
11890  *
11891  */
11892
11893 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11894  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
11895  * in 100 ns intervals.
11896  */
11897 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11898
11899 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11900 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11901 {
11902 #if __CRTL_VER >= 70300000
11903   struct utimbuf utc_utimes, *utc_utimesp;
11904
11905   if (utimes != NULL) {
11906     utc_utimes.actime = utimes->actime;
11907     utc_utimes.modtime = utimes->modtime;
11908 # ifdef VMSISH_TIME
11909     /* If input was local; convert to UTC for sys svc */
11910     if (VMSISH_TIME) {
11911       utc_utimes.actime = _toutc(utimes->actime);
11912       utc_utimes.modtime = _toutc(utimes->modtime);
11913     }
11914 # endif
11915     utc_utimesp = &utc_utimes;
11916   }
11917   else {
11918     utc_utimesp = NULL;
11919   }
11920
11921   return utime(file, utc_utimesp);
11922
11923 #else /* __CRTL_VER < 70300000 */
11924
11925   register int i;
11926   int sts;
11927   long int bintime[2], len = 2, lowbit, unixtime,
11928            secscale = 10000000; /* seconds --> 100 ns intervals */
11929   unsigned long int chan, iosb[2], retsts;
11930   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11931   struct FAB myfab = cc$rms_fab;
11932   struct NAM mynam = cc$rms_nam;
11933 #if defined (__DECC) && defined (__VAX)
11934   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11935    * at least through VMS V6.1, which causes a type-conversion warning.
11936    */
11937 #  pragma message save
11938 #  pragma message disable cvtdiftypes
11939 #endif
11940   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11941   struct fibdef myfib;
11942 #if defined (__DECC) && defined (__VAX)
11943   /* This should be right after the declaration of myatr, but due
11944    * to a bug in VAX DEC C, this takes effect a statement early.
11945    */
11946 #  pragma message restore
11947 #endif
11948   /* cast ok for read only parameter */
11949   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11950                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11951                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
11952
11953   if (file == NULL || *file == '\0') {
11954     SETERRNO(ENOENT, LIB$_INVARG);
11955     return -1;
11956   }
11957
11958   /* Convert to VMS format ensuring that it will fit in 255 characters */
11959   if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
11960       SETERRNO(ENOENT, LIB$_INVARG);
11961       return -1;
11962   }
11963   if (utimes != NULL) {
11964     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
11965      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11966      * Since time_t is unsigned long int, and lib$emul takes a signed long int
11967      * as input, we force the sign bit to be clear by shifting unixtime right
11968      * one bit, then multiplying by an extra factor of 2 in lib$emul().
11969      */
11970     lowbit = (utimes->modtime & 1) ? secscale : 0;
11971     unixtime = (long int) utimes->modtime;
11972 #   ifdef VMSISH_TIME
11973     /* If input was UTC; convert to local for sys svc */
11974     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
11975 #   endif
11976     unixtime >>= 1;  secscale <<= 1;
11977     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11978     if (!(retsts & 1)) {
11979       SETERRNO(EVMSERR, retsts);
11980       return -1;
11981     }
11982     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11983     if (!(retsts & 1)) {
11984       SETERRNO(EVMSERR, retsts);
11985       return -1;
11986     }
11987   }
11988   else {
11989     /* Just get the current time in VMS format directly */
11990     retsts = sys$gettim(bintime);
11991     if (!(retsts & 1)) {
11992       SETERRNO(EVMSERR, retsts);
11993       return -1;
11994     }
11995   }
11996
11997   myfab.fab$l_fna = vmsspec;
11998   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11999   myfab.fab$l_nam = &mynam;
12000   mynam.nam$l_esa = esa;
12001   mynam.nam$b_ess = (unsigned char) sizeof esa;
12002   mynam.nam$l_rsa = rsa;
12003   mynam.nam$b_rss = (unsigned char) sizeof rsa;
12004   if (decc_efs_case_preserve)
12005       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
12006
12007   /* Look for the file to be affected, letting RMS parse the file
12008    * specification for us as well.  I have set errno using only
12009    * values documented in the utime() man page for VMS POSIX.
12010    */
12011   retsts = sys$parse(&myfab,0,0);
12012   if (!(retsts & 1)) {
12013     set_vaxc_errno(retsts);
12014     if      (retsts == RMS$_PRV) set_errno(EACCES);
12015     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
12016     else                         set_errno(EVMSERR);
12017     return -1;
12018   }
12019   retsts = sys$search(&myfab,0,0);
12020   if (!(retsts & 1)) {
12021     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12022     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12023     set_vaxc_errno(retsts);
12024     if      (retsts == RMS$_PRV) set_errno(EACCES);
12025     else if (retsts == RMS$_FNF) set_errno(ENOENT);
12026     else                         set_errno(EVMSERR);
12027     return -1;
12028   }
12029
12030   devdsc.dsc$w_length = mynam.nam$b_dev;
12031   /* cast ok for read only parameter */
12032   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
12033
12034   retsts = sys$assign(&devdsc,&chan,0,0);
12035   if (!(retsts & 1)) {
12036     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12037     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12038     set_vaxc_errno(retsts);
12039     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
12040     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
12041     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
12042     else                               set_errno(EVMSERR);
12043     return -1;
12044   }
12045
12046   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
12047   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
12048
12049   memset((void *) &myfib, 0, sizeof myfib);
12050 #if defined(__DECC) || defined(__DECCXX)
12051   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
12052   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
12053   /* This prevents the revision time of the file being reset to the current
12054    * time as a result of our IO$_MODIFY $QIO. */
12055   myfib.fib$l_acctl = FIB$M_NORECORD;
12056 #else
12057   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
12058   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
12059   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
12060 #endif
12061   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
12062   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12063   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12064   _ckvmssts(sys$dassgn(chan));
12065   if (retsts & 1) retsts = iosb[0];
12066   if (!(retsts & 1)) {
12067     set_vaxc_errno(retsts);
12068     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12069     else                      set_errno(EVMSERR);
12070     return -1;
12071   }
12072
12073   return 0;
12074
12075 #endif /* #if __CRTL_VER >= 70300000 */
12076
12077 }  /* end of my_utime() */
12078 /*}}}*/
12079
12080 /*
12081  * flex_stat, flex_lstat, flex_fstat
12082  * basic stat, but gets it right when asked to stat
12083  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
12084  */
12085
12086 #ifndef _USE_STD_STAT
12087 /* encode_dev packs a VMS device name string into an integer to allow
12088  * simple comparisons. This can be used, for example, to check whether two
12089  * files are located on the same device, by comparing their encoded device
12090  * names. Even a string comparison would not do, because stat() reuses the
12091  * device name buffer for each call; so without encode_dev, it would be
12092  * necessary to save the buffer and use strcmp (this would mean a number of
12093  * changes to the standard Perl code, to say nothing of what a Perl script
12094  * would have to do.
12095  *
12096  * The device lock id, if it exists, should be unique (unless perhaps compared
12097  * with lock ids transferred from other nodes). We have a lock id if the disk is
12098  * mounted cluster-wide, which is when we tend to get long (host-qualified)
12099  * device names. Thus we use the lock id in preference, and only if that isn't
12100  * available, do we try to pack the device name into an integer (flagged by
12101  * the sign bit (LOCKID_MASK) being set).
12102  *
12103  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
12104  * name and its encoded form, but it seems very unlikely that we will find
12105  * two files on different disks that share the same encoded device names,
12106  * and even more remote that they will share the same file id (if the test
12107  * is to check for the same file).
12108  *
12109  * A better method might be to use sys$device_scan on the first call, and to
12110  * search for the device, returning an index into the cached array.
12111  * The number returned would be more intelligible.
12112  * This is probably not worth it, and anyway would take quite a bit longer
12113  * on the first call.
12114  */
12115 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
12116 static mydev_t encode_dev (pTHX_ const char *dev)
12117 {
12118   int i;
12119   unsigned long int f;
12120   mydev_t enc;
12121   char c;
12122   const char *q;
12123
12124   if (!dev || !dev[0]) return 0;
12125
12126 #if LOCKID_MASK
12127   {
12128     struct dsc$descriptor_s dev_desc;
12129     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
12130
12131     /* For cluster-mounted disks, the disk lock identifier is unique, so we
12132        can try that first. */
12133     dev_desc.dsc$w_length =  strlen (dev);
12134     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
12135     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
12136     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
12137     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
12138     if (!$VMS_STATUS_SUCCESS(status)) {
12139       switch (status) {
12140         case SS$_NOSUCHDEV:
12141           SETERRNO(ENODEV, status);
12142           return 0;
12143         default:
12144           _ckvmssts(status);
12145       }
12146     }
12147     if (lockid) return (lockid & ~LOCKID_MASK);
12148   }
12149 #endif
12150
12151   /* Otherwise we try to encode the device name */
12152   enc = 0;
12153   f = 1;
12154   i = 0;
12155   for (q = dev + strlen(dev); q--; q >= dev) {
12156     if (*q == ':')
12157         break;
12158     if (isdigit (*q))
12159       c= (*q) - '0';
12160     else if (isalpha (toupper (*q)))
12161       c= toupper (*q) - 'A' + (char)10;
12162     else
12163       continue; /* Skip '$'s */
12164     i++;
12165     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
12166     if (i>1) f *= 36;
12167     enc += f * (unsigned long int) c;
12168   }
12169   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
12170
12171 }  /* end of encode_dev() */
12172 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12173         device_no = encode_dev(aTHX_ devname)
12174 #else
12175 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12176         device_no = new_dev_no
12177 #endif
12178
12179 static int
12180 is_null_device(name)
12181     const char *name;
12182 {
12183   if (decc_bug_devnull != 0) {
12184     if (strncmp("/dev/null", name, 9) == 0)
12185       return 1;
12186   }
12187     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
12188        The underscore prefix, controller letter, and unit number are
12189        independently optional; for our purposes, the colon punctuation
12190        is not.  The colon can be trailed by optional directory and/or
12191        filename, but two consecutive colons indicates a nodename rather
12192        than a device.  [pr]  */
12193   if (*name == '_') ++name;
12194   if (tolower(*name++) != 'n') return 0;
12195   if (tolower(*name++) != 'l') return 0;
12196   if (tolower(*name) == 'a') ++name;
12197   if (*name == '0') ++name;
12198   return (*name++ == ':') && (*name != ':');
12199 }
12200
12201
12202 static I32
12203 Perl_cando_by_name_int
12204    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
12205 {
12206   char usrname[L_cuserid];
12207   struct dsc$descriptor_s usrdsc =
12208          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
12209   char *vmsname = NULL, *fileified = NULL;
12210   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
12211   unsigned short int retlen, trnlnm_iter_count;
12212   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12213   union prvdef curprv;
12214   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
12215          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
12216          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
12217   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
12218          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
12219          {0,0,0,0}};
12220   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
12221          {0,0,0,0}};
12222   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12223   Stat_t st;
12224   static int profile_context = -1;
12225
12226   if (!fname || !*fname) return FALSE;
12227
12228   /* Make sure we expand logical names, since sys$check_access doesn't */
12229   fileified = PerlMem_malloc(VMS_MAXRSS);
12230   if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12231   if (!strpbrk(fname,"/]>:")) {
12232       strcpy(fileified,fname);
12233       trnlnm_iter_count = 0;
12234       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
12235         trnlnm_iter_count++;
12236         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
12237       }
12238       fname = fileified;
12239   }
12240
12241   vmsname = PerlMem_malloc(VMS_MAXRSS);
12242   if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12243   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
12244     /* Don't know if already in VMS format, so make sure */
12245     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
12246       PerlMem_free(fileified);
12247       PerlMem_free(vmsname);
12248       return FALSE;
12249     }
12250   }
12251   else {
12252     strcpy(vmsname,fname);
12253   }
12254
12255   /* sys$check_access needs a file spec, not a directory spec.
12256    * Don't use flex_stat here, as that depends on thread context
12257    * having been initialized, and we may get here during startup.
12258    */
12259
12260   retlen = namdsc.dsc$w_length = strlen(vmsname);
12261   if (vmsname[retlen-1] == ']'
12262       || vmsname[retlen-1] == '>'
12263       || vmsname[retlen-1] == ':'
12264       || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
12265
12266       if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) {
12267         PerlMem_free(fileified);
12268         PerlMem_free(vmsname);
12269         return FALSE;
12270       }
12271       fname = fileified;
12272   }
12273   else {
12274       fname = vmsname;
12275   }
12276
12277   retlen = namdsc.dsc$w_length = strlen(fname);
12278   namdsc.dsc$a_pointer = (char *)fname;
12279
12280   switch (bit) {
12281     case S_IXUSR: case S_IXGRP: case S_IXOTH:
12282       access = ARM$M_EXECUTE;
12283       flags = CHP$M_READ;
12284       break;
12285     case S_IRUSR: case S_IRGRP: case S_IROTH:
12286       access = ARM$M_READ;
12287       flags = CHP$M_READ | CHP$M_USEREADALL;
12288       break;
12289     case S_IWUSR: case S_IWGRP: case S_IWOTH:
12290       access = ARM$M_WRITE;
12291       flags = CHP$M_READ | CHP$M_WRITE;
12292       break;
12293     case S_IDUSR: case S_IDGRP: case S_IDOTH:
12294       access = ARM$M_DELETE;
12295       flags = CHP$M_READ | CHP$M_WRITE;
12296       break;
12297     default:
12298       if (fileified != NULL)
12299         PerlMem_free(fileified);
12300       if (vmsname != NULL)
12301         PerlMem_free(vmsname);
12302       return FALSE;
12303   }
12304
12305   /* Before we call $check_access, create a user profile with the current
12306    * process privs since otherwise it just uses the default privs from the
12307    * UAF and might give false positives or negatives.  This only works on
12308    * VMS versions v6.0 and later since that's when sys$create_user_profile
12309    * became available.
12310    */
12311
12312   /* get current process privs and username */
12313   _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
12314   _ckvmssts_noperl(iosb[0]);
12315
12316 #if defined(__VMS_VER) && __VMS_VER >= 60000000
12317
12318   /* find out the space required for the profile */
12319   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
12320                                     &usrprodsc.dsc$w_length,&profile_context));
12321
12322   /* allocate space for the profile and get it filled in */
12323   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
12324   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12325   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
12326                                     &usrprodsc.dsc$w_length,&profile_context));
12327
12328   /* use the profile to check access to the file; free profile & analyze results */
12329   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
12330   PerlMem_free(usrprodsc.dsc$a_pointer);
12331   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
12332
12333 #else
12334
12335   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
12336
12337 #endif
12338
12339   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
12340       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
12341       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
12342     set_vaxc_errno(retsts);
12343     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12344     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12345     else set_errno(ENOENT);
12346     if (fileified != NULL)
12347       PerlMem_free(fileified);
12348     if (vmsname != NULL)
12349       PerlMem_free(vmsname);
12350     return FALSE;
12351   }
12352   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12353     if (fileified != NULL)
12354       PerlMem_free(fileified);
12355     if (vmsname != NULL)
12356       PerlMem_free(vmsname);
12357     return TRUE;
12358   }
12359   _ckvmssts_noperl(retsts);
12360
12361   if (fileified != NULL)
12362     PerlMem_free(fileified);
12363   if (vmsname != NULL)
12364     PerlMem_free(vmsname);
12365   return FALSE;  /* Should never get here */
12366
12367 }
12368
12369 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
12370 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12371  * subset of the applicable information.
12372  */
12373 bool
12374 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12375 {
12376   return cando_by_name_int
12377         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12378 }  /* end of cando() */
12379 /*}}}*/
12380
12381
12382 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12383 I32
12384 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12385 {
12386    return cando_by_name_int(bit, effective, fname, 0);
12387
12388 }  /* end of cando_by_name() */
12389 /*}}}*/
12390
12391
12392 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12393 int
12394 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12395 {
12396   if (!fstat(fd,(stat_t *) statbufp)) {
12397     char *cptr;
12398     char *vms_filename;
12399     vms_filename = PerlMem_malloc(VMS_MAXRSS);
12400     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12401
12402     /* Save name for cando by name in VMS format */
12403     cptr = getname(fd, vms_filename, 1);
12404
12405     /* This should not happen, but just in case */
12406     if (cptr == NULL) {
12407         statbufp->st_devnam[0] = 0;
12408     }
12409     else {
12410         /* Make sure that the saved name fits in 255 characters */
12411         cptr = int_rmsexpand_vms
12412                        (vms_filename,
12413                         statbufp->st_devnam,
12414                         0);
12415         if (cptr == NULL)
12416             statbufp->st_devnam[0] = 0;
12417     }
12418     PerlMem_free(vms_filename);
12419
12420     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12421     VMS_DEVICE_ENCODE
12422         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12423
12424 #   ifdef RTL_USES_UTC
12425 #   ifdef VMSISH_TIME
12426     if (VMSISH_TIME) {
12427       statbufp->st_mtime = _toloc(statbufp->st_mtime);
12428       statbufp->st_atime = _toloc(statbufp->st_atime);
12429       statbufp->st_ctime = _toloc(statbufp->st_ctime);
12430     }
12431 #   endif
12432 #   else
12433 #   ifdef VMSISH_TIME
12434     if (!VMSISH_TIME) { /* Return UTC instead of local time */
12435 #   else
12436     if (1) {
12437 #   endif
12438       statbufp->st_mtime = _toutc(statbufp->st_mtime);
12439       statbufp->st_atime = _toutc(statbufp->st_atime);
12440       statbufp->st_ctime = _toutc(statbufp->st_ctime);
12441     }
12442 #endif
12443     return 0;
12444   }
12445   return -1;
12446
12447 }  /* end of flex_fstat() */
12448 /*}}}*/
12449
12450 #if !defined(__VAX) && __CRTL_VER >= 80200000
12451 #ifdef lstat
12452 #undef lstat
12453 #endif
12454 #else
12455 #ifdef lstat
12456 #undef lstat
12457 #endif
12458 #define lstat(_x, _y) stat(_x, _y)
12459 #endif
12460
12461 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
12462
12463 static int
12464 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12465 {
12466     char fileified[VMS_MAXRSS];
12467     char temp_fspec[VMS_MAXRSS];
12468     char *save_spec;
12469     int retval = -1;
12470     dSAVEDERRNO;
12471
12472     if (!fspec) return retval;
12473     SAVE_ERRNO;
12474     strcpy(temp_fspec, fspec);
12475
12476     if (decc_bug_devnull != 0) {
12477       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
12478         memset(statbufp,0,sizeof *statbufp);
12479         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12480         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12481         statbufp->st_uid = 0x00010001;
12482         statbufp->st_gid = 0x0001;
12483         time((time_t *)&statbufp->st_mtime);
12484         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12485         return 0;
12486       }
12487     }
12488
12489     /* Try for a directory name first.  If fspec contains a filename without
12490      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12491      * and sea:[wine.dark]water. exist, we prefer the directory here.
12492      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12493      * not sea:[wine.dark]., if the latter exists.  If the intended target is
12494      * the file with null type, specify this by calling flex_stat() with
12495      * a '.' at the end of fspec.
12496      *
12497      * If we are in Posix filespec mode, accept the filename as is.
12498      */
12499
12500
12501 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12502   /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
12503    * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
12504    */
12505   if (!decc_efs_charset)
12506     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
12507 #endif
12508
12509 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12510   if (decc_posix_compliant_pathnames == 0) {
12511 #endif
12512     if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
12513       if (lstat_flag == 0)
12514         retval = stat(fileified,(stat_t *) statbufp);
12515       else
12516         retval = lstat(fileified,(stat_t *) statbufp);
12517       save_spec = fileified;
12518     }
12519     if (retval) {
12520       if (lstat_flag == 0)
12521         retval = stat(temp_fspec,(stat_t *) statbufp);
12522       else
12523         retval = lstat(temp_fspec,(stat_t *) statbufp);
12524       save_spec = temp_fspec;
12525     }
12526 /*
12527  * In debugging, on 8.3 Alpha, I found a case where stat was returning a
12528  * file not found error for a directory named foo:[bar.t] or /foo/bar/t
12529  * and lstat was working correctly for the same file.
12530  * The only syntax that was working for stat was "foo:[bar]t.dir".
12531  *
12532  * Other directories with the same syntax worked fine.
12533  * So work around the problem when it shows up here.
12534  */
12535     if (retval) {
12536         int save_errno = errno;
12537         if (do_tovmsspec(fspec, temp_fspec, 0, NULL) != NULL) {
12538             if (do_fileify_dirspec(temp_fspec, fileified, 0, NULL) != NULL) {
12539                 retval = stat(fileified, (stat_t *) statbufp);
12540                 save_spec = fileified;
12541             }
12542         }
12543         /* Restore the errno value if third stat does not succeed */
12544         if (retval != 0)
12545             errno = save_errno;
12546     }
12547 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12548   } else {
12549     if (lstat_flag == 0)
12550       retval = stat(temp_fspec,(stat_t *) statbufp);
12551     else
12552       retval = lstat(temp_fspec,(stat_t *) statbufp);
12553       save_spec = temp_fspec;
12554   }
12555 #endif
12556
12557 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12558   /* As you were... */
12559   if (!decc_efs_charset)
12560     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12561 #endif
12562
12563     if (!retval) {
12564     char * cptr;
12565     int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12566
12567       /* If this is an lstat, do not follow the link */
12568       if (lstat_flag)
12569         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12570
12571       cptr = int_rmsexpand_tovms(save_spec, statbufp->st_devnam, rmsex_flags);
12572       if (cptr == NULL)
12573         statbufp->st_devnam[0] = 0;
12574
12575       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12576       VMS_DEVICE_ENCODE
12577         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12578 #     ifdef RTL_USES_UTC
12579 #     ifdef VMSISH_TIME
12580       if (VMSISH_TIME) {
12581         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12582         statbufp->st_atime = _toloc(statbufp->st_atime);
12583         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12584       }
12585 #     endif
12586 #     else
12587 #     ifdef VMSISH_TIME
12588       if (!VMSISH_TIME) { /* Return UTC instead of local time */
12589 #     else
12590       if (1) {
12591 #     endif
12592         statbufp->st_mtime = _toutc(statbufp->st_mtime);
12593         statbufp->st_atime = _toutc(statbufp->st_atime);
12594         statbufp->st_ctime = _toutc(statbufp->st_ctime);
12595       }
12596 #     endif
12597     }
12598     /* If we were successful, leave errno where we found it */
12599     if (retval == 0) RESTORE_ERRNO;
12600     return retval;
12601
12602 }  /* end of flex_stat_int() */
12603
12604
12605 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12606 int
12607 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12608 {
12609    return flex_stat_int(fspec, statbufp, 0);
12610 }
12611 /*}}}*/
12612
12613 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12614 int
12615 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12616 {
12617    return flex_stat_int(fspec, statbufp, 1);
12618 }
12619 /*}}}*/
12620
12621
12622 /*{{{char *my_getlogin()*/
12623 /* VMS cuserid == Unix getlogin, except calling sequence */
12624 char *
12625 my_getlogin(void)
12626 {
12627     static char user[L_cuserid];
12628     return cuserid(user);
12629 }
12630 /*}}}*/
12631
12632
12633 /*  rmscopy - copy a file using VMS RMS routines
12634  *
12635  *  Copies contents and attributes of spec_in to spec_out, except owner
12636  *  and protection information.  Name and type of spec_in are used as
12637  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
12638  *  should try to propagate timestamps from the input file to the output file.
12639  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
12640  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
12641  *  propagated to the output file at creation iff the output file specification
12642  *  did not contain an explicit name or type, and the revision date is always
12643  *  updated at the end of the copy operation.  If it is greater than 0, then
12644  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12645  *  other than the revision date should be propagated, and bit 1 indicates
12646  *  that the revision date should be propagated.
12647  *
12648  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12649  *
12650  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12651  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
12652  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
12653  * as part of the Perl standard distribution under the terms of the
12654  * GNU General Public License or the Perl Artistic License.  Copies
12655  * of each may be found in the Perl standard distribution.
12656  */ /* FIXME */
12657 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12658 int
12659 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12660 {
12661     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12662          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12663     unsigned long int i, sts, sts2;
12664     int dna_len;
12665     struct FAB fab_in, fab_out;
12666     struct RAB rab_in, rab_out;
12667     rms_setup_nam(nam);
12668     rms_setup_nam(nam_out);
12669     struct XABDAT xabdat;
12670     struct XABFHC xabfhc;
12671     struct XABRDT xabrdt;
12672     struct XABSUM xabsum;
12673
12674     vmsin = PerlMem_malloc(VMS_MAXRSS);
12675     if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12676     vmsout = PerlMem_malloc(VMS_MAXRSS);
12677     if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12678     if (!spec_in  || !*spec_in  || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
12679         !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
12680       PerlMem_free(vmsin);
12681       PerlMem_free(vmsout);
12682       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12683       return 0;
12684     }
12685
12686     esa = PerlMem_malloc(VMS_MAXRSS);
12687     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12688     esal = NULL;
12689 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12690     esal = PerlMem_malloc(VMS_MAXRSS);
12691     if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12692 #endif
12693     fab_in = cc$rms_fab;
12694     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12695     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12696     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12697     fab_in.fab$l_fop = FAB$M_SQO;
12698     rms_bind_fab_nam(fab_in, nam);
12699     fab_in.fab$l_xab = (void *) &xabdat;
12700
12701     rsa = PerlMem_malloc(VMS_MAXRSS);
12702     if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12703     rsal = NULL;
12704 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12705     rsal = PerlMem_malloc(VMS_MAXRSS);
12706     if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12707 #endif
12708     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12709     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12710     rms_nam_esl(nam) = 0;
12711     rms_nam_rsl(nam) = 0;
12712     rms_nam_esll(nam) = 0;
12713     rms_nam_rsll(nam) = 0;
12714 #ifdef NAM$M_NO_SHORT_UPCASE
12715     if (decc_efs_case_preserve)
12716         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12717 #endif
12718
12719     xabdat = cc$rms_xabdat;        /* To get creation date */
12720     xabdat.xab$l_nxt = (void *) &xabfhc;
12721
12722     xabfhc = cc$rms_xabfhc;        /* To get record length */
12723     xabfhc.xab$l_nxt = (void *) &xabsum;
12724
12725     xabsum = cc$rms_xabsum;        /* To get key and area information */
12726
12727     if (!((sts = sys$open(&fab_in)) & 1)) {
12728       PerlMem_free(vmsin);
12729       PerlMem_free(vmsout);
12730       PerlMem_free(esa);
12731       if (esal != NULL)
12732         PerlMem_free(esal);
12733       PerlMem_free(rsa);
12734       if (rsal != NULL)
12735         PerlMem_free(rsal);
12736       set_vaxc_errno(sts);
12737       switch (sts) {
12738         case RMS$_FNF: case RMS$_DNF:
12739           set_errno(ENOENT); break;
12740         case RMS$_DIR:
12741           set_errno(ENOTDIR); break;
12742         case RMS$_DEV:
12743           set_errno(ENODEV); break;
12744         case RMS$_SYN:
12745           set_errno(EINVAL); break;
12746         case RMS$_PRV:
12747           set_errno(EACCES); break;
12748         default:
12749           set_errno(EVMSERR);
12750       }
12751       return 0;
12752     }
12753
12754     nam_out = nam;
12755     fab_out = fab_in;
12756     fab_out.fab$w_ifi = 0;
12757     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12758     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12759     fab_out.fab$l_fop = FAB$M_SQO;
12760     rms_bind_fab_nam(fab_out, nam_out);
12761     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12762     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12763     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12764     esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12765     if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12766     rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12767     if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12768     esal_out = NULL;
12769     rsal_out = NULL;
12770 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12771     esal_out = PerlMem_malloc(VMS_MAXRSS);
12772     if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12773     rsal_out = PerlMem_malloc(VMS_MAXRSS);
12774     if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12775 #endif
12776     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12777     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12778
12779     if (preserve_dates == 0) {  /* Act like DCL COPY */
12780       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12781       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
12782       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12783         PerlMem_free(vmsin);
12784         PerlMem_free(vmsout);
12785         PerlMem_free(esa);
12786         if (esal != NULL)
12787             PerlMem_free(esal);
12788         PerlMem_free(rsa);
12789         if (rsal != NULL)
12790             PerlMem_free(rsal);
12791         PerlMem_free(esa_out);
12792         if (esal_out != NULL)
12793             PerlMem_free(esal_out);
12794         PerlMem_free(rsa_out);
12795         if (rsal_out != NULL)
12796             PerlMem_free(rsal_out);
12797         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12798         set_vaxc_errno(sts);
12799         return 0;
12800       }
12801       fab_out.fab$l_xab = (void *) &xabdat;
12802       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12803         preserve_dates = 1;
12804     }
12805     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
12806       preserve_dates =0;      /* bitmask from this point forward   */
12807
12808     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12809     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12810       PerlMem_free(vmsin);
12811       PerlMem_free(vmsout);
12812       PerlMem_free(esa);
12813       if (esal != NULL)
12814           PerlMem_free(esal);
12815       PerlMem_free(rsa);
12816       if (rsal != NULL)
12817           PerlMem_free(rsal);
12818       PerlMem_free(esa_out);
12819       if (esal_out != NULL)
12820           PerlMem_free(esal_out);
12821       PerlMem_free(rsa_out);
12822       if (rsal_out != NULL)
12823           PerlMem_free(rsal_out);
12824       set_vaxc_errno(sts);
12825       switch (sts) {
12826         case RMS$_DNF:
12827           set_errno(ENOENT); break;
12828         case RMS$_DIR:
12829           set_errno(ENOTDIR); break;
12830         case RMS$_DEV:
12831           set_errno(ENODEV); break;
12832         case RMS$_SYN:
12833           set_errno(EINVAL); break;
12834         case RMS$_PRV:
12835           set_errno(EACCES); break;
12836         default:
12837           set_errno(EVMSERR);
12838       }
12839       return 0;
12840     }
12841     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
12842     if (preserve_dates & 2) {
12843       /* sys$close() will process xabrdt, not xabdat */
12844       xabrdt = cc$rms_xabrdt;
12845 #ifndef __GNUC__
12846       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12847 #else
12848       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12849        * is unsigned long[2], while DECC & VAXC use a struct */
12850       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12851 #endif
12852       fab_out.fab$l_xab = (void *) &xabrdt;
12853     }
12854
12855     ubf = PerlMem_malloc(32256);
12856     if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12857     rab_in = cc$rms_rab;
12858     rab_in.rab$l_fab = &fab_in;
12859     rab_in.rab$l_rop = RAB$M_BIO;
12860     rab_in.rab$l_ubf = ubf;
12861     rab_in.rab$w_usz = 32256;
12862     if (!((sts = sys$connect(&rab_in)) & 1)) {
12863       sys$close(&fab_in); sys$close(&fab_out);
12864       PerlMem_free(vmsin);
12865       PerlMem_free(vmsout);
12866       PerlMem_free(ubf);
12867       PerlMem_free(esa);
12868       if (esal != NULL)
12869           PerlMem_free(esal);
12870       PerlMem_free(rsa);
12871       if (rsal != NULL)
12872           PerlMem_free(rsal);
12873       PerlMem_free(esa_out);
12874       if (esal_out != NULL)
12875           PerlMem_free(esal_out);
12876       PerlMem_free(rsa_out);
12877       if (rsal_out != NULL)
12878           PerlMem_free(rsal_out);
12879       set_errno(EVMSERR); set_vaxc_errno(sts);
12880       return 0;
12881     }
12882
12883     rab_out = cc$rms_rab;
12884     rab_out.rab$l_fab = &fab_out;
12885     rab_out.rab$l_rbf = ubf;
12886     if (!((sts = sys$connect(&rab_out)) & 1)) {
12887       sys$close(&fab_in); sys$close(&fab_out);
12888       PerlMem_free(vmsin);
12889       PerlMem_free(vmsout);
12890       PerlMem_free(ubf);
12891       PerlMem_free(esa);
12892       if (esal != NULL)
12893           PerlMem_free(esal);
12894       PerlMem_free(rsa);
12895       if (rsal != NULL)
12896           PerlMem_free(rsal);
12897       PerlMem_free(esa_out);
12898       if (esal_out != NULL)
12899           PerlMem_free(esal_out);
12900       PerlMem_free(rsa_out);
12901       if (rsal_out != NULL)
12902           PerlMem_free(rsal_out);
12903       set_errno(EVMSERR); set_vaxc_errno(sts);
12904       return 0;
12905     }
12906
12907     while ((sts = sys$read(&rab_in))) {  /* always true  */
12908       if (sts == RMS$_EOF) break;
12909       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12910       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12911         sys$close(&fab_in); sys$close(&fab_out);
12912         PerlMem_free(vmsin);
12913         PerlMem_free(vmsout);
12914         PerlMem_free(ubf);
12915         PerlMem_free(esa);
12916         if (esal != NULL)
12917             PerlMem_free(esal);
12918         PerlMem_free(rsa);
12919         if (rsal != NULL)
12920             PerlMem_free(rsal);
12921         PerlMem_free(esa_out);
12922         if (esal_out != NULL)
12923             PerlMem_free(esal_out);
12924         PerlMem_free(rsa_out);
12925         if (rsal_out != NULL)
12926             PerlMem_free(rsal_out);
12927         set_errno(EVMSERR); set_vaxc_errno(sts);
12928         return 0;
12929       }
12930     }
12931
12932
12933     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
12934     sys$close(&fab_in);  sys$close(&fab_out);
12935     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12936
12937     PerlMem_free(vmsin);
12938     PerlMem_free(vmsout);
12939     PerlMem_free(ubf);
12940     PerlMem_free(esa);
12941     if (esal != NULL)
12942         PerlMem_free(esal);
12943     PerlMem_free(rsa);
12944     if (rsal != NULL)
12945         PerlMem_free(rsal);
12946     PerlMem_free(esa_out);
12947     if (esal_out != NULL)
12948         PerlMem_free(esal_out);
12949     PerlMem_free(rsa_out);
12950     if (rsal_out != NULL)
12951         PerlMem_free(rsal_out);
12952
12953     if (!(sts & 1)) {
12954       set_errno(EVMSERR); set_vaxc_errno(sts);
12955       return 0;
12956     }
12957
12958     return 1;
12959
12960 }  /* end of rmscopy() */
12961 /*}}}*/
12962
12963
12964 /***  The following glue provides 'hooks' to make some of the routines
12965  * from this file available from Perl.  These routines are sufficiently
12966  * basic, and are required sufficiently early in the build process,
12967  * that's it's nice to have them available to miniperl as well as the
12968  * full Perl, so they're set up here instead of in an extension.  The
12969  * Perl code which handles importation of these names into a given
12970  * package lives in [.VMS]Filespec.pm in @INC.
12971  */
12972
12973 void
12974 rmsexpand_fromperl(pTHX_ CV *cv)
12975 {
12976   dXSARGS;
12977   char *fspec, *defspec = NULL, *rslt;
12978   STRLEN n_a;
12979   int fs_utf8, dfs_utf8;
12980
12981   fs_utf8 = 0;
12982   dfs_utf8 = 0;
12983   if (!items || items > 2)
12984     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12985   fspec = SvPV(ST(0),n_a);
12986   fs_utf8 = SvUTF8(ST(0));
12987   if (!fspec || !*fspec) XSRETURN_UNDEF;
12988   if (items == 2) {
12989     defspec = SvPV(ST(1),n_a);
12990     dfs_utf8 = SvUTF8(ST(1));
12991   }
12992   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12993   ST(0) = sv_newmortal();
12994   if (rslt != NULL) {
12995     sv_usepvn(ST(0),rslt,strlen(rslt));
12996     if (fs_utf8) {
12997         SvUTF8_on(ST(0));
12998     }
12999   }
13000   XSRETURN(1);
13001 }
13002
13003 void
13004 vmsify_fromperl(pTHX_ CV *cv)
13005 {
13006   dXSARGS;
13007   char *vmsified;
13008   STRLEN n_a;
13009   int utf8_fl;
13010
13011   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
13012   utf8_fl = SvUTF8(ST(0));
13013   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13014   ST(0) = sv_newmortal();
13015   if (vmsified != NULL) {
13016     sv_usepvn(ST(0),vmsified,strlen(vmsified));
13017     if (utf8_fl) {
13018         SvUTF8_on(ST(0));
13019     }
13020   }
13021   XSRETURN(1);
13022 }
13023
13024 void
13025 unixify_fromperl(pTHX_ CV *cv)
13026 {
13027   dXSARGS;
13028   char *unixified;
13029   STRLEN n_a;
13030   int utf8_fl;
13031
13032   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
13033   utf8_fl = SvUTF8(ST(0));
13034   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13035   ST(0) = sv_newmortal();
13036   if (unixified != NULL) {
13037     sv_usepvn(ST(0),unixified,strlen(unixified));
13038     if (utf8_fl) {
13039         SvUTF8_on(ST(0));
13040     }
13041   }
13042   XSRETURN(1);
13043 }
13044
13045 void
13046 fileify_fromperl(pTHX_ CV *cv)
13047 {
13048   dXSARGS;
13049   char *fileified;
13050   STRLEN n_a;
13051   int utf8_fl;
13052
13053   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
13054   utf8_fl = SvUTF8(ST(0));
13055   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13056   ST(0) = sv_newmortal();
13057   if (fileified != NULL) {
13058     sv_usepvn(ST(0),fileified,strlen(fileified));
13059     if (utf8_fl) {
13060         SvUTF8_on(ST(0));
13061     }
13062   }
13063   XSRETURN(1);
13064 }
13065
13066 void
13067 pathify_fromperl(pTHX_ CV *cv)
13068 {
13069   dXSARGS;
13070   char *pathified;
13071   STRLEN n_a;
13072   int utf8_fl;
13073
13074   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
13075   utf8_fl = SvUTF8(ST(0));
13076   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13077   ST(0) = sv_newmortal();
13078   if (pathified != NULL) {
13079     sv_usepvn(ST(0),pathified,strlen(pathified));
13080     if (utf8_fl) {
13081         SvUTF8_on(ST(0));
13082     }
13083   }
13084   XSRETURN(1);
13085 }
13086
13087 void
13088 vmspath_fromperl(pTHX_ CV *cv)
13089 {
13090   dXSARGS;
13091   char *vmspath;
13092   STRLEN n_a;
13093   int utf8_fl;
13094
13095   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
13096   utf8_fl = SvUTF8(ST(0));
13097   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13098   ST(0) = sv_newmortal();
13099   if (vmspath != NULL) {
13100     sv_usepvn(ST(0),vmspath,strlen(vmspath));
13101     if (utf8_fl) {
13102         SvUTF8_on(ST(0));
13103     }
13104   }
13105   XSRETURN(1);
13106 }
13107
13108 void
13109 unixpath_fromperl(pTHX_ CV *cv)
13110 {
13111   dXSARGS;
13112   char *unixpath;
13113   STRLEN n_a;
13114   int utf8_fl;
13115
13116   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
13117   utf8_fl = SvUTF8(ST(0));
13118   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13119   ST(0) = sv_newmortal();
13120   if (unixpath != NULL) {
13121     sv_usepvn(ST(0),unixpath,strlen(unixpath));
13122     if (utf8_fl) {
13123         SvUTF8_on(ST(0));
13124     }
13125   }
13126   XSRETURN(1);
13127 }
13128
13129 void
13130 candelete_fromperl(pTHX_ CV *cv)
13131 {
13132   dXSARGS;
13133   char *fspec, *fsp;
13134   SV *mysv;
13135   IO *io;
13136   STRLEN n_a;
13137
13138   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
13139
13140   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13141   Newx(fspec, VMS_MAXRSS, char);
13142   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
13143   if (SvTYPE(mysv) == SVt_PVGV) {
13144     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
13145       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13146       ST(0) = &PL_sv_no;
13147       Safefree(fspec);
13148       XSRETURN(1);
13149     }
13150     fsp = fspec;
13151   }
13152   else {
13153     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
13154       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13155       ST(0) = &PL_sv_no;
13156       Safefree(fspec);
13157       XSRETURN(1);
13158     }
13159   }
13160
13161   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
13162   Safefree(fspec);
13163   XSRETURN(1);
13164 }
13165
13166 void
13167 rmscopy_fromperl(pTHX_ CV *cv)
13168 {
13169   dXSARGS;
13170   char *inspec, *outspec, *inp, *outp;
13171   int date_flag;
13172   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
13173                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13174   unsigned long int sts;
13175   SV *mysv;
13176   IO *io;
13177   STRLEN n_a;
13178
13179   if (items < 2 || items > 3)
13180     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
13181
13182   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13183   Newx(inspec, VMS_MAXRSS, char);
13184   if (SvTYPE(mysv) == SVt_PVGV) {
13185     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
13186       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13187       ST(0) = &PL_sv_no;
13188       Safefree(inspec);
13189       XSRETURN(1);
13190     }
13191     inp = inspec;
13192   }
13193   else {
13194     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
13195       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13196       ST(0) = &PL_sv_no;
13197       Safefree(inspec);
13198       XSRETURN(1);
13199     }
13200   }
13201   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
13202   Newx(outspec, VMS_MAXRSS, char);
13203   if (SvTYPE(mysv) == SVt_PVGV) {
13204     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
13205       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13206       ST(0) = &PL_sv_no;
13207       Safefree(inspec);
13208       Safefree(outspec);
13209       XSRETURN(1);
13210     }
13211     outp = outspec;
13212   }
13213   else {
13214     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
13215       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13216       ST(0) = &PL_sv_no;
13217       Safefree(inspec);
13218       Safefree(outspec);
13219       XSRETURN(1);
13220     }
13221   }
13222   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
13223
13224   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
13225   Safefree(inspec);
13226   Safefree(outspec);
13227   XSRETURN(1);
13228 }
13229
13230 /* The mod2fname is limited to shorter filenames by design, so it should
13231  * not be modified to support longer EFS pathnames
13232  */
13233 void
13234 mod2fname(pTHX_ CV *cv)
13235 {
13236   dXSARGS;
13237   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
13238        workbuff[NAM$C_MAXRSS*1 + 1];
13239   int total_namelen = 3, counter, num_entries;
13240   /* ODS-5 ups this, but we want to be consistent, so... */
13241   int max_name_len = 39;
13242   AV *in_array = (AV *)SvRV(ST(0));
13243
13244   num_entries = av_len(in_array);
13245
13246   /* All the names start with PL_. */
13247   strcpy(ultimate_name, "PL_");
13248
13249   /* Clean up our working buffer */
13250   Zero(work_name, sizeof(work_name), char);
13251
13252   /* Run through the entries and build up a working name */
13253   for(counter = 0; counter <= num_entries; counter++) {
13254     /* If it's not the first name then tack on a __ */
13255     if (counter) {
13256       strcat(work_name, "__");
13257     }
13258     strcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)));
13259   }
13260
13261   /* Check to see if we actually have to bother...*/
13262   if (strlen(work_name) + 3 <= max_name_len) {
13263     strcat(ultimate_name, work_name);
13264   } else {
13265     /* It's too darned big, so we need to go strip. We use the same */
13266     /* algorithm as xsubpp does. First, strip out doubled __ */
13267     char *source, *dest, last;
13268     dest = workbuff;
13269     last = 0;
13270     for (source = work_name; *source; source++) {
13271       if (last == *source && last == '_') {
13272         continue;
13273       }
13274       *dest++ = *source;
13275       last = *source;
13276     }
13277     /* Go put it back */
13278     strcpy(work_name, workbuff);
13279     /* Is it still too big? */
13280     if (strlen(work_name) + 3 > max_name_len) {
13281       /* Strip duplicate letters */
13282       last = 0;
13283       dest = workbuff;
13284       for (source = work_name; *source; source++) {
13285         if (last == toupper(*source)) {
13286         continue;
13287         }
13288         *dest++ = *source;
13289         last = toupper(*source);
13290       }
13291       strcpy(work_name, workbuff);
13292     }
13293
13294     /* Is it *still* too big? */
13295     if (strlen(work_name) + 3 > max_name_len) {
13296       /* Too bad, we truncate */
13297       work_name[max_name_len - 2] = 0;
13298     }
13299     strcat(ultimate_name, work_name);
13300   }
13301
13302   /* Okay, return it */
13303   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
13304   XSRETURN(1);
13305 }
13306
13307 void
13308 hushexit_fromperl(pTHX_ CV *cv)
13309 {
13310     dXSARGS;
13311
13312     if (items > 0) {
13313         VMSISH_HUSHED = SvTRUE(ST(0));
13314     }
13315     ST(0) = boolSV(VMSISH_HUSHED);
13316     XSRETURN(1);
13317 }
13318
13319
13320 PerlIO *
13321 Perl_vms_start_glob
13322    (pTHX_ SV *tmpglob,
13323     IO *io)
13324 {
13325     PerlIO *fp;
13326     struct vs_str_st *rslt;
13327     char *vmsspec;
13328     char *rstr;
13329     char *begin, *cp;
13330     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13331     PerlIO *tmpfp;
13332     STRLEN i;
13333     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13334     struct dsc$descriptor_vs rsdsc;
13335     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13336     unsigned long hasver = 0, isunix = 0;
13337     unsigned long int lff_flags = 0;
13338     int rms_sts;
13339
13340     if (!SvOK(tmpglob)) {
13341         SETERRNO(ENOENT,RMS$_FNF);
13342         return NULL;
13343     }
13344
13345 #ifdef VMS_LONGNAME_SUPPORT
13346     lff_flags = LIB$M_FIL_LONG_NAMES;
13347 #endif
13348     /* The Newx macro will not allow me to assign a smaller array
13349      * to the rslt pointer, so we will assign it to the begin char pointer
13350      * and then copy the value into the rslt pointer.
13351      */
13352     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13353     rslt = (struct vs_str_st *)begin;
13354     rslt->length = 0;
13355     rstr = &rslt->str[0];
13356     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13357     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13358     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13359     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13360
13361     Newx(vmsspec, VMS_MAXRSS, char);
13362
13363         /* We could find out if there's an explicit dev/dir or version
13364            by peeking into lib$find_file's internal context at
13365            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13366            but that's unsupported, so I don't want to do it now and
13367            have it bite someone in the future. */
13368         /* Fix-me: vms_split_path() is the only way to do this, the
13369            existing method will fail with many legal EFS or UNIX specifications
13370          */
13371
13372     cp = SvPV(tmpglob,i);
13373
13374     for (; i; i--) {
13375         if (cp[i] == ';') hasver = 1;
13376         if (cp[i] == '.') {
13377             if (sts) hasver = 1;
13378             else sts = 1;
13379         }
13380         if (cp[i] == '/') {
13381             hasdir = isunix = 1;
13382             break;
13383         }
13384         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13385             hasdir = 1;
13386             break;
13387         }
13388     }
13389     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13390         int found = 0;
13391         Stat_t st;
13392         int stat_sts;
13393         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13394         if (!stat_sts && S_ISDIR(st.st_mode)) {
13395             wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
13396             ok = (wilddsc.dsc$a_pointer != NULL);
13397             /* maybe passed 'foo' rather than '[.foo]', thus not detected above */
13398             hasdir = 1;
13399         }
13400         else {
13401             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13402             ok = (wilddsc.dsc$a_pointer != NULL);
13403         }
13404         if (ok)
13405             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13406
13407         /* If not extended character set, replace ? with % */
13408         /* With extended character set, ? is a wildcard single character */
13409         if (!decc_efs_case_preserve) {
13410             for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
13411                 if (*cp == '?') *cp = '%';
13412         }
13413         sts = SS$_NORMAL;
13414         while (ok && $VMS_STATUS_SUCCESS(sts)) {
13415          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13416          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13417
13418             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13419                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
13420             if (!$VMS_STATUS_SUCCESS(sts))
13421                 break;
13422
13423             found++;
13424
13425             /* with varying string, 1st word of buffer contains result length */
13426             rstr[rslt->length] = '\0';
13427
13428              /* Find where all the components are */
13429              v_sts = vms_split_path
13430                        (rstr,
13431                         &v_spec,
13432                         &v_len,
13433                         &r_spec,
13434                         &r_len,
13435                         &d_spec,
13436                         &d_len,
13437                         &n_spec,
13438                         &n_len,
13439                         &e_spec,
13440                         &e_len,
13441                         &vs_spec,
13442                         &vs_len);
13443
13444             /* If no version on input, truncate the version on output */
13445             if (!hasver && (vs_len > 0)) {
13446                 *vs_spec = '\0';
13447                 vs_len = 0;
13448
13449                 /* No version & a null extension on UNIX handling */
13450                 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
13451                     e_len = 0;
13452                     *e_spec = '\0';
13453                 }
13454             }
13455
13456             if (!decc_efs_case_preserve) {
13457                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13458             }
13459
13460             if (hasdir) {
13461                 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13462                 begin = rstr;
13463             }
13464             else {
13465                 /* Start with the name */
13466                 begin = n_spec;
13467             }
13468             strcat(begin,"\n");
13469             ok = (PerlIO_puts(tmpfp,begin) != EOF);
13470         }
13471         if (cxt) (void)lib$find_file_end(&cxt);
13472
13473         if (!found) {
13474             /* Be POSIXish: return the input pattern when no matches */
13475             strcpy(rstr,SvPVX(tmpglob));
13476             strcat(rstr,"\n");
13477             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13478         }
13479
13480         if (ok && sts != RMS$_NMF &&
13481             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13482         if (!ok) {
13483             if (!(sts & 1)) {
13484                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13485             }
13486             PerlIO_close(tmpfp);
13487             fp = NULL;
13488         }
13489         else {
13490             PerlIO_rewind(tmpfp);
13491             IoTYPE(io) = IoTYPE_RDONLY;
13492             IoIFP(io) = fp = tmpfp;
13493             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
13494         }
13495     }
13496     Safefree(vmsspec);
13497     Safefree(rslt);
13498     return fp;
13499 }
13500
13501
13502 static char *
13503 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13504                    int *utf8_fl);
13505
13506 void
13507 unixrealpath_fromperl(pTHX_ CV *cv)
13508 {
13509     dXSARGS;
13510     char *fspec, *rslt_spec, *rslt;
13511     STRLEN n_a;
13512
13513     if (!items || items != 1)
13514         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
13515
13516     fspec = SvPV(ST(0),n_a);
13517     if (!fspec || !*fspec) XSRETURN_UNDEF;
13518
13519     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13520     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13521
13522     ST(0) = sv_newmortal();
13523     if (rslt != NULL)
13524         sv_usepvn(ST(0),rslt,strlen(rslt));
13525     else
13526         Safefree(rslt_spec);
13527         XSRETURN(1);
13528 }
13529
13530 static char *
13531 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13532                    int *utf8_fl);
13533
13534 void
13535 vmsrealpath_fromperl(pTHX_ CV *cv)
13536 {
13537     dXSARGS;
13538     char *fspec, *rslt_spec, *rslt;
13539     STRLEN n_a;
13540
13541     if (!items || items != 1)
13542         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
13543
13544     fspec = SvPV(ST(0),n_a);
13545     if (!fspec || !*fspec) XSRETURN_UNDEF;
13546
13547     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13548     rslt = do_vms_realname(fspec, rslt_spec, NULL);
13549
13550     ST(0) = sv_newmortal();
13551     if (rslt != NULL)
13552         sv_usepvn(ST(0),rslt,strlen(rslt));
13553     else
13554         Safefree(rslt_spec);
13555         XSRETURN(1);
13556 }
13557
13558 #ifdef HAS_SYMLINK
13559 /*
13560  * A thin wrapper around decc$symlink to make sure we follow the
13561  * standard and do not create a symlink with a zero-length name.
13562  *
13563  * Also in ODS-2 mode, existing tests assume that the link target
13564  * will be converted to UNIX format.
13565  */
13566 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
13567 int Perl_my_symlink(pTHX_ const char *contents, const char *link_name) {
13568   if (!link_name || !*link_name) {
13569     SETERRNO(ENOENT, SS$_NOSUCHFILE);
13570     return -1;
13571   }
13572
13573   if (decc_efs_charset) {
13574       return symlink(contents, link_name);
13575   } else {
13576       int sts;
13577       char * utarget;
13578
13579       /* Unless we are in ODS-5 mode, convert the symlink target to UNIX */
13580       /* because in order to work, the symlink target must be in UNIX format */
13581
13582       /* As symbolic links can hold things other than files, we will only do */
13583       /* the conversion in in ODS-2 mode */
13584
13585       Newx(utarget, VMS_MAXRSS + 1, char);
13586       if (int_tounixspec(contents, utarget, NULL) == NULL) {
13587
13588           /* This should not fail, as an untranslatable filename */
13589           /* should be passed through */
13590           utarget = (char *)contents;
13591       }
13592       sts = symlink(utarget, link_name);
13593       Safefree(utarget);
13594       return sts;
13595   }
13596
13597 }
13598 /*}}}*/
13599
13600 #endif /* HAS_SYMLINK */
13601
13602 int do_vms_case_tolerant(void);
13603
13604 void
13605 case_tolerant_process_fromperl(pTHX_ CV *cv)
13606 {
13607   dXSARGS;
13608   ST(0) = boolSV(do_vms_case_tolerant());
13609   XSRETURN(1);
13610 }
13611
13612 #ifdef USE_ITHREADS
13613
13614 void
13615 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13616                           struct interp_intern *dst)
13617 {
13618     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13619
13620     memcpy(dst,src,sizeof(struct interp_intern));
13621 }
13622
13623 #endif
13624
13625 void
13626 Perl_sys_intern_clear(pTHX)
13627 {
13628 }
13629
13630 void
13631 Perl_sys_intern_init(pTHX)
13632 {
13633     unsigned int ix = RAND_MAX;
13634     double x;
13635
13636     VMSISH_HUSHED = 0;
13637
13638     MY_POSIX_EXIT = vms_posix_exit;
13639
13640     x = (float)ix;
13641     MY_INV_RAND_MAX = 1./x;
13642 }
13643
13644 void
13645 init_os_extras(void)
13646 {
13647   dTHX;
13648   char* file = __FILE__;
13649   if (decc_disable_to_vms_logname_translation) {
13650     no_translate_barewords = TRUE;
13651   } else {
13652     no_translate_barewords = FALSE;
13653   }
13654
13655   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13656   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13657   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13658   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13659   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13660   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13661   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13662   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13663   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13664   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13665   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13666   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13667   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13668   newXSproto("VMS::Filespec::case_tolerant_process",
13669       case_tolerant_process_fromperl,file,"");
13670
13671   store_pipelocs(aTHX);         /* will redo any earlier attempts */
13672
13673   return;
13674 }
13675
13676 #if __CRTL_VER == 80200000
13677 /* This missed getting in to the DECC SDK for 8.2 */
13678 char *realpath(const char *file_name, char * resolved_name, ...);
13679 #endif
13680
13681 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13682 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13683  * The perl fallback routine to provide realpath() is not as efficient
13684  * on OpenVMS.
13685  */
13686
13687 /* Hack, use old stat() as fastest way of getting ino_t and device */
13688 int decc$stat(const char *name, void * statbuf);
13689
13690
13691 /* Realpath is fragile.  In 8.3 it does not work if the feature
13692  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13693  * links are implemented in RMS, not the CRTL. It also can fail if the
13694  * user does not have read/execute access to some of the directories.
13695  * So in order for Do What I Mean mode to work, if realpath() fails,
13696  * fall back to looking up the filename by the device name and FID.
13697  */
13698
13699 int vms_fid_to_name(char * outname, int outlen, const char * name)
13700 {
13701 struct statbuf_t {
13702     char           * st_dev;
13703     unsigned short st_ino[3];
13704     unsigned short padw;
13705     unsigned long  padl[30];  /* plenty of room */
13706 } statbuf;
13707 int sts;
13708 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13709 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13710
13711     sts = decc$stat(name, &statbuf);
13712     if (sts == 0) {
13713
13714         dvidsc.dsc$a_pointer=statbuf.st_dev;
13715        dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13716
13717         specdsc.dsc$a_pointer = outname;
13718         specdsc.dsc$w_length = outlen-1;
13719
13720        sts = lib$fid_to_name
13721             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13722        if ($VMS_STATUS_SUCCESS(sts)) {
13723             outname[specdsc.dsc$w_length] = 0;
13724             return 0;
13725         }
13726     }
13727     return sts;
13728 }
13729
13730
13731
13732 static char *
13733 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13734                    int *utf8_fl)
13735 {
13736     char * rslt = NULL;
13737
13738 #ifdef HAS_SYMLINK
13739     if (decc_posix_compliant_pathnames > 0 ) {
13740         /* realpath currently only works if posix compliant pathnames are
13741          * enabled.  It may start working when they are not, but in that
13742          * case we still want the fallback behavior for backwards compatibility
13743          */
13744         rslt = realpath(filespec, outbuf);
13745     }
13746 #endif
13747
13748     if (rslt == NULL) {
13749         char * vms_spec;
13750         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13751         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13752         int file_len;
13753
13754         /* Fall back to fid_to_name */
13755
13756         Newx(vms_spec, VMS_MAXRSS + 1, char);
13757
13758         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec);
13759         if (sts == 0) {
13760
13761
13762             /* Now need to trim the version off */
13763             sts = vms_split_path
13764                   (vms_spec,
13765                    &v_spec,
13766                    &v_len,
13767                    &r_spec,
13768                    &r_len,
13769                    &d_spec,
13770                    &d_len,
13771                    &n_spec,
13772                    &n_len,
13773                    &e_spec,
13774                    &e_len,
13775                    &vs_spec,
13776                    &vs_len);
13777
13778
13779                 if (sts == 0) {
13780                     int haslower = 0;
13781                     const char *cp;
13782
13783                     /* Trim off the version */
13784                     int file_len = v_len + r_len + d_len + n_len + e_len;
13785                     vms_spec[file_len] = 0;
13786
13787                     /* The result is expected to be in UNIX format */
13788                     rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
13789
13790                     /* Downcase if input had any lower case letters and
13791                      * case preservation is not in effect.
13792                      */
13793                     if (!decc_efs_case_preserve) {
13794                         for (cp = filespec; *cp; cp++)
13795                             if (islower(*cp)) { haslower = 1; break; }
13796
13797                         if (haslower) __mystrtolower(rslt);
13798                     }
13799                 }
13800         } else {
13801
13802             /* Now for some hacks to deal with backwards and forward */
13803             /* compatibilty */
13804             if (!decc_efs_charset) {
13805
13806                 /* 1. ODS-2 mode wants to do a syntax only translation */
13807                 rslt = int_rmsexpand(filespec, outbuf,
13808                                     NULL, 0, NULL, utf8_fl);
13809
13810             } else {
13811                 if (decc_filename_unix_report) {
13812                     char * dir_name;
13813                     char * vms_dir_name;
13814                     char * file_name;
13815
13816                     /* 2. ODS-5 / UNIX report mode should return a failure */
13817                     /*    if the parent directory also does not exist */
13818                     /*    Otherwise, get the real path for the parent */
13819                     /*    and add the child to it.
13820
13821                     /* basename / dirname only available for VMS 7.0+ */
13822                     /* So we may need to implement them as common routines */
13823
13824                     Newx(dir_name, VMS_MAXRSS + 1, char);
13825                     Newx(vms_dir_name, VMS_MAXRSS + 1, char);
13826                     dir_name[0] = '\0';
13827                     file_name = NULL;
13828
13829                     /* First try a VMS parse */
13830                     sts = vms_split_path
13831                           (filespec,
13832                            &v_spec,
13833                            &v_len,
13834                            &r_spec,
13835                            &r_len,
13836                            &d_spec,
13837                            &d_len,
13838                            &n_spec,
13839                            &n_len,
13840                            &e_spec,
13841                            &e_len,
13842                            &vs_spec,
13843                            &vs_len);
13844
13845                     if (sts == 0) {
13846                         /* This is VMS */
13847
13848                         int dir_len = v_len + r_len + d_len + n_len;
13849                         if (dir_len > 0) {
13850                            strncpy(dir_name, filespec, dir_len);
13851                            dir_name[dir_len] = '\0';
13852                            file_name = (char *)&filespec[dir_len + 1];
13853                         }
13854                     } else {
13855                         /* This must be UNIX */
13856                         char * tchar;
13857
13858                         tchar = strrchr(filespec, '/');
13859
13860                         if (tchar != NULL) {
13861                             int dir_len = tchar - filespec;
13862                             strncpy(dir_name, filespec, dir_len);
13863                             dir_name[dir_len] = '\0';
13864                             file_name = (char *) &filespec[dir_len + 1];
13865                         }
13866                     }
13867
13868                     /* Dir name is defaulted */
13869                     if (dir_name[0] == 0) {
13870                         dir_name[0] = '.';
13871                         dir_name[1] = '\0';
13872                     }
13873
13874                     /* Need realpath for the directory */
13875                     sts = vms_fid_to_name(vms_dir_name,
13876                                           VMS_MAXRSS + 1,
13877                                           dir_name);
13878
13879                     if (sts == 0) {
13880                         /* Now need to pathify it.
13881                         char *tdir = do_pathify_dirspec(vms_dir_name,
13882                                                         outbuf, utf8_fl);
13883
13884                         /* And now add the original filespec to it */
13885                         if (file_name != NULL) {
13886                             strcat(outbuf, file_name);
13887                         }
13888                         return outbuf;
13889                     }
13890                     Safefree(vms_dir_name);
13891                     Safefree(dir_name);
13892                 }
13893             }
13894         }
13895         Safefree(vms_spec);
13896     }
13897     return rslt;
13898 }
13899
13900 static char *
13901 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13902                    int *utf8_fl)
13903 {
13904     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13905     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13906     int file_len;
13907
13908     /* Fall back to fid_to_name */
13909
13910     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec);
13911     if (sts != 0) {
13912         return NULL;
13913     }
13914     else {
13915
13916
13917         /* Now need to trim the version off */
13918         sts = vms_split_path
13919                   (outbuf,
13920                    &v_spec,
13921                    &v_len,
13922                    &r_spec,
13923                    &r_len,
13924                    &d_spec,
13925                    &d_len,
13926                    &n_spec,
13927                    &n_len,
13928                    &e_spec,
13929                    &e_len,
13930                    &vs_spec,
13931                    &vs_len);
13932
13933
13934         if (sts == 0) {
13935             int haslower = 0;
13936             const char *cp;
13937
13938             /* Trim off the version */
13939             int file_len = v_len + r_len + d_len + n_len + e_len;
13940             outbuf[file_len] = 0;
13941
13942             /* Downcase if input had any lower case letters and
13943              * case preservation is not in effect.
13944              */
13945             if (!decc_efs_case_preserve) {
13946                 for (cp = filespec; *cp; cp++)
13947                     if (islower(*cp)) { haslower = 1; break; }
13948
13949                 if (haslower) __mystrtolower(outbuf);
13950             }
13951         }
13952     }
13953     return outbuf;
13954 }
13955
13956
13957 /*}}}*/
13958 /* External entry points */
13959 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13960 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
13961
13962 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13963 { return do_vms_realname(filespec, outbuf, utf8_fl); }
13964
13965 /* case_tolerant */
13966
13967 /*{{{int do_vms_case_tolerant(void)*/
13968 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13969  * controlled by a process setting.
13970  */
13971 int do_vms_case_tolerant(void)
13972 {
13973     return vms_process_case_tolerant;
13974 }
13975 /*}}}*/
13976 /* External entry points */
13977 #if __CRTL_VER >= 70301000 && !defined(__VAX)
13978 int Perl_vms_case_tolerant(void)
13979 { return do_vms_case_tolerant(); }
13980 #else
13981 int Perl_vms_case_tolerant(void)
13982 { return vms_process_case_tolerant; }
13983 #endif
13984
13985
13986  /* Start of DECC RTL Feature handling */
13987
13988 static int sys_trnlnm
13989    (const char * logname,
13990     char * value,
13991     int value_len)
13992 {
13993     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
13994     const unsigned long attr = LNM$M_CASE_BLIND;
13995     struct dsc$descriptor_s name_dsc;
13996     int status;
13997     unsigned short result;
13998     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
13999                                 {0, 0, 0, 0}};
14000
14001     name_dsc.dsc$w_length = strlen(logname);
14002     name_dsc.dsc$a_pointer = (char *)logname;
14003     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14004     name_dsc.dsc$b_class = DSC$K_CLASS_S;
14005
14006     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
14007
14008     if ($VMS_STATUS_SUCCESS(status)) {
14009
14010          /* Null terminate and return the string */
14011         /*--------------------------------------*/
14012         value[result] = 0;
14013     }
14014
14015     return status;
14016 }
14017
14018 static int sys_crelnm
14019    (const char * logname,
14020     const char * value)
14021 {
14022     int ret_val;
14023     const char * proc_table = "LNM$PROCESS_TABLE";
14024     struct dsc$descriptor_s proc_table_dsc;
14025     struct dsc$descriptor_s logname_dsc;
14026     struct itmlst_3 item_list[2];
14027
14028     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
14029     proc_table_dsc.dsc$w_length = strlen(proc_table);
14030     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14031     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
14032
14033     logname_dsc.dsc$a_pointer = (char *) logname;
14034     logname_dsc.dsc$w_length = strlen(logname);
14035     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14036     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
14037
14038     item_list[0].buflen = strlen(value);
14039     item_list[0].itmcode = LNM$_STRING;
14040     item_list[0].bufadr = (char *)value;
14041     item_list[0].retlen = NULL;
14042
14043     item_list[1].buflen = 0;
14044     item_list[1].itmcode = 0;
14045
14046     ret_val = sys$crelnm
14047                        (NULL,
14048                         (const struct dsc$descriptor_s *)&proc_table_dsc,
14049                         (const struct dsc$descriptor_s *)&logname_dsc,
14050                         NULL,
14051                         (const struct item_list_3 *) item_list);
14052
14053     return ret_val;
14054 }
14055
14056 /* C RTL Feature settings */
14057
14058 static int set_features
14059    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
14060     int (* cli_routine)(void),  /* Not documented */
14061     void *image_info)           /* Not documented */
14062 {
14063     int status;
14064     int s;
14065     char* str;
14066     char val_str[10];
14067 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
14068     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
14069     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
14070     unsigned long case_perm;
14071     unsigned long case_image;
14072 #endif
14073
14074     /* Allow an exception to bring Perl into the VMS debugger */
14075     vms_debug_on_exception = 0;
14076     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
14077     if ($VMS_STATUS_SUCCESS(status)) {
14078        val_str[0] = _toupper(val_str[0]);
14079        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14080          vms_debug_on_exception = 1;
14081        else
14082          vms_debug_on_exception = 0;
14083     }
14084
14085     /* Debug unix/vms file translation routines */
14086     vms_debug_fileify = 0;
14087     status = sys_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
14088     if ($VMS_STATUS_SUCCESS(status)) {
14089         val_str[0] = _toupper(val_str[0]);
14090         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14091             vms_debug_fileify = 1;
14092         else
14093             vms_debug_fileify = 0;
14094     }
14095
14096
14097     /* Historically PERL has been doing vmsify / stat differently than */
14098     /* the CRTL.  In particular, under some conditions the CRTL will   */
14099     /* remove some illegal characters like spaces from filenames       */
14100     /* resulting in some differences.  The stat()/lstat() wrapper has  */
14101     /* been reporting such file names as invalid and fails to stat them */
14102     /* fixing this bug so that stat()/lstat() accept these like the     */
14103     /* CRTL does will result in several tests failing.                  */
14104     /* This should really be fixed, but for now, set up a feature to    */
14105     /* enable it so that the impact can be studied.                     */
14106     vms_bug_stat_filename = 0;
14107     status = sys_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
14108     if ($VMS_STATUS_SUCCESS(status)) {
14109         val_str[0] = _toupper(val_str[0]);
14110         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14111             vms_bug_stat_filename = 1;
14112         else
14113             vms_bug_stat_filename = 0;
14114     }
14115
14116
14117     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
14118     vms_vtf7_filenames = 0;
14119     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
14120     if ($VMS_STATUS_SUCCESS(status)) {
14121        val_str[0] = _toupper(val_str[0]);
14122        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14123          vms_vtf7_filenames = 1;
14124        else
14125          vms_vtf7_filenames = 0;
14126     }
14127
14128     /* unlink all versions on unlink() or rename() */
14129     vms_unlink_all_versions = 0;
14130     status = sys_trnlnm
14131         ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
14132     if ($VMS_STATUS_SUCCESS(status)) {
14133        val_str[0] = _toupper(val_str[0]);
14134        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14135          vms_unlink_all_versions = 1;
14136        else
14137          vms_unlink_all_versions = 0;
14138     }
14139
14140     /* Dectect running under GNV Bash or other UNIX like shell */
14141 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14142     gnv_unix_shell = 0;
14143     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
14144     if ($VMS_STATUS_SUCCESS(status)) {
14145          gnv_unix_shell = 1;
14146          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
14147          set_feature_default("DECC$EFS_CHARSET", 1);
14148          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
14149          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
14150          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
14151          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
14152          vms_unlink_all_versions = 1;
14153          vms_posix_exit = 1;
14154     }
14155 #endif
14156
14157     /* hacks to see if known bugs are still present for testing */
14158
14159     /* PCP mode requires creating /dev/null special device file */
14160     decc_bug_devnull = 0;
14161     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14162     if ($VMS_STATUS_SUCCESS(status)) {
14163        val_str[0] = _toupper(val_str[0]);
14164        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14165           decc_bug_devnull = 1;
14166        else
14167           decc_bug_devnull = 0;
14168     }
14169
14170     /* UNIX directory names with no paths are broken in a lot of places */
14171     decc_dir_barename = 1;
14172     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
14173     if ($VMS_STATUS_SUCCESS(status)) {
14174       val_str[0] = _toupper(val_str[0]);
14175       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14176         decc_dir_barename = 1;
14177       else
14178         decc_dir_barename = 0;
14179     }
14180
14181 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14182     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14183     if (s >= 0) {
14184         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14185         if (decc_disable_to_vms_logname_translation < 0)
14186             decc_disable_to_vms_logname_translation = 0;
14187     }
14188
14189     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14190     if (s >= 0) {
14191         decc_efs_case_preserve = decc$feature_get_value(s, 1);
14192         if (decc_efs_case_preserve < 0)
14193             decc_efs_case_preserve = 0;
14194     }
14195
14196     s = decc$feature_get_index("DECC$EFS_CHARSET");
14197     decc_efs_charset_index = s;
14198     if (s >= 0) {
14199         decc_efs_charset = decc$feature_get_value(s, 1);
14200         if (decc_efs_charset < 0)
14201             decc_efs_charset = 0;
14202     }
14203
14204     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14205     if (s >= 0) {
14206         decc_filename_unix_report = decc$feature_get_value(s, 1);
14207         if (decc_filename_unix_report > 0) {
14208             decc_filename_unix_report = 1;
14209             vms_posix_exit = 1;
14210         }
14211         else
14212             decc_filename_unix_report = 0;
14213     }
14214
14215     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14216     if (s >= 0) {
14217         decc_filename_unix_only = decc$feature_get_value(s, 1);
14218         if (decc_filename_unix_only > 0) {
14219             decc_filename_unix_only = 1;
14220         }
14221         else {
14222             decc_filename_unix_only = 0;
14223         }
14224     }
14225
14226     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14227     if (s >= 0) {
14228         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14229         if (decc_filename_unix_no_version < 0)
14230             decc_filename_unix_no_version = 0;
14231     }
14232
14233     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14234     if (s >= 0) {
14235         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14236         if (decc_readdir_dropdotnotype < 0)
14237             decc_readdir_dropdotnotype = 0;
14238     }
14239
14240 #if __CRTL_VER >= 80200000
14241     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14242     if (s >= 0) {
14243         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14244         if (decc_posix_compliant_pathnames < 0)
14245             decc_posix_compliant_pathnames = 0;
14246         if (decc_posix_compliant_pathnames > 4)
14247             decc_posix_compliant_pathnames = 0;
14248     }
14249
14250 #endif
14251 #else
14252     status = sys_trnlnm
14253         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
14254     if ($VMS_STATUS_SUCCESS(status)) {
14255         val_str[0] = _toupper(val_str[0]);
14256         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14257            decc_disable_to_vms_logname_translation = 1;
14258         }
14259     }
14260
14261 #ifndef __VAX
14262     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
14263     if ($VMS_STATUS_SUCCESS(status)) {
14264         val_str[0] = _toupper(val_str[0]);
14265         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14266            decc_efs_case_preserve = 1;
14267         }
14268     }
14269 #endif
14270
14271     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14272     if ($VMS_STATUS_SUCCESS(status)) {
14273         val_str[0] = _toupper(val_str[0]);
14274         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14275            decc_filename_unix_report = 1;
14276         }
14277     }
14278     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14279     if ($VMS_STATUS_SUCCESS(status)) {
14280         val_str[0] = _toupper(val_str[0]);
14281         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14282            decc_filename_unix_only = 1;
14283            decc_filename_unix_report = 1;
14284         }
14285     }
14286     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14287     if ($VMS_STATUS_SUCCESS(status)) {
14288         val_str[0] = _toupper(val_str[0]);
14289         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14290            decc_filename_unix_no_version = 1;
14291         }
14292     }
14293     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
14294     if ($VMS_STATUS_SUCCESS(status)) {
14295         val_str[0] = _toupper(val_str[0]);
14296         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14297            decc_readdir_dropdotnotype = 1;
14298         }
14299     }
14300 #endif
14301
14302 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
14303
14304      /* Report true case tolerance */
14305     /*----------------------------*/
14306     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14307     if (!$VMS_STATUS_SUCCESS(status))
14308         case_perm = PPROP$K_CASE_BLIND;
14309     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14310     if (!$VMS_STATUS_SUCCESS(status))
14311         case_image = PPROP$K_CASE_BLIND;
14312     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14313         (case_image == PPROP$K_CASE_SENSITIVE))
14314         vms_process_case_tolerant = 0;
14315
14316 #endif
14317
14318     /* USE POSIX/DCL Exit codes - Recommended, but needs to default to  */
14319     /* for strict backward compatibilty */
14320     status = sys_trnlnm
14321         ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14322     if ($VMS_STATUS_SUCCESS(status)) {
14323        val_str[0] = _toupper(val_str[0]);
14324        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14325          vms_posix_exit = 1;
14326        else
14327          vms_posix_exit = 0;
14328     }
14329
14330
14331     /* CRTL can be initialized past this point, but not before. */
14332 /*    DECC$CRTL_INIT(); */
14333
14334     return SS$_NORMAL;
14335 }
14336
14337 #ifdef __DECC
14338 #pragma nostandard
14339 #pragma extern_model save
14340 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
14341         const __align (LONGWORD) int spare[8] = {0};
14342
14343 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
14344 #if __DECC_VER >= 60560002
14345 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
14346 #else
14347 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
14348 #endif
14349 #endif /* __DECC */
14350
14351 const long vms_cc_features = (const long)set_features;
14352
14353 /*
14354 ** Force a reference to LIB$INITIALIZE to ensure it
14355 ** exists in the image.
14356 */
14357 int lib$initialize(void);
14358 #ifdef __DECC
14359 #pragma extern_model strict_refdef
14360 #endif
14361     int lib_init_ref = (int) lib$initialize;
14362
14363 #ifdef __DECC
14364 #pragma extern_model restore
14365 #pragma standard
14366 #endif
14367
14368 /*  End of vms.c */