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_tovmsspec
 300    (const char *path, char *buf, int dir_flag, int * utf8_flag);
 301
 302 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 303 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 304
 305 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 306  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 307  * the Perl facility.
 308  */
 309 #define PERL_LNM_MAX_ITER 10
 310
 311   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 312 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 313 #define MAX_DCL_SYMBOL          (8192)
 314 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 315 #else
 316 #define MAX_DCL_SYMBOL          (1024)
 317 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 318 #endif
 319
 320 static char *__mystrtolower(char *str)
 321 {
 322   if (str) for (; *str; ++str) *str= tolower(*str);
 323   return str;
 324 }
 325
 326 static struct dsc$descriptor_s fildevdsc =
 327   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 328 static struct dsc$descriptor_s crtlenvdsc =
 329   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 330 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 331 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 332 static struct dsc$descriptor_s **env_tables = defenv;
 333 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 334
 335 /* True if we shouldn't treat barewords as logicals during directory */
 336 /* munching */
 337 static int no_translate_barewords;
 338
 339 #ifndef RTL_USES_UTC
 340 static int tz_updated = 1;
 341 #endif
 342
 343 /* DECC Features that may need to affect how Perl interprets
 344  * displays filename information
 345  */
 346 static int decc_disable_to_vms_logname_translation = 1;
 347 static int decc_disable_posix_root = 1;
 348 int decc_efs_case_preserve = 0;
 349 static int decc_efs_charset = 0;
 350 static int decc_efs_charset_index = -1;
 351 static int decc_filename_unix_no_version = 0;
 352 static int decc_filename_unix_only = 0;
 353 int decc_filename_unix_report = 0;
 354 int decc_posix_compliant_pathnames = 0;
 355 int decc_readdir_dropdotnotype = 0;
 356 static int vms_process_case_tolerant = 1;
 357 int vms_vtf7_filenames = 0;
 358 int gnv_unix_shell = 0;
 359 static int vms_unlink_all_versions = 0;
 360 static int vms_posix_exit = 0;
 361
 362 /* bug workarounds if needed */
 363 int decc_bug_devnull = 1;
 364 int decc_dir_barename = 0;
 365 int vms_bug_stat_filename = 0;
 366
 367 static int vms_debug_on_exception = 0;
 368 static int vms_debug_fileify = 0;
 369
 370 /* Simple logical name translation */
 371 static int simple_trnlnm
 372    (const char * logname,
 373     char * value,
 374     int value_len)
 375 {
 376     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
 377     const unsigned long attr = LNM$M_CASE_BLIND;
 378     struct dsc$descriptor_s name_dsc;
 379     int status;
 380     unsigned short result;
 381     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
 382                                 {0, 0, 0, 0}};
 383
 384     name_dsc.dsc$w_length = strlen(logname);
 385     name_dsc.dsc$a_pointer = (char *)logname;
 386     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
 387     name_dsc.dsc$b_class = DSC$K_CLASS_S;
 388
 389     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
 390
 391     if ($VMS_STATUS_SUCCESS(status)) {
 392
 393          /* Null terminate and return the string */
 394         /*--------------------------------------*/
 395         value[result] = 0;
 396         return result;
 397     }
 398
 399     return 0;
 400 }
 401
 402
 403 /* Is this a UNIX file specification?
 404  *   No longer a simple check with EFS file specs
 405  *   For now, not a full check, but need to
 406  *   handle POSIX ^UP^ specifications
 407  *   Fixing to handle ^/ cases would require
 408  *   changes to many other conversion routines.
 409  */
 410
 411 static int is_unix_filespec(const char *path)
 412 {
 413 int ret_val;
 414 const char * pch1;
 415
 416     ret_val = 0;
 417     if (strncmp(path,"\"^UP^",5) != 0) {
 418         pch1 = strchr(path, '/');
 419         if (pch1 != NULL)
 420             ret_val = 1;
 421         else {
 422
 423             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 424             if (decc_filename_unix_report || decc_filename_unix_only) {
 425             if (strcmp(path,".") == 0)
 426                 ret_val = 1;
 427             }
 428         }
 429     }
 430     return ret_val;
 431 }
 432
 433 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 434  */
 435
 436 static void ucs2_to_vtf7
 437    (char *outspec,
 438     unsigned long ucs2_char,
 439     int * output_cnt)
 440 {
 441 unsigned char * ucs_ptr;
 442 int hex;
 443
 444     ucs_ptr = (unsigned char *)&ucs2_char;
 445
 446     outspec[0] = '^';
 447     outspec[1] = 'U';
 448     hex = (ucs_ptr[1] >> 4) & 0xf;
 449     if (hex < 0xA)
 450         outspec[2] = hex + '0';
 451     else
 452         outspec[2] = (hex - 9) + 'A';
 453     hex = ucs_ptr[1] & 0xF;
 454     if (hex < 0xA)
 455         outspec[3] = hex + '0';
 456     else {
 457         outspec[3] = (hex - 9) + 'A';
 458     }
 459     hex = (ucs_ptr[0] >> 4) & 0xf;
 460     if (hex < 0xA)
 461         outspec[4] = hex + '0';
 462     else
 463         outspec[4] = (hex - 9) + 'A';
 464     hex = ucs_ptr[1] & 0xF;
 465     if (hex < 0xA)
 466         outspec[5] = hex + '0';
 467     else {
 468         outspec[5] = (hex - 9) + 'A';
 469     }
 470     *output_cnt = 6;
 471 }
 472
 473
 474 /* This handles the conversion of a UNIX extended character set to a ^
 475  * escaped VMS character.
 476  * in a UNIX file specification.
 477  *
 478  * The output count variable contains the number of characters added
 479  * to the output string.
 480  *
 481  * The return value is the number of characters read from the input string
 482  */
 483 static int copy_expand_unix_filename_escape
 484   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 485 {
 486 int count;
 487 int scnt;
 488 int utf8_flag;
 489
 490     utf8_flag = 0;
 491     if (utf8_fl)
 492       utf8_flag = *utf8_fl;
 493
 494     count = 0;
 495     *output_cnt = 0;
 496     if (*inspec >= 0x80) {
 497         if (utf8_fl && vms_vtf7_filenames) {
 498         unsigned long ucs_char;
 499
 500             ucs_char = 0;
 501
 502             if ((*inspec & 0xE0) == 0xC0) {
 503                 /* 2 byte Unicode */
 504                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 505                 if (ucs_char >= 0x80) {
 506                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 507                     return 2;
 508                 }
 509             } else if ((*inspec & 0xF0) == 0xE0) {
 510                 /* 3 byte Unicode */
 511                 ucs_char = ((inspec[0] & 0xF) << 12) +
 512                    ((inspec[1] & 0x3f) << 6) +
 513                    (inspec[2] & 0x3f);
 514                 if (ucs_char >= 0x800) {
 515                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 516                     return 3;
 517                 }
 518
 519 #if 0 /* I do not see longer sequences supported by OpenVMS */
 520       /* Maybe some one can fix this later */
 521             } else if ((*inspec & 0xF8) == 0xF0) {
 522                 /* 4 byte Unicode */
 523                 /* UCS-4 to UCS-2 */
 524             } else if ((*inspec & 0xFC) == 0xF8) {
 525                 /* 5 byte Unicode */
 526                 /* UCS-4 to UCS-2 */
 527             } else if ((*inspec & 0xFE) == 0xFC) {
 528                 /* 6 byte Unicode */
 529                 /* UCS-4 to UCS-2 */
 530 #endif
 531             }
 532         }
 533
 534         /* High bit set, but not a Unicode character! */
 535
 536         /* Non printing DECMCS or ISO Latin-1 character? */
 537         if (*inspec <= 0x9F) {
 538         int hex;
 539             outspec[0] = '^';
 540             outspec++;
 541             hex = (*inspec >> 4) & 0xF;
 542             if (hex < 0xA)
 543                 outspec[1] = hex + '0';
 544             else {
 545                 outspec[1] = (hex - 9) + 'A';
 546             }
 547             hex = *inspec & 0xF;
 548             if (hex < 0xA)
 549                 outspec[2] = hex + '0';
 550             else {
 551                 outspec[2] = (hex - 9) + 'A';
 552             }
 553             *output_cnt = 3;
 554             return 1;
 555         } else if (*inspec == 0xA0) {
 556             outspec[0] = '^';
 557             outspec[1] = 'A';
 558             outspec[2] = '0';
 559             *output_cnt = 3;
 560             return 1;
 561         } else if (*inspec == 0xFF) {
 562             outspec[0] = '^';
 563             outspec[1] = 'F';
 564             outspec[2] = 'F';
 565             *output_cnt = 3;
 566             return 1;
 567         }
 568         *outspec = *inspec;
 569         *output_cnt = 1;
 570         return 1;
 571     }
 572
 573     /* Is this a macro that needs to be passed through?
 574      * Macros start with $( and an alpha character, followed
 575      * by a string of alpha numeric characters ending with a )
 576      * If this does not match, then encode it as ODS-5.
 577      */
 578     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 579     int tcnt;
 580
 581         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 582             tcnt = 3;
 583             outspec[0] = inspec[0];
 584             outspec[1] = inspec[1];
 585             outspec[2] = inspec[2];
 586
 587             while(isalnum(inspec[tcnt]) ||
 588                   (inspec[2] == '.') || (inspec[2] == '_')) {
 589                 outspec[tcnt] = inspec[tcnt];
 590                 tcnt++;
 591             }
 592             if (inspec[tcnt] == ')') {
 593                 outspec[tcnt] = inspec[tcnt];
 594                 tcnt++;
 595                 *output_cnt = tcnt;
 596                 return tcnt;
 597             }
 598         }
 599     }
 600
 601     switch (*inspec) {
 602     case 0x7f:
 603         outspec[0] = '^';
 604         outspec[1] = '7';
 605         outspec[2] = 'F';
 606         *output_cnt = 3;
 607         return 1;
 608         break;
 609     case '?':
 610         if (decc_efs_charset == 0)
 611           outspec[0] = '%';
 612         else
 613           outspec[0] = '?';
 614         *output_cnt = 1;
 615         return 1;
 616         break;
 617     case '.':
 618     case '~':
 619     case '!':
 620     case '#':
 621     case '&':
 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         /* Don't escape again if following character is
 638          * already something we escape.
 639          */
 640         if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
 641             *outspec = *inspec;
 642             *output_cnt = 1;
 643             return 1;
 644             break;
 645         }
 646         /* But otherwise fall through and escape it. */
 647     case '=':
 648         /* Assume that this is to be escaped */
 649         outspec[0] = '^';
 650         outspec[1] = *inspec;
 651         *output_cnt = 2;
 652         return 1;
 653         break;
 654     case ' ': /* space */
 655         /* Assume that this is to be escaped */
 656         outspec[0] = '^';
 657         outspec[1] = '_';
 658         *output_cnt = 2;
 659         return 1;
 660         break;
 661     default:
 662         *outspec = *inspec;
 663         *output_cnt = 1;
 664         return 1;
 665         break;
 666     }
 667 }
 668
 669
 670 /* This handles the expansion of a '^' prefix to the proper character
 671  * in a UNIX file specification.
 672  *
 673  * The output count variable contains the number of characters added
 674  * to the output string.
 675  *
 676  * The return value is the number of characters read from the input
 677  * string
 678  */
 679 static int copy_expand_vms_filename_escape
 680   (char *outspec, const char *inspec, int *output_cnt)
 681 {
 682 int count;
 683 int scnt;
 684
 685     count = 0;
 686     *output_cnt = 0;
 687     if (*inspec == '^') {
 688         inspec++;
 689         switch (*inspec) {
 690         /* Spaces and non-trailing dots should just be passed through,
 691          * but eat the escape character.
 692          */
 693         case '.':
 694             *outspec = *inspec;
 695             count += 2;
 696             (*output_cnt)++;
 697             break;
 698         case '_': /* space */
 699             *outspec = ' ';
 700             count += 2;
 701             (*output_cnt)++;
 702             break;
 703         case '^':
 704             /* Hmm.  Better leave the escape escaped. */
 705             outspec[0] = '^';
 706             outspec[1] = '^';
 707             count += 2;
 708             (*output_cnt) += 2;
 709             break;
 710         case 'U': /* Unicode - FIX-ME this is wrong. */
 711             inspec++;
 712             count++;
 713             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 714             if (scnt == 4) {
 715                 unsigned int c1, c2;
 716                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 717                 outspec[0] == c1 & 0xff;
 718                 outspec[1] == c2 & 0xff;
 719                 if (scnt > 1) {
 720                     (*output_cnt) += 2;
 721                     count += 4;
 722                 }
 723             }
 724             else {
 725                 /* Error - do best we can to continue */
 726                 *outspec = 'U';
 727                 outspec++;
 728                 (*output_cnt++);
 729                 *outspec = *inspec;
 730                 count++;
 731                 (*output_cnt++);
 732             }
 733             break;
 734         default:
 735             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 736             if (scnt == 2) {
 737                 /* Hex encoded */
 738                 unsigned int c1;
 739                 scnt = sscanf(inspec, "%2x", &c1);
 740                 outspec[0] = c1 & 0xff;
 741                 if (scnt > 0) {
 742                     (*output_cnt++);
 743                     count += 2;
 744                 }
 745             }
 746             else {
 747                 *outspec = *inspec;
 748                 count++;
 749                 (*output_cnt++);
 750             }
 751         }
 752     }
 753     else {
 754         *outspec = *inspec;
 755         count++;
 756         (*output_cnt)++;
 757     }
 758     return count;
 759 }
 760
 761 #ifdef sys$filescan
 762 #undef sys$filescan
 763 int sys$filescan
 764    (const struct dsc$descriptor_s * srcstr,
 765     struct filescan_itmlst_2 * valuelist,
 766     unsigned long * fldflags,
 767     struct dsc$descriptor_s *auxout,
 768     unsigned short * retlen);
 769 #endif
 770
 771 /* vms_split_path - Verify that the input file specification is a
 772  * VMS format file specification, and provide pointers to the components of
 773  * it.  With EFS format filenames, this is virtually the only way to
 774  * parse a VMS path specification into components.
 775  *
 776  * If the sum of the components do not add up to the length of the
 777  * string, then the passed file specification is probably a UNIX style
 778  * path.
 779  */
 780 static int vms_split_path
 781    (const char * path,
 782     char * * volume,
 783     int * vol_len,
 784     char * * root,
 785     int * root_len,
 786     char * * dir,
 787     int * dir_len,
 788     char * * name,
 789     int * name_len,
 790     char * * ext,
 791     int * ext_len,
 792     char * * version,
 793     int * ver_len)
 794 {
 795 struct dsc$descriptor path_desc;
 796 int status;
 797 unsigned long flags;
 798 int ret_stat;
 799 struct filescan_itmlst_2 item_list[9];
 800 const int filespec = 0;
 801 const int nodespec = 1;
 802 const int devspec = 2;
 803 const int rootspec = 3;
 804 const int dirspec = 4;
 805 const int namespec = 5;
 806 const int typespec = 6;
 807 const int verspec = 7;
 808
 809     /* Assume the worst for an easy exit */
 810     ret_stat = -1;
 811     *volume = NULL;
 812     *vol_len = 0;
 813     *root = NULL;
 814     *root_len = 0;
 815     *dir = NULL;
 816     *dir_len;
 817     *name = NULL;
 818     *name_len = 0;
 819     *ext = NULL;
 820     *ext_len = 0;
 821     *version = NULL;
 822     *ver_len = 0;
 823
 824     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 825     path_desc.dsc$w_length = strlen(path);
 826     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 827     path_desc.dsc$b_class = DSC$K_CLASS_S;
 828
 829     /* Get the total length, if it is shorter than the string passed
 830      * then this was probably not a VMS formatted file specification
 831      */
 832     item_list[filespec].itmcode = FSCN$_FILESPEC;
 833     item_list[filespec].length = 0;
 834     item_list[filespec].component = NULL;
 835
 836     /* If the node is present, then it gets considered as part of the
 837      * volume name to hopefully make things simple.
 838      */
 839     item_list[nodespec].itmcode = FSCN$_NODE;
 840     item_list[nodespec].length = 0;
 841     item_list[nodespec].component = NULL;
 842
 843     item_list[devspec].itmcode = FSCN$_DEVICE;
 844     item_list[devspec].length = 0;
 845     item_list[devspec].component = NULL;
 846
 847     /* root is a special case,  adding it to either the directory or
 848      * the device components will probalby complicate things for the
 849      * callers of this routine, so leave it separate.
 850      */
 851     item_list[rootspec].itmcode = FSCN$_ROOT;
 852     item_list[rootspec].length = 0;
 853     item_list[rootspec].component = NULL;
 854
 855     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 856     item_list[dirspec].length = 0;
 857     item_list[dirspec].component = NULL;
 858
 859     item_list[namespec].itmcode = FSCN$_NAME;
 860     item_list[namespec].length = 0;
 861     item_list[namespec].component = NULL;
 862
 863     item_list[typespec].itmcode = FSCN$_TYPE;
 864     item_list[typespec].length = 0;
 865     item_list[typespec].component = NULL;
 866
 867     item_list[verspec].itmcode = FSCN$_VERSION;
 868     item_list[verspec].length = 0;
 869     item_list[verspec].component = NULL;
 870
 871     item_list[8].itmcode = 0;
 872     item_list[8].length = 0;
 873     item_list[8].component = NULL;
 874
 875     status = sys$filescan
 876        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 877         &flags, NULL, NULL);
 878     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 879
 880     /* If we parsed it successfully these two lengths should be the same */
 881     if (path_desc.dsc$w_length != item_list[filespec].length)
 882         return ret_stat;
 883
 884     /* If we got here, then it is a VMS file specification */
 885     ret_stat = 0;
 886
 887     /* set the volume name */
 888     if (item_list[nodespec].length > 0) {
 889         *volume = item_list[nodespec].component;
 890         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 891     }
 892     else {
 893         *volume = item_list[devspec].component;
 894         *vol_len = item_list[devspec].length;
 895     }
 896
 897     *root = item_list[rootspec].component;
 898     *root_len = item_list[rootspec].length;
 899
 900     *dir = item_list[dirspec].component;
 901     *dir_len = item_list[dirspec].length;
 902
 903     /* Now fun with versions and EFS file specifications
 904      * The parser can not tell the difference when a "." is a version
 905      * delimiter or a part of the file specification.
 906      */
 907     if ((decc_efs_charset) &&
 908         (item_list[verspec].length > 0) &&
 909         (item_list[verspec].component[0] == '.')) {
 910         *name = item_list[namespec].component;
 911         *name_len = item_list[namespec].length + item_list[typespec].length;
 912         *ext = item_list[verspec].component;
 913         *ext_len = item_list[verspec].length;
 914         *version = NULL;
 915         *ver_len = 0;
 916     }
 917     else {
 918         *name = item_list[namespec].component;
 919         *name_len = item_list[namespec].length;
 920         *ext = item_list[typespec].component;
 921         *ext_len = item_list[typespec].length;
 922         *version = item_list[verspec].component;
 923         *ver_len = item_list[verspec].length;
 924     }
 925     return ret_stat;
 926 }
 927
 928 /* Routine to determine if the file specification ends with .dir */
 929 static int is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len) {
 930
 931     /* e_len must be 4, and version must be <= 2 characters */
 932     if (e_len != 4 || vs_len > 2)
 933         return 0;
 934
 935     /* If a version number is present, it needs to be one */
 936     if ((vs_len == 2) && (vs_spec[1] != '1'))
 937         return 0;
 938
 939     /* Look for the DIR on the extension */
 940     if (vms_process_case_tolerant) {
 941         if ((toupper(e_spec[1]) == 'D') &&
 942             (toupper(e_spec[2]) == 'I') &&
 943             (toupper(e_spec[3]) == 'R')) {
 944             return 1;
 945         }
 946     } else {
 947         /* Directory extensions are supposed to be in upper case only */
 948         /* I would not be surprised if this rule can not be enforced */
 949         /* if and when someone fully debugs the case sensitive mode */
 950         if ((e_spec[1] == 'D') &&
 951             (e_spec[2] == 'I') &&
 952             (e_spec[3] == 'R')) {
 953             return 1;
 954         }
 955     }
 956     return 0;
 957 }
 958
 959
 960 /* my_maxidx
 961  * Routine to retrieve the maximum equivalence index for an input
 962  * logical name.  Some calls to this routine have no knowledge if
 963  * the variable is a logical or not.  So on error we return a max
 964  * index of zero.
 965  */
 966 /*{{{int my_maxidx(const char *lnm) */
 967 static int
 968 my_maxidx(const char *lnm)
 969 {
 970     int status;
 971     int midx;
 972     int attr = LNM$M_CASE_BLIND;
 973     struct dsc$descriptor lnmdsc;
 974     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 975                                 {0, 0, 0, 0}};
 976
 977     lnmdsc.dsc$w_length = strlen(lnm);
 978     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 979     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 980     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 981
 982     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 983     if ((status & 1) == 0)
 984        midx = 0;
 985
 986     return (midx);
 987 }
 988 /*}}}*/
 989
 990 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 991 int
 992 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 993   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 994 {
 995     const char *cp1;
 996     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 997     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 998     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 999     int midx;
1000     unsigned char acmode;
1001     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1002                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1003     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
1004                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
1005                                  {0, 0, 0, 0}};
1006     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1007 #if defined(PERL_IMPLICIT_CONTEXT)
1008     pTHX = NULL;
1009     if (PL_curinterp) {
1010       aTHX = PERL_GET_INTERP;
1011     } else {
1012       aTHX = NULL;
1013     }
1014 #endif
1015
1016     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
1017       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
1018     }
1019     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1020       *cp2 = _toupper(*cp1);
1021       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1022         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1023         return 0;
1024       }
1025     }
1026     lnmdsc.dsc$w_length = cp1 - lnm;
1027     lnmdsc.dsc$a_pointer = uplnm;
1028     uplnm[lnmdsc.dsc$w_length] = '\0';
1029     secure = flags & PERL__TRNENV_SECURE;
1030     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
1031     if (!tabvec || !*tabvec) tabvec = env_tables;
1032
1033     for (curtab = 0; tabvec[curtab]; curtab++) {
1034       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1035         if (!ivenv && !secure) {
1036           char *eq, *end;
1037           int i;
1038           if (!environ) {
1039             ivenv = 1;
1040 #if defined(PERL_IMPLICIT_CONTEXT)
1041             if (aTHX == NULL) {
1042                 fprintf(stderr,
1043                     "%%PERL-W-VMS_INIT Can't read CRTL environ\n");
1044             } else
1045 #endif
1046                 Perl_warn(aTHX_ "Can't read CRTL environ\n");
1047             continue;
1048           }
1049           retsts = SS$_NOLOGNAM;
1050           for (i = 0; environ[i]; i++) {
1051             if ((eq = strchr(environ[i],'=')) &&
1052                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
1053                 !strncmp(environ[i],uplnm,eq - environ[i])) {
1054               eq++;
1055               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
1056               if (!eqvlen) continue;
1057               retsts = SS$_NORMAL;
1058               break;
1059             }
1060           }
1061           if (retsts != SS$_NOLOGNAM) break;
1062         }
1063       }
1064       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1065                !str$case_blind_compare(&tmpdsc,&clisym)) {
1066         if (!ivsym && !secure) {
1067           unsigned short int deflen = LNM$C_NAMLENGTH;
1068           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1069           /* dynamic dsc to accomodate possible long value */
1070           _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
1071           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
1072           if (retsts & 1) {
1073             if (eqvlen > MAX_DCL_SYMBOL) {
1074               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
1075               eqvlen = MAX_DCL_SYMBOL;
1076               /* Special hack--we might be called before the interpreter's */
1077               /* fully initialized, in which case either thr or PL_curcop */
1078               /* might be bogus. We have to check, since ckWARN needs them */
1079               /* both to be valid if running threaded */
1080 #if defined(PERL_IMPLICIT_CONTEXT)
1081               if (aTHX == NULL) {
1082                   fprintf(stderr,
1083                      "%Perl-VMS-Init, Value of CLI symbol \"%s\" too long",lnm);
1084               } else
1085 #endif
1086                 if (ckWARN(WARN_MISC)) {
1087                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
1088                 }
1089             }
1090             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
1091           }
1092           _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
1093           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1094           if (retsts == LIB$_NOSUCHSYM) continue;
1095           break;
1096         }
1097       }
1098       else if (!ivlnm) {
1099         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
1100           midx = my_maxidx(lnm);
1101           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1102             lnmlst[1].bufadr = cp2;
1103             eqvlen = 0;
1104             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1105             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1106             if (retsts == SS$_NOLOGNAM) break;
1107             /* PPFs have a prefix */
1108             if (
1109 #if INTSIZE == 4
1110                  *((int *)uplnm) == *((int *)"SYS$")                    &&
1111 #endif
1112                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
1113                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
1114                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
1115                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
1116                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
1117               memmove(eqv,eqv+4,eqvlen-4);
1118               eqvlen -= 4;
1119             }
1120             cp2 += eqvlen;
1121             *cp2 = '\0';
1122           }
1123           if ((retsts == SS$_IVLOGNAM) ||
1124               (retsts == SS$_NOLOGNAM)) { continue; }
1125         }
1126         else {
1127           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1128           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1129           if (retsts == SS$_NOLOGNAM) continue;
1130           eqv[eqvlen] = '\0';
1131         }
1132         eqvlen = strlen(eqv);
1133         break;
1134       }
1135     }
1136     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1137     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1138              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
1139              retsts == SS$_NOLOGNAM) {
1140       set_errno(EINVAL);  set_vaxc_errno(retsts);
1141     }
1142     else _ckvmssts_noperl(retsts);
1143     return 0;
1144 }  /* end of vmstrnenv */
1145 /*}}}*/
1146
1147 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1148 /* Define as a function so we can access statics. */
1149 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1150 {
1151     int flags = 0;
1152
1153 #if defined(PERL_IMPLICIT_CONTEXT)
1154     if (aTHX != NULL)
1155 #endif
1156 #ifdef SECURE_INTERNAL_GETENV
1157         flags = (PL_curinterp ? PL_tainting : will_taint) ?
1158                  PERL__TRNENV_SECURE : 0;
1159 #endif
1160
1161     return vmstrnenv(lnm, eqv, idx, fildev, flags);
1162 }
1163 /*}}}*/
1164
1165 /* my_getenv
1166  * Note: Uses Perl temp to store result so char * can be returned to
1167  * caller; this pointer will be invalidated at next Perl statement
1168  * transition.
1169  * We define this as a function rather than a macro in terms of my_getenv_len()
1170  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1171  * allocate SVs).
1172  */
1173 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1174 char *
1175 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1176 {
1177     const char *cp1;
1178     static char *__my_getenv_eqv = NULL;
1179     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1180     unsigned long int idx = 0;
1181     int trnsuccess, success, secure, saverr, savvmserr;
1182     int midx, flags;
1183     SV *tmpsv;
1184
1185     midx = my_maxidx(lnm) + 1;
1186
1187     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1188       /* Set up a temporary buffer for the return value; Perl will
1189        * clean it up at the next statement transition */
1190       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1191       if (!tmpsv) return NULL;
1192       eqv = SvPVX(tmpsv);
1193     }
1194     else {
1195       /* Assume no interpreter ==> single thread */
1196       if (__my_getenv_eqv != NULL) {
1197         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1198       }
1199       else {
1200         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1201       }
1202       eqv = __my_getenv_eqv;
1203     }
1204
1205     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1206     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1207       int len;
1208       getcwd(eqv,LNM$C_NAMLENGTH);
1209
1210       len = strlen(eqv);
1211
1212       /* Get rid of "000000/ in rooted filespecs */
1213       if (len > 7) {
1214         char * zeros;
1215         zeros = strstr(eqv, "/000000/");
1216         if (zeros != NULL) {
1217           int mlen;
1218           mlen = len - (zeros - eqv) - 7;
1219           memmove(zeros, &zeros[7], mlen);
1220           len = len - 7;
1221           eqv[len] = '\0';
1222         }
1223       }
1224       return eqv;
1225     }
1226     else {
1227       /* Impose security constraints only if tainting */
1228       if (sys) {
1229         /* Impose security constraints only if tainting */
1230         secure = PL_curinterp ? PL_tainting : will_taint;
1231         saverr = errno;  savvmserr = vaxc$errno;
1232       }
1233       else {
1234         secure = 0;
1235       }
1236
1237       flags =
1238 #ifdef SECURE_INTERNAL_GETENV
1239               secure ? PERL__TRNENV_SECURE : 0
1240 #else
1241               0
1242 #endif
1243       ;
1244
1245       /* For the getenv interface we combine all the equivalence names
1246        * of a search list logical into one value to acquire a maximum
1247        * value length of 255*128 (assuming %ENV is using logicals).
1248        */
1249       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1250
1251       /* If the name contains a semicolon-delimited index, parse it
1252        * off and make sure we only retrieve the equivalence name for
1253        * that index.  */
1254       if ((cp2 = strchr(lnm,';')) != NULL) {
1255         strcpy(uplnm,lnm);
1256         uplnm[cp2-lnm] = '\0';
1257         idx = strtoul(cp2+1,NULL,0);
1258         lnm = uplnm;
1259         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1260       }
1261
1262       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1263
1264       /* Discard NOLOGNAM on internal calls since we're often looking
1265        * for an optional name, and this "error" often shows up as the
1266        * (bogus) exit status for a die() call later on.  */
1267       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1268       return success ? eqv : NULL;
1269     }
1270
1271 }  /* end of my_getenv() */
1272 /*}}}*/
1273
1274
1275 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1276 char *
1277 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1278 {
1279     const char *cp1;
1280     char *buf, *cp2;
1281     unsigned long idx = 0;
1282     int midx, flags;
1283     static char *__my_getenv_len_eqv = NULL;
1284     int secure, saverr, savvmserr;
1285     SV *tmpsv;
1286
1287     midx = my_maxidx(lnm) + 1;
1288
1289     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1290       /* Set up a temporary buffer for the return value; Perl will
1291        * clean it up at the next statement transition */
1292       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1293       if (!tmpsv) return NULL;
1294       buf = SvPVX(tmpsv);
1295     }
1296     else {
1297       /* Assume no interpreter ==> single thread */
1298       if (__my_getenv_len_eqv != NULL) {
1299         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1300       }
1301       else {
1302         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1303       }
1304       buf = __my_getenv_len_eqv;
1305     }
1306
1307     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1308     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1309     char * zeros;
1310
1311       getcwd(buf,LNM$C_NAMLENGTH);
1312       *len = strlen(buf);
1313
1314       /* Get rid of "000000/ in rooted filespecs */
1315       if (*len > 7) {
1316       zeros = strstr(buf, "/000000/");
1317       if (zeros != NULL) {
1318         int mlen;
1319         mlen = *len - (zeros - buf) - 7;
1320         memmove(zeros, &zeros[7], mlen);
1321         *len = *len - 7;
1322         buf[*len] = '\0';
1323         }
1324       }
1325       return buf;
1326     }
1327     else {
1328       if (sys) {
1329         /* Impose security constraints only if tainting */
1330         secure = PL_curinterp ? PL_tainting : will_taint;
1331         saverr = errno;  savvmserr = vaxc$errno;
1332       }
1333       else {
1334         secure = 0;
1335       }
1336
1337       flags =
1338 #ifdef SECURE_INTERNAL_GETENV
1339               secure ? PERL__TRNENV_SECURE : 0
1340 #else
1341               0
1342 #endif
1343       ;
1344
1345       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1346
1347       if ((cp2 = strchr(lnm,';')) != NULL) {
1348         strcpy(buf,lnm);
1349         buf[cp2-lnm] = '\0';
1350         idx = strtoul(cp2+1,NULL,0);
1351         lnm = buf;
1352         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1353       }
1354
1355       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1356
1357       /* Get rid of "000000/ in rooted filespecs */
1358       if (*len > 7) {
1359       char * zeros;
1360         zeros = strstr(buf, "/000000/");
1361         if (zeros != NULL) {
1362           int mlen;
1363           mlen = *len - (zeros - buf) - 7;
1364           memmove(zeros, &zeros[7], mlen);
1365           *len = *len - 7;
1366           buf[*len] = '\0';
1367         }
1368       }
1369
1370       /* Discard NOLOGNAM on internal calls since we're often looking
1371        * for an optional name, and this "error" often shows up as the
1372        * (bogus) exit status for a die() call later on.  */
1373       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1374       return *len ? buf : NULL;
1375     }
1376
1377 }  /* end of my_getenv_len() */
1378 /*}}}*/
1379
1380 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
1381
1382 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1383
1384 /*{{{ void prime_env_iter() */
1385 void
1386 prime_env_iter(void)
1387 /* Fill the %ENV associative array with all logical names we can
1388  * find, in preparation for iterating over it.
1389  */
1390 {
1391   static int primed = 0;
1392   HV *seenhv = NULL, *envhv;
1393   SV *sv = NULL;
1394   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1395   unsigned short int chan;
1396 #ifndef CLI$M_TRUSTED
1397 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1398 #endif
1399   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1400   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1401   long int i;
1402   bool have_sym = FALSE, have_lnm = FALSE;
1403   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1404   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1405   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1406   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1407   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1408 #if defined(PERL_IMPLICIT_CONTEXT)
1409   pTHX;
1410 #endif
1411 #if defined(USE_ITHREADS)
1412   static perl_mutex primenv_mutex;
1413   MUTEX_INIT(&primenv_mutex);
1414 #endif
1415
1416 #if defined(PERL_IMPLICIT_CONTEXT)
1417     /* We jump through these hoops because we can be called at */
1418     /* platform-specific initialization time, which is before anything is */
1419     /* set up--we can't even do a plain dTHX since that relies on the */
1420     /* interpreter structure to be initialized */
1421     if (PL_curinterp) {
1422       aTHX = PERL_GET_INTERP;
1423     } else {
1424       /* we never get here because the NULL pointer will cause the */
1425       /* several of the routines called by this routine to access violate */
1426
1427       /* This routine is only called by hv.c/hv_iterinit which has a */
1428       /* context, so the real fix may be to pass it through instead of */
1429       /* the hoops above */
1430       aTHX = NULL;
1431     }
1432 #endif
1433
1434   if (primed || !PL_envgv) return;
1435   MUTEX_LOCK(&primenv_mutex);
1436   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1437   envhv = GvHVn(PL_envgv);
1438   /* Perform a dummy fetch as an lval to insure that the hash table is
1439    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1440   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1441
1442   for (i = 0; env_tables[i]; i++) {
1443      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1444          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1445      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1446   }
1447   if (have_sym || have_lnm) {
1448     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1449     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1450     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1451     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1452   }
1453
1454   for (i--; i >= 0; i--) {
1455     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1456       char *start;
1457       int j;
1458       for (j = 0; environ[j]; j++) {
1459         if (!(start = strchr(environ[j],'='))) {
1460           if (ckWARN(WARN_INTERNAL))
1461             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1462         }
1463         else {
1464           start++;
1465           sv = newSVpv(start,0);
1466           SvTAINTED_on(sv);
1467           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1468         }
1469       }
1470       continue;
1471     }
1472     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1473              !str$case_blind_compare(&tmpdsc,&clisym)) {
1474       strcpy(cmd,"Show Symbol/Global *");
1475       cmddsc.dsc$w_length = 20;
1476       if (env_tables[i]->dsc$w_length == 12 &&
1477           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1478           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1479       flags = defflags | CLI$M_NOLOGNAM;
1480     }
1481     else {
1482       strcpy(cmd,"Show Logical *");
1483       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1484         strcat(cmd," /Table=");
1485         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1486         cmddsc.dsc$w_length = strlen(cmd);
1487       }
1488       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1489       flags = defflags | CLI$M_NOCLISYM;
1490     }
1491
1492     /* Create a new subprocess to execute each command, to exclude the
1493      * remote possibility that someone could subvert a mbx or file used
1494      * to write multiple commands to a single subprocess.
1495      */
1496     do {
1497       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1498                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1499       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1500       defflags &= ~CLI$M_TRUSTED;
1501     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1502     _ckvmssts(retsts);
1503     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1504     if (seenhv) SvREFCNT_dec(seenhv);
1505     seenhv = newHV();
1506     while (1) {
1507       char *cp1, *cp2, *key;
1508       unsigned long int sts, iosb[2], retlen, keylen;
1509       register U32 hash;
1510
1511       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1512       if (sts & 1) sts = iosb[0] & 0xffff;
1513       if (sts == SS$_ENDOFFILE) {
1514         int wakect = 0;
1515         while (substs == 0) { sys$hiber(); wakect++;}
1516         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1517         _ckvmssts(substs);
1518         break;
1519       }
1520       _ckvmssts(sts);
1521       retlen = iosb[0] >> 16;
1522       if (!retlen) continue;  /* blank line */
1523       buf[retlen] = '\0';
1524       if (iosb[1] != subpid) {
1525         if (iosb[1]) {
1526           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1527         }
1528         continue;
1529       }
1530       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1531         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1532
1533       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1534       if (*cp1 == '(' || /* Logical name table name */
1535           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1536       if (*cp1 == '"') cp1++;
1537       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1538       key = cp1;  keylen = cp2 - cp1;
1539       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1540       while (*cp2 && *cp2 != '=') cp2++;
1541       while (*cp2 && *cp2 == '=') cp2++;
1542       while (*cp2 && *cp2 == ' ') cp2++;
1543       if (*cp2 == '"') {  /* String translation; may embed "" */
1544         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1545         cp2++;  cp1--; /* Skip "" surrounding translation */
1546       }
1547       else {  /* Numeric translation */
1548         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1549         cp1--;  /* stop on last non-space char */
1550       }
1551       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1552         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1553         continue;
1554       }
1555       PERL_HASH(hash,key,keylen);
1556
1557       if (cp1 == cp2 && *cp2 == '.') {
1558         /* A single dot usually means an unprintable character, such as a null
1559          * to indicate a zero-length value.  Get the actual value to make sure.
1560          */
1561         char lnm[LNM$C_NAMLENGTH+1];
1562         char eqv[MAX_DCL_SYMBOL+1];
1563         int trnlen;
1564         strncpy(lnm, key, keylen);
1565         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1566         sv = newSVpvn(eqv, strlen(eqv));
1567       }
1568       else {
1569         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1570       }
1571
1572       SvTAINTED_on(sv);
1573       hv_store(envhv,key,keylen,sv,hash);
1574       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1575     }
1576     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1577       /* get the PPFs for this process, not the subprocess */
1578       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1579       char eqv[LNM$C_NAMLENGTH+1];
1580       int trnlen, i;
1581       for (i = 0; ppfs[i]; i++) {
1582         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1583         sv = newSVpv(eqv,trnlen);
1584         SvTAINTED_on(sv);
1585         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1586       }
1587     }
1588   }
1589   primed = 1;
1590   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1591   if (buf) Safefree(buf);
1592   if (seenhv) SvREFCNT_dec(seenhv);
1593   MUTEX_UNLOCK(&primenv_mutex);
1594   return;
1595
1596 }  /* end of prime_env_iter */
1597 /*}}}*/
1598
1599
1600 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1601 /* Define or delete an element in the same "environment" as
1602  * vmstrnenv().  If an element is to be deleted, it's removed from
1603  * the first place it's found.  If it's to be set, it's set in the
1604  * place designated by the first element of the table vector.
1605  * Like setenv() returns 0 for success, non-zero on error.
1606  */
1607 int
1608 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1609 {
1610     const char *cp1;
1611     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1612     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1613     int nseg = 0, j;
1614     unsigned long int retsts, usermode = PSL$C_USER;
1615     struct itmlst_3 *ile, *ilist;
1616     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1617                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1618                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1619     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1620     $DESCRIPTOR(local,"_LOCAL");
1621
1622     if (!lnm) {
1623         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1624         return SS$_IVLOGNAM;
1625     }
1626
1627     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1628       *cp2 = _toupper(*cp1);
1629       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1630         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1631         return SS$_IVLOGNAM;
1632       }
1633     }
1634     lnmdsc.dsc$w_length = cp1 - lnm;
1635     if (!tabvec || !*tabvec) tabvec = env_tables;
1636
1637     if (!eqv) {  /* we're deleting n element */
1638       for (curtab = 0; tabvec[curtab]; curtab++) {
1639         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1640         int i;
1641           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1642             if ((cp1 = strchr(environ[i],'=')) &&
1643                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1644                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1645 #ifdef HAS_SETENV
1646               return setenv(lnm,"",1) ? vaxc$errno : 0;
1647             }
1648           }
1649           ivenv = 1; retsts = SS$_NOLOGNAM;
1650 #else
1651               if (ckWARN(WARN_INTERNAL))
1652                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1653               ivenv = 1; retsts = SS$_NOSUCHPGM;
1654               break;
1655             }
1656           }
1657 #endif
1658         }
1659         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1660                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1661           unsigned int symtype;
1662           if (tabvec[curtab]->dsc$w_length == 12 &&
1663               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1664               !str$case_blind_compare(&tmpdsc,&local))
1665             symtype = LIB$K_CLI_LOCAL_SYM;
1666           else symtype = LIB$K_CLI_GLOBAL_SYM;
1667           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1668           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1669           if (retsts == LIB$_NOSUCHSYM) continue;
1670           break;
1671         }
1672         else if (!ivlnm) {
1673           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1674           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1675           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1676           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1677           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1678         }
1679       }
1680     }
1681     else {  /* we're defining a value */
1682       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1683 #ifdef HAS_SETENV
1684         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1685 #else
1686         if (ckWARN(WARN_INTERNAL))
1687           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1688         retsts = SS$_NOSUCHPGM;
1689 #endif
1690       }
1691       else {
1692         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1693         eqvdsc.dsc$w_length  = strlen(eqv);
1694         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1695             !str$case_blind_compare(&tmpdsc,&clisym)) {
1696           unsigned int symtype;
1697           if (tabvec[0]->dsc$w_length == 12 &&
1698               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1699                !str$case_blind_compare(&tmpdsc,&local))
1700             symtype = LIB$K_CLI_LOCAL_SYM;
1701           else symtype = LIB$K_CLI_GLOBAL_SYM;
1702           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1703         }
1704         else {
1705           if (!*eqv) eqvdsc.dsc$w_length = 1;
1706           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1707
1708             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1709             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1710               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1711                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1712               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1713               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1714             }
1715
1716             Newx(ilist,nseg+1,struct itmlst_3);
1717             ile = ilist;
1718             if (!ile) {
1719               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1720               return SS$_INSFMEM;
1721             }
1722             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1723
1724             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1725               ile->itmcode = LNM$_STRING;
1726               ile->bufadr = c;
1727               if ((j+1) == nseg) {
1728                 ile->buflen = strlen(c);
1729                 /* in case we are truncating one that's too long */
1730                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1731               }
1732               else {
1733                 ile->buflen = LNM$C_NAMLENGTH;
1734               }
1735             }
1736
1737             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1738             Safefree (ilist);
1739           }
1740           else {
1741             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1742           }
1743         }
1744       }
1745     }
1746     if (!(retsts & 1)) {
1747       switch (retsts) {
1748         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1749         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1750           set_errno(EVMSERR); break;
1751         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1752         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1753           set_errno(EINVAL); break;
1754         case SS$_NOPRIV:
1755           set_errno(EACCES); break;
1756         default:
1757           _ckvmssts(retsts);
1758           set_errno(EVMSERR);
1759        }
1760        set_vaxc_errno(retsts);
1761        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1762     }
1763     else {
1764       /* We reset error values on success because Perl does an hv_fetch()
1765        * before each hv_store(), and if the thing we're setting didn't
1766        * previously exist, we've got a leftover error message.  (Of course,
1767        * this fails in the face of
1768        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1769        * in that the error reported in $! isn't spurious,
1770        * but it's right more often than not.)
1771        */
1772       set_errno(0); set_vaxc_errno(retsts);
1773       return 0;
1774     }
1775
1776 }  /* end of vmssetenv() */
1777 /*}}}*/
1778
1779 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1780 /* This has to be a function since there's a prototype for it in proto.h */
1781 void
1782 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1783 {
1784     if (lnm && *lnm) {
1785       int len = strlen(lnm);
1786       if  (len == 7) {
1787         char uplnm[8];
1788         int i;
1789         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1790         if (!strcmp(uplnm,"DEFAULT")) {
1791           if (eqv && *eqv) my_chdir(eqv);
1792           return;
1793         }
1794     }
1795 #ifndef RTL_USES_UTC
1796     if (len == 6 || len == 2) {
1797       char uplnm[7];
1798       int i;
1799       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1800       uplnm[len] = '\0';
1801       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1802       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1803     }
1804 #endif
1805   }
1806   (void) vmssetenv(lnm,eqv,NULL);
1807 }
1808 /*}}}*/
1809
1810 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1811 /*  vmssetuserlnm
1812  *  sets a user-mode logical in the process logical name table
1813  *  used for redirection of sys$error
1814  */
1815 void
1816 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1817 {
1818     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1819     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1820     unsigned long int iss, attr = LNM$M_CONFINE;
1821     unsigned char acmode = PSL$C_USER;
1822     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1823                                  {0, 0, 0, 0}};
1824     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1825     d_name.dsc$w_length = strlen(name);
1826
1827     lnmlst[0].buflen = strlen(eqv);
1828     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1829
1830     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1831     if (!(iss&1)) lib$signal(iss);
1832 }
1833 /*}}}*/
1834
1835
1836 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1837 /* my_crypt - VMS password hashing
1838  * my_crypt() provides an interface compatible with the Unix crypt()
1839  * C library function, and uses sys$hash_password() to perform VMS
1840  * password hashing.  The quadword hashed password value is returned
1841  * as a NUL-terminated 8 character string.  my_crypt() does not change
1842  * the case of its string arguments; in order to match the behavior
1843  * of LOGINOUT et al., alphabetic characters in both arguments must
1844  *  be upcased by the caller.
1845  *
1846  * - fix me to call ACM services when available
1847  */
1848 char *
1849 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1850 {
1851 #   ifndef UAI$C_PREFERRED_ALGORITHM
1852 #     define UAI$C_PREFERRED_ALGORITHM 127
1853 #   endif
1854     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1855     unsigned short int salt = 0;
1856     unsigned long int sts;
1857     struct const_dsc {
1858         unsigned short int dsc$w_length;
1859         unsigned char      dsc$b_type;
1860         unsigned char      dsc$b_class;
1861         const char *       dsc$a_pointer;
1862     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1863        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1864     struct itmlst_3 uailst[3] = {
1865         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1866         { sizeof salt, UAI$_SALT,    &salt, 0},
1867         { 0,           0,            NULL,  NULL}};
1868     static char hash[9];
1869
1870     usrdsc.dsc$w_length = strlen(usrname);
1871     usrdsc.dsc$a_pointer = usrname;
1872     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1873       switch (sts) {
1874         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1875           set_errno(EACCES);
1876           break;
1877         case RMS$_RNF:
1878           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1879           break;
1880         default:
1881           set_errno(EVMSERR);
1882       }
1883       set_vaxc_errno(sts);
1884       if (sts != RMS$_RNF) return NULL;
1885     }
1886
1887     txtdsc.dsc$w_length = strlen(textpasswd);
1888     txtdsc.dsc$a_pointer = textpasswd;
1889     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1890       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1891     }
1892
1893     return (char *) hash;
1894
1895 }  /* end of my_crypt() */
1896 /*}}}*/
1897
1898
1899 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1900 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1901 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1902
1903 /* fixup barenames that are directories for internal use.
1904  * There have been problems with the consistent handling of UNIX
1905  * style directory names when routines are presented with a name that
1906  * has no directory delimitors at all.  So this routine will eventually
1907  * fix the issue.
1908  */
1909 static char * fixup_bare_dirnames(const char * name)
1910 {
1911   if (decc_disable_to_vms_logname_translation) {
1912 /* fix me */
1913   }
1914   return NULL;
1915 }
1916
1917 /* 8.3, remove() is now broken on symbolic links */
1918 static int rms_erase(const char * vmsname);
1919
1920
1921 /* mp_do_kill_file
1922  * A little hack to get around a bug in some implemenation of remove()
1923  * that do not know how to delete a directory
1924  *
1925  * Delete any file to which user has control access, regardless of whether
1926  * delete access is explicitly allowed.
1927  * Limitations: User must have write access to parent directory.
1928  *              Does not block signals or ASTs; if interrupted in midstream
1929  *              may leave file with an altered ACL.
1930  * HANDLE WITH CARE!
1931  */
1932 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1933 static int
1934 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1935 {
1936     char *vmsname;
1937     char *rslt;
1938     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1939     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1940     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1941     struct myacedef {
1942       unsigned char myace$b_length;
1943       unsigned char myace$b_type;
1944       unsigned short int myace$w_flags;
1945       unsigned long int myace$l_access;
1946       unsigned long int myace$l_ident;
1947     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1948                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1949       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1950      struct itmlst_3
1951        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1952                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1953        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1954        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1955        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1956        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1957
1958     /* Expand the input spec using RMS, since the CRTL remove() and
1959      * system services won't do this by themselves, so we may miss
1960      * a file "hiding" behind a logical name or search list. */
1961     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1962     if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1963
1964     rslt = do_rmsexpand(name,
1965                         vmsname,
1966                         0,
1967                         NULL,
1968                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
1969                         NULL,
1970                         NULL);
1971     if (rslt == NULL) {
1972         PerlMem_free(vmsname);
1973         return -1;
1974       }
1975
1976     /* Erase the file */
1977     rmsts = rms_erase(vmsname);
1978
1979     /* Did it succeed */
1980     if ($VMS_STATUS_SUCCESS(rmsts)) {
1981         PerlMem_free(vmsname);
1982         return 0;
1983       }
1984
1985     /* If not, can changing protections help? */
1986     if (rmsts != RMS$_PRV) {
1987       set_vaxc_errno(rmsts);
1988       PerlMem_free(vmsname);
1989       return -1;
1990     }
1991
1992     /* No, so we get our own UIC to use as a rights identifier,
1993      * and the insert an ACE at the head of the ACL which allows us
1994      * to delete the file.
1995      */
1996     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1997     fildsc.dsc$w_length = strlen(vmsname);
1998     fildsc.dsc$a_pointer = vmsname;
1999     cxt = 0;
2000     newace.myace$l_ident = oldace.myace$l_ident;
2001     rmsts = -1;
2002     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
2003       switch (aclsts) {
2004         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
2005           set_errno(ENOENT); break;
2006         case RMS$_DIR:
2007           set_errno(ENOTDIR); break;
2008         case RMS$_DEV:
2009           set_errno(ENODEV); break;
2010         case RMS$_SYN: case SS$_INVFILFOROP:
2011           set_errno(EINVAL); break;
2012         case RMS$_PRV:
2013           set_errno(EACCES); break;
2014         default:
2015           _ckvmssts_noperl(aclsts);
2016       }
2017       set_vaxc_errno(aclsts);
2018       PerlMem_free(vmsname);
2019       return -1;
2020     }
2021     /* Grab any existing ACEs with this identifier in case we fail */
2022     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
2023     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
2024                     || fndsts == SS$_NOMOREACE ) {
2025       /* Add the new ACE . . . */
2026       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
2027         goto yourroom;
2028
2029       rmsts = rms_erase(vmsname);
2030       if ($VMS_STATUS_SUCCESS(rmsts)) {
2031         rmsts = 0;
2032         }
2033         else {
2034         rmsts = -1;
2035         /* We blew it - dir with files in it, no write priv for
2036          * parent directory, etc.  Put things back the way they were. */
2037         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
2038           goto yourroom;
2039         if (fndsts & 1) {
2040           addlst[0].bufadr = &oldace;
2041           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2042             goto yourroom;
2043         }
2044       }
2045     }
2046
2047     yourroom:
2048     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2049     /* We just deleted it, so of course it's not there.  Some versions of
2050      * VMS seem to return success on the unlock operation anyhow (after all
2051      * the unlock is successful), but others don't.
2052      */
2053     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2054     if (aclsts & 1) aclsts = fndsts;
2055     if (!(aclsts & 1)) {
2056       set_errno(EVMSERR);
2057       set_vaxc_errno(aclsts);
2058     }
2059
2060     PerlMem_free(vmsname);
2061     return rmsts;
2062
2063 }  /* end of kill_file() */
2064 /*}}}*/
2065
2066
2067 /*{{{int do_rmdir(char *name)*/
2068 int
2069 Perl_do_rmdir(pTHX_ const char *name)
2070 {
2071     char * dirfile;
2072     int retval;
2073     Stat_t st;
2074
2075     dirfile = PerlMem_malloc(VMS_MAXRSS + 1);
2076     if (dirfile == NULL)
2077         _ckvmssts(SS$_INSFMEM);
2078
2079     /* Force to a directory specification */
2080     if (do_fileify_dirspec(name, dirfile, 0, NULL) == NULL) {
2081         PerlMem_free(dirfile);
2082         return -1;
2083     }
2084     if (Perl_flex_lstat(aTHX_ dirfile, &st) || !S_ISDIR(st.st_mode)) {
2085         errno = ENOTDIR;
2086         retval = -1;
2087     }
2088     else
2089         retval = mp_do_kill_file(aTHX_ dirfile, 1);
2090
2091     PerlMem_free(dirfile);
2092     return retval;
2093
2094 }  /* end of do_rmdir */
2095 /*}}}*/
2096
2097 /* kill_file
2098  * Delete any file to which user has control access, regardless of whether
2099  * delete access is explicitly allowed.
2100  * Limitations: User must have write access to parent directory.
2101  *              Does not block signals or ASTs; if interrupted in midstream
2102  *              may leave file with an altered ACL.
2103  * HANDLE WITH CARE!
2104  */
2105 /*{{{int kill_file(char *name)*/
2106 int
2107 Perl_kill_file(pTHX_ const char *name)
2108 {
2109     char rspec[NAM$C_MAXRSS+1];
2110     char *tspec;
2111     Stat_t st;
2112     int rmsts;
2113
2114    /* Remove() is allowed to delete directories, according to the X/Open
2115     * specifications.
2116     * This may need special handling to work with the ACL hacks.
2117      */
2118    if ((flex_lstat(name, &st) == 0) && S_ISDIR(st.st_mode)) {
2119         rmsts = Perl_do_rmdir(aTHX_ name);
2120         return rmsts;
2121     }
2122
2123    rmsts = mp_do_kill_file(aTHX_ name, 0);
2124
2125     return rmsts;
2126
2127 }  /* end of kill_file() */
2128 /*}}}*/
2129
2130
2131 /*{{{int my_mkdir(char *,Mode_t)*/
2132 int
2133 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2134 {
2135   STRLEN dirlen = strlen(dir);
2136
2137   /* zero length string sometimes gives ACCVIO */
2138   if (dirlen == 0) return -1;
2139
2140   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2141    * null file name/type.  However, it's commonplace under Unix,
2142    * so we'll allow it for a gain in portability.
2143    */
2144   if (dir[dirlen-1] == '/') {
2145     char *newdir = savepvn(dir,dirlen-1);
2146     int ret = mkdir(newdir,mode);
2147     Safefree(newdir);
2148     return ret;
2149   }
2150   else return mkdir(dir,mode);
2151 }  /* end of my_mkdir */
2152 /*}}}*/
2153
2154 /*{{{int my_chdir(char *)*/
2155 int
2156 Perl_my_chdir(pTHX_ const char *dir)
2157 {
2158   STRLEN dirlen = strlen(dir);
2159
2160   /* zero length string sometimes gives ACCVIO */
2161   if (dirlen == 0) return -1;
2162   const char *dir1;
2163
2164   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2165    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2166    * so that existing scripts do not need to be changed.
2167    */
2168   dir1 = dir;
2169   while ((dirlen > 0) && (*dir1 == ' ')) {
2170     dir1++;
2171     dirlen--;
2172   }
2173
2174   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2175    * that implies
2176    * null file name/type.  However, it's commonplace under Unix,
2177    * so we'll allow it for a gain in portability.
2178    *
2179    * - Preview- '/' will be valid soon on VMS
2180    */
2181   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2182     char *newdir = savepvn(dir1,dirlen-1);
2183     int ret = chdir(newdir);
2184     Safefree(newdir);
2185     return ret;
2186   }
2187   else return chdir(dir1);
2188 }  /* end of my_chdir */
2189 /*}}}*/
2190
2191
2192 /*{{{int my_chmod(char *, mode_t)*/
2193 int
2194 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2195 {
2196   STRLEN speclen = strlen(file_spec);
2197
2198   /* zero length string sometimes gives ACCVIO */
2199   if (speclen == 0) return -1;
2200
2201   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2202    * that implies null file name/type.  However, it's commonplace under Unix,
2203    * so we'll allow it for a gain in portability.
2204    *
2205    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2206    * in VMS file.dir notation.
2207    */
2208   if ((speclen > 1) && (file_spec[speclen-1] == '/')) {
2209     char *vms_src, *vms_dir, *rslt;
2210     int ret = -1;
2211     errno = EIO;
2212
2213     /* First convert this to a VMS format specification */
2214     vms_src = PerlMem_malloc(VMS_MAXRSS);
2215     if (vms_src == NULL)
2216         _ckvmssts_noperl(SS$_INSFMEM);
2217
2218     rslt = do_tovmsspec(file_spec, vms_src, 0, NULL);
2219     if (rslt == NULL) {
2220         /* If we fail, then not a file specification */
2221         PerlMem_free(vms_src);
2222         errno = EIO;
2223         return -1;
2224     }
2225
2226     /* Now make it a directory spec so chmod is happy */
2227     vms_dir = PerlMem_malloc(VMS_MAXRSS + 1);
2228     if (vms_dir == NULL)
2229         _ckvmssts_noperl(SS$_INSFMEM);
2230     rslt = do_fileify_dirspec(vms_src, vms_dir, 0, NULL);
2231     PerlMem_free(vms_src);
2232
2233     /* Now do it */
2234     if (rslt != NULL) {
2235         ret = chmod(vms_dir, mode);
2236     } else {
2237         errno = EIO;
2238     }
2239     PerlMem_free(vms_dir);
2240     return ret;
2241   }
2242   else return chmod(file_spec, mode);
2243 }  /* end of my_chmod */
2244 /*}}}*/
2245
2246
2247 /*{{{FILE *my_tmpfile()*/
2248 FILE *
2249 my_tmpfile(void)
2250 {
2251   FILE *fp;
2252   char *cp;
2253
2254   if ((fp = tmpfile())) return fp;
2255
2256   cp = PerlMem_malloc(L_tmpnam+24);
2257   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2258
2259   if (decc_filename_unix_only == 0)
2260     strcpy(cp,"Sys$Scratch:");
2261   else
2262     strcpy(cp,"/tmp/");
2263   tmpnam(cp+strlen(cp));
2264   strcat(cp,".Perltmp");
2265   fp = fopen(cp,"w+","fop=dlt");
2266   PerlMem_free(cp);
2267   return fp;
2268 }
2269 /*}}}*/
2270
2271
2272 #ifndef HOMEGROWN_POSIX_SIGNALS
2273 /*
2274  * The C RTL's sigaction fails to check for invalid signal numbers so we
2275  * help it out a bit.  The docs are correct, but the actual routine doesn't
2276  * do what the docs say it will.
2277  */
2278 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2279 int
2280 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2281                    struct sigaction* oact)
2282 {
2283   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2284         SETERRNO(EINVAL, SS$_INVARG);
2285         return -1;
2286   }
2287   return sigaction(sig, act, oact);
2288 }
2289 /*}}}*/
2290 #endif
2291
2292 #ifdef KILL_BY_SIGPRC
2293 #include <errnodef.h>
2294
2295 /* We implement our own kill() using the undocumented system service
2296    sys$sigprc for one of two reasons:
2297
2298    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2299    target process to do a sys$exit, which usually can't be handled
2300    gracefully...certainly not by Perl and the %SIG{} mechanism.
2301
2302    2.) If the kill() in the CRTL can't be called from a signal
2303    handler without disappearing into the ether, i.e., the signal
2304    it purportedly sends is never trapped. Still true as of VMS 7.3.
2305
2306    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2307    in the target process rather than calling sys$exit.
2308
2309    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2310    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2311    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2312    with condition codes C$_SIG0+nsig*8, catching the exception on the
2313    target process and resignaling with appropriate arguments.
2314
2315    But we don't have that VMS 7.0+ exception handler, so if you
2316    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2317
2318    Also note that SIGTERM is listed in the docs as being "unimplemented",
2319    yet always seems to be signaled with a VMS condition code of 4 (and
2320    correctly handled for that code).  So we hardwire it in.
2321
2322    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2323    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2324    than signalling with an unrecognized (and unhandled by CRTL) code.
2325 */
2326
2327 #define _MY_SIG_MAX 28
2328
2329 static unsigned int
2330 Perl_sig_to_vmscondition_int(int sig)
2331 {
2332     static unsigned int sig_code[_MY_SIG_MAX+1] =
2333     {
2334         0,                  /*  0 ZERO     */
2335         SS$_HANGUP,         /*  1 SIGHUP   */
2336         SS$_CONTROLC,       /*  2 SIGINT   */
2337         SS$_CONTROLY,       /*  3 SIGQUIT  */
2338         SS$_RADRMOD,        /*  4 SIGILL   */
2339         SS$_BREAK,          /*  5 SIGTRAP  */
2340         SS$_OPCCUS,         /*  6 SIGABRT  */
2341         SS$_COMPAT,         /*  7 SIGEMT   */
2342 #ifdef __VAX
2343         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2344 #else
2345         SS$_HPARITH,        /*  8 SIGFPE AXP */
2346 #endif
2347         SS$_ABORT,          /*  9 SIGKILL  */
2348         SS$_ACCVIO,         /* 10 SIGBUS   */
2349         SS$_ACCVIO,         /* 11 SIGSEGV  */
2350         SS$_BADPARAM,       /* 12 SIGSYS   */
2351         SS$_NOMBX,          /* 13 SIGPIPE  */
2352         SS$_ASTFLT,         /* 14 SIGALRM  */
2353         4,                  /* 15 SIGTERM  */
2354         0,                  /* 16 SIGUSR1  */
2355         0,                  /* 17 SIGUSR2  */
2356         0,                  /* 18 */
2357         0,                  /* 19 */
2358         0,                  /* 20 SIGCHLD  */
2359         0,                  /* 21 SIGCONT  */
2360         0,                  /* 22 SIGSTOP  */
2361         0,                  /* 23 SIGTSTP  */
2362         0,                  /* 24 SIGTTIN  */
2363         0,                  /* 25 SIGTTOU  */
2364         0,                  /* 26 */
2365         0,                  /* 27 */
2366         0                   /* 28 SIGWINCH  */
2367     };
2368
2369 #if __VMS_VER >= 60200000
2370     static int initted = 0;
2371     if (!initted) {
2372         initted = 1;
2373         sig_code[16] = C$_SIGUSR1;
2374         sig_code[17] = C$_SIGUSR2;
2375 #if __CRTL_VER >= 70000000
2376         sig_code[20] = C$_SIGCHLD;
2377 #endif
2378 #if __CRTL_VER >= 70300000
2379         sig_code[28] = C$_SIGWINCH;
2380 #endif
2381     }
2382 #endif
2383
2384     if (sig < _SIG_MIN) return 0;
2385     if (sig > _MY_SIG_MAX) return 0;
2386     return sig_code[sig];
2387 }
2388
2389 unsigned int
2390 Perl_sig_to_vmscondition(int sig)
2391 {
2392 #ifdef SS$_DEBUG
2393     if (vms_debug_on_exception != 0)
2394         lib$signal(SS$_DEBUG);
2395 #endif
2396     return Perl_sig_to_vmscondition_int(sig);
2397 }
2398
2399
2400 int
2401 Perl_my_kill(int pid, int sig)
2402 {
2403     dTHX;
2404     int iss;
2405     unsigned int code;
2406     int sys$sigprc(unsigned int *pidadr,
2407                      struct dsc$descriptor_s *prcname,
2408                      unsigned int code);
2409
2410      /* sig 0 means validate the PID */
2411     /*------------------------------*/
2412     if (sig == 0) {
2413         const unsigned long int jpicode = JPI$_PID;
2414         pid_t ret_pid;
2415         int status;
2416         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2417         if ($VMS_STATUS_SUCCESS(status))
2418            return 0;
2419         switch (status) {
2420         case SS$_NOSUCHNODE:
2421         case SS$_UNREACHABLE:
2422         case SS$_NONEXPR:
2423            errno = ESRCH;
2424            break;
2425         case SS$_NOPRIV:
2426            errno = EPERM;
2427            break;
2428         default:
2429            errno = EVMSERR;
2430         }
2431         vaxc$errno=status;
2432         return -1;
2433     }
2434
2435     code = Perl_sig_to_vmscondition_int(sig);
2436
2437     if (!code) {
2438         SETERRNO(EINVAL, SS$_BADPARAM);
2439         return -1;
2440     }
2441
2442     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2443      * signals are to be sent to multiple processes.
2444      *  pid = 0 - all processes in group except ones that the system exempts
2445      *  pid = -1 - all processes except ones that the system exempts
2446      *  pid = -n - all processes in group (abs(n)) except ...
2447      * For now, just report as not supported.
2448      */
2449
2450     if (pid <= 0) {
2451         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2452         return -1;
2453     }
2454
2455     iss = sys$sigprc((unsigned int *)&pid,0,code);
2456     if (iss&1) return 0;
2457
2458     switch (iss) {
2459       case SS$_NOPRIV:
2460         set_errno(EPERM);  break;
2461       case SS$_NONEXPR:
2462       case SS$_NOSUCHNODE:
2463       case SS$_UNREACHABLE:
2464         set_errno(ESRCH);  break;
2465       case SS$_INSFMEM:
2466         set_errno(ENOMEM); break;
2467       default:
2468         _ckvmssts_noperl(iss);
2469         set_errno(EVMSERR);
2470     }
2471     set_vaxc_errno(iss);
2472
2473     return -1;
2474 }
2475 #endif
2476
2477 /* Routine to convert a VMS status code to a UNIX status code.
2478 ** More tricky than it appears because of conflicting conventions with
2479 ** existing code.
2480 **
2481 ** VMS status codes are a bit mask, with the least significant bit set for
2482 ** success.
2483 **
2484 ** Special UNIX status of EVMSERR indicates that no translation is currently
2485 ** available, and programs should check the VMS status code.
2486 **
2487 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2488 ** decoding.
2489 */
2490
2491 #ifndef C_FACILITY_NO
2492 #define C_FACILITY_NO 0x350000
2493 #endif
2494 #ifndef DCL_IVVERB
2495 #define DCL_IVVERB 0x38090
2496 #endif
2497
2498 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2499 {
2500 int facility;
2501 int fac_sp;
2502 int msg_no;
2503 int msg_status;
2504 int unix_status;
2505
2506   /* Assume the best or the worst */
2507   if (vms_status & STS$M_SUCCESS)
2508     unix_status = 0;
2509   else
2510     unix_status = EVMSERR;
2511
2512   msg_status = vms_status & ~STS$M_CONTROL;
2513
2514   facility = vms_status & STS$M_FAC_NO;
2515   fac_sp = vms_status & STS$M_FAC_SP;
2516   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2517
2518   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2519     switch(msg_no) {
2520     case SS$_NORMAL:
2521         unix_status = 0;
2522         break;
2523     case SS$_ACCVIO:
2524         unix_status = EFAULT;
2525         break;
2526     case SS$_DEVOFFLINE:
2527         unix_status = EBUSY;
2528         break;
2529     case SS$_CLEARED:
2530         unix_status = ENOTCONN;
2531         break;
2532     case SS$_IVCHAN:
2533     case SS$_IVLOGNAM:
2534     case SS$_BADPARAM:
2535     case SS$_IVLOGTAB:
2536     case SS$_NOLOGNAM:
2537     case SS$_NOLOGTAB:
2538     case SS$_INVFILFOROP:
2539     case SS$_INVARG:
2540     case SS$_NOSUCHID:
2541     case SS$_IVIDENT:
2542         unix_status = EINVAL;
2543         break;
2544     case SS$_UNSUPPORTED:
2545         unix_status = ENOTSUP;
2546         break;
2547     case SS$_FILACCERR:
2548     case SS$_NOGRPPRV:
2549     case SS$_NOSYSPRV:
2550         unix_status = EACCES;
2551         break;
2552     case SS$_DEVICEFULL:
2553         unix_status = ENOSPC;
2554         break;
2555     case SS$_NOSUCHDEV:
2556         unix_status = ENODEV;
2557         break;
2558     case SS$_NOSUCHFILE:
2559     case SS$_NOSUCHOBJECT:
2560         unix_status = ENOENT;
2561         break;
2562     case SS$_ABORT:                                 /* Fatal case */
2563     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2564     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2565         unix_status = EINTR;
2566         break;
2567     case SS$_BUFFEROVF:
2568         unix_status = E2BIG;
2569         break;
2570     case SS$_INSFMEM:
2571         unix_status = ENOMEM;
2572         break;
2573     case SS$_NOPRIV:
2574         unix_status = EPERM;
2575         break;
2576     case SS$_NOSUCHNODE:
2577     case SS$_UNREACHABLE:
2578         unix_status = ESRCH;
2579         break;
2580     case SS$_NONEXPR:
2581         unix_status = ECHILD;
2582         break;
2583     default:
2584         if ((facility == 0) && (msg_no < 8)) {
2585           /* These are not real VMS status codes so assume that they are
2586           ** already UNIX status codes
2587           */
2588           unix_status = msg_no;
2589           break;
2590         }
2591     }
2592   }
2593   else {
2594     /* Translate a POSIX exit code to a UNIX exit code */
2595     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2596         unix_status = (msg_no & 0x07F8) >> 3;
2597     }
2598     else {
2599
2600          /* Documented traditional behavior for handling VMS child exits */
2601         /*--------------------------------------------------------------*/
2602         if (child_flag != 0) {
2603
2604              /* Success / Informational return 0 */
2605             /*----------------------------------*/
2606             if (msg_no & STS$K_SUCCESS)
2607                 return 0;
2608
2609              /* Warning returns 1 */
2610             /*-------------------*/
2611             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2612                 return 1;
2613
2614              /* Everything else pass through the severity bits */
2615             /*------------------------------------------------*/
2616             return (msg_no & STS$M_SEVERITY);
2617         }
2618
2619          /* Normal VMS status to ERRNO mapping attempt */
2620         /*--------------------------------------------*/
2621         switch(msg_status) {
2622         /* case RMS$_EOF: */ /* End of File */
2623         case RMS$_FNF:  /* File Not Found */
2624         case RMS$_DNF:  /* Dir Not Found */
2625                 unix_status = ENOENT;
2626                 break;
2627         case RMS$_RNF:  /* Record Not Found */
2628                 unix_status = ESRCH;
2629                 break;
2630         case RMS$_DIR:
2631                 unix_status = ENOTDIR;
2632                 break;
2633         case RMS$_DEV:
2634                 unix_status = ENODEV;
2635                 break;
2636         case RMS$_IFI:
2637         case RMS$_FAC:
2638         case RMS$_ISI:
2639                 unix_status = EBADF;
2640                 break;
2641         case RMS$_FEX:
2642                 unix_status = EEXIST;
2643                 break;
2644         case RMS$_SYN:
2645         case RMS$_FNM:
2646         case LIB$_INVSTRDES:
2647         case LIB$_INVARG:
2648         case LIB$_NOSUCHSYM:
2649         case LIB$_INVSYMNAM:
2650         case DCL_IVVERB:
2651                 unix_status = EINVAL;
2652                 break;
2653         case CLI$_BUFOVF:
2654         case RMS$_RTB:
2655         case CLI$_TKNOVF:
2656         case CLI$_RSLOVF:
2657                 unix_status = E2BIG;
2658                 break;
2659         case RMS$_PRV:  /* No privilege */
2660         case RMS$_ACC:  /* ACP file access failed */
2661         case RMS$_WLK:  /* Device write locked */
2662                 unix_status = EACCES;
2663                 break;
2664         case RMS$_MKD:  /* Failed to mark for delete */
2665                 unix_status = EPERM;
2666                 break;
2667         /* case RMS$_NMF: */  /* No more files */
2668         }
2669     }
2670   }
2671
2672   return unix_status;
2673 }
2674
2675 /* Try to guess at what VMS error status should go with a UNIX errno
2676  * value.  This is hard to do as there could be many possible VMS
2677  * error statuses that caused the errno value to be set.
2678  */
2679
2680 int Perl_unix_status_to_vms(int unix_status)
2681 {
2682 int test_unix_status;
2683
2684      /* Trivial cases first */
2685     /*---------------------*/
2686     if (unix_status == EVMSERR)
2687         return vaxc$errno;
2688
2689      /* Is vaxc$errno sane? */
2690     /*---------------------*/
2691     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2692     if (test_unix_status == unix_status)
2693         return vaxc$errno;
2694
2695      /* If way out of range, must be VMS code already */
2696     /*-----------------------------------------------*/
2697     if (unix_status > EVMSERR)
2698         return unix_status;
2699
2700      /* If out of range, punt */
2701     /*-----------------------*/
2702     if (unix_status > __ERRNO_MAX)
2703         return SS$_ABORT;
2704
2705
2706      /* Ok, now we have to do it the hard way. */
2707     /*----------------------------------------*/
2708     switch(unix_status) {
2709     case 0:     return SS$_NORMAL;
2710     case EPERM: return SS$_NOPRIV;
2711     case ENOENT: return SS$_NOSUCHOBJECT;
2712     case ESRCH: return SS$_UNREACHABLE;
2713     case EINTR: return SS$_ABORT;
2714     /* case EIO: */
2715     /* case ENXIO:  */
2716     case E2BIG: return SS$_BUFFEROVF;
2717     /* case ENOEXEC */
2718     case EBADF: return RMS$_IFI;
2719     case ECHILD: return SS$_NONEXPR;
2720     /* case EAGAIN */
2721     case ENOMEM: return SS$_INSFMEM;
2722     case EACCES: return SS$_FILACCERR;
2723     case EFAULT: return SS$_ACCVIO;
2724     /* case ENOTBLK */
2725     case EBUSY: return SS$_DEVOFFLINE;
2726     case EEXIST: return RMS$_FEX;
2727     /* case EXDEV */
2728     case ENODEV: return SS$_NOSUCHDEV;
2729     case ENOTDIR: return RMS$_DIR;
2730     /* case EISDIR */
2731     case EINVAL: return SS$_INVARG;
2732     /* case ENFILE */
2733     /* case EMFILE */
2734     /* case ENOTTY */
2735     /* case ETXTBSY */
2736     /* case EFBIG */
2737     case ENOSPC: return SS$_DEVICEFULL;
2738     case ESPIPE: return LIB$_INVARG;
2739     /* case EROFS: */
2740     /* case EMLINK: */
2741     /* case EPIPE: */
2742     /* case EDOM */
2743     case ERANGE: return LIB$_INVARG;
2744     /* case EWOULDBLOCK */
2745     /* case EINPROGRESS */
2746     /* case EALREADY */
2747     /* case ENOTSOCK */
2748     /* case EDESTADDRREQ */
2749     /* case EMSGSIZE */
2750     /* case EPROTOTYPE */
2751     /* case ENOPROTOOPT */
2752     /* case EPROTONOSUPPORT */
2753     /* case ESOCKTNOSUPPORT */
2754     /* case EOPNOTSUPP */
2755     /* case EPFNOSUPPORT */
2756     /* case EAFNOSUPPORT */
2757     /* case EADDRINUSE */
2758     /* case EADDRNOTAVAIL */
2759     /* case ENETDOWN */
2760     /* case ENETUNREACH */
2761     /* case ENETRESET */
2762     /* case ECONNABORTED */
2763     /* case ECONNRESET */
2764     /* case ENOBUFS */
2765     /* case EISCONN */
2766     case ENOTCONN: return SS$_CLEARED;
2767     /* case ESHUTDOWN */
2768     /* case ETOOMANYREFS */
2769     /* case ETIMEDOUT */
2770     /* case ECONNREFUSED */
2771     /* case ELOOP */
2772     /* case ENAMETOOLONG */
2773     /* case EHOSTDOWN */
2774     /* case EHOSTUNREACH */
2775     /* case ENOTEMPTY */
2776     /* case EPROCLIM */
2777     /* case EUSERS  */
2778     /* case EDQUOT  */
2779     /* case ENOMSG  */
2780     /* case EIDRM */
2781     /* case EALIGN */
2782     /* case ESTALE */
2783     /* case EREMOTE */
2784     /* case ENOLCK */
2785     /* case ENOSYS */
2786     /* case EFTYPE */
2787     /* case ECANCELED */
2788     /* case EFAIL */
2789     /* case EINPROG */
2790     case ENOTSUP:
2791         return SS$_UNSUPPORTED;
2792     /* case EDEADLK */
2793     /* case ENWAIT */
2794     /* case EILSEQ */
2795     /* case EBADCAT */
2796     /* case EBADMSG */
2797     /* case EABANDONED */
2798     default:
2799         return SS$_ABORT; /* punt */
2800     }
2801
2802   return SS$_ABORT; /* Should not get here */
2803 }
2804
2805
2806 /* default piping mailbox size */
2807 #define PERL_BUFSIZ        512
2808
2809
2810 static void
2811 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2812 {
2813   unsigned long int mbxbufsiz;
2814   static unsigned long int syssize = 0;
2815   unsigned long int dviitm = DVI$_DEVNAM;
2816   char csize[LNM$C_NAMLENGTH+1];
2817   int sts;
2818
2819   if (!syssize) {
2820     unsigned long syiitm = SYI$_MAXBUF;
2821     /*
2822      * Get the SYSGEN parameter MAXBUF
2823      *
2824      * If the logical 'PERL_MBX_SIZE' is defined
2825      * use the value of the logical instead of PERL_BUFSIZ, but
2826      * keep the size between 128 and MAXBUF.
2827      *
2828      */
2829     _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2830   }
2831
2832   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2833       mbxbufsiz = atoi(csize);
2834   } else {
2835       mbxbufsiz = PERL_BUFSIZ;
2836   }
2837   if (mbxbufsiz < 128) mbxbufsiz = 128;
2838   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2839
2840   _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2841
2842   sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2843   _ckvmssts_noperl(sts);
2844   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2845
2846 }  /* end of create_mbx() */
2847
2848
2849 /*{{{  my_popen and my_pclose*/
2850
2851 typedef struct _iosb           IOSB;
2852 typedef struct _iosb*         pIOSB;
2853 typedef struct _pipe           Pipe;
2854 typedef struct _pipe*         pPipe;
2855 typedef struct pipe_details    Info;
2856 typedef struct pipe_details*  pInfo;
2857 typedef struct _srqp            RQE;
2858 typedef struct _srqp*          pRQE;
2859 typedef struct _tochildbuf      CBuf;
2860 typedef struct _tochildbuf*    pCBuf;
2861
2862 struct _iosb {
2863     unsigned short status;
2864     unsigned short count;
2865     unsigned long  dvispec;
2866 };
2867
2868 #pragma member_alignment save
2869 #pragma nomember_alignment quadword
2870 struct _srqp {          /* VMS self-relative queue entry */
2871     unsigned long qptr[2];
2872 };
2873 #pragma member_alignment restore
2874 static RQE  RQE_ZERO = {0,0};
2875
2876 struct _tochildbuf {
2877     RQE             q;
2878     int             eof;
2879     unsigned short  size;
2880     char            *buf;
2881 };
2882
2883 struct _pipe {
2884     RQE            free;
2885     RQE            wait;
2886     int            fd_out;
2887     unsigned short chan_in;
2888     unsigned short chan_out;
2889     char          *buf;
2890     unsigned int   bufsize;
2891     IOSB           iosb;
2892     IOSB           iosb2;
2893     int           *pipe_done;
2894     int            retry;
2895     int            type;
2896     int            shut_on_empty;
2897     int            need_wake;
2898     pPipe         *home;
2899     pInfo          info;
2900     pCBuf          curr;
2901     pCBuf          curr2;
2902 #if defined(PERL_IMPLICIT_CONTEXT)
2903     void            *thx;           /* Either a thread or an interpreter */
2904                                     /* pointer, depending on how we're built */
2905 #endif
2906 };
2907
2908
2909 struct pipe_details
2910 {
2911     pInfo           next;
2912     PerlIO *fp;  /* file pointer to pipe mailbox */
2913     int useFILE; /* using stdio, not perlio */
2914     int pid;   /* PID of subprocess */
2915     int mode;  /* == 'r' if pipe open for reading */
2916     int done;  /* subprocess has completed */
2917     int waiting; /* waiting for completion/closure */
2918     int             closing;        /* my_pclose is closing this pipe */
2919     unsigned long   completion;     /* termination status of subprocess */
2920     pPipe           in;             /* pipe in to sub */
2921     pPipe           out;            /* pipe out of sub */
2922     pPipe           err;            /* pipe of sub's sys$error */
2923     int             in_done;        /* true when in pipe finished */
2924     int             out_done;
2925     int             err_done;
2926     unsigned short  xchan;          /* channel to debug xterm */
2927     unsigned short  xchan_valid;    /* channel is assigned */
2928 };
2929
2930 struct exit_control_block
2931 {
2932     struct exit_control_block *flink;
2933     unsigned long int   (*exit_routine)();
2934     unsigned long int arg_count;
2935     unsigned long int *status_address;
2936     unsigned long int exit_status;
2937 };
2938
2939 typedef struct _closed_pipes    Xpipe;
2940 typedef struct _closed_pipes*  pXpipe;
2941
2942 struct _closed_pipes {
2943     int             pid;            /* PID of subprocess */
2944     unsigned long   completion;     /* termination status of subprocess */
2945 };
2946 #define NKEEPCLOSED 50
2947 static Xpipe closed_list[NKEEPCLOSED];
2948 static int   closed_index = 0;
2949 static int   closed_num = 0;
2950
2951 #define RETRY_DELAY     "0 ::0.20"
2952 #define MAX_RETRY              50
2953
2954 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2955 static unsigned long mypid;
2956 static unsigned long delaytime[2];
2957
2958 static pInfo open_pipes = NULL;
2959 static $DESCRIPTOR(nl_desc, "NL:");
2960
2961 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2962
2963
2964
2965 static unsigned long int
2966 pipe_exit_routine()
2967 {
2968     pInfo info;
2969     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2970     int sts, did_stuff, need_eof, j;
2971
2972    /*
2973     * Flush any pending i/o, but since we are in process run-down, be
2974     * careful about referencing PerlIO structures that may already have
2975     * been deallocated.  We may not even have an interpreter anymore.
2976     */
2977     info = open_pipes;
2978     while (info) {
2979         if (info->fp) {
2980 #if defined(PERL_IMPLICIT_CONTEXT)
2981            /* We need to use the Perl context of the thread that created */
2982            /* the pipe. */
2983            pTHX;
2984            if (info->err)
2985                aTHX = info->err->thx;
2986            else if (info->out)
2987                aTHX = info->out->thx;
2988            else if (info->in)
2989                aTHX = info->in->thx;
2990 #endif
2991            if (!info->useFILE
2992 #if defined(USE_ITHREADS)
2993              && my_perl
2994 #endif
2995              && PL_perlio_fd_refcnt)
2996                PerlIO_flush(info->fp);
2997            else
2998                fflush((FILE *)info->fp);
2999         }
3000         info = info->next;
3001     }
3002
3003     /*
3004      next we try sending an EOF...ignore if doesn't work, make sure we
3005      don't hang
3006     */
3007     did_stuff = 0;
3008     info = open_pipes;
3009
3010     while (info) {
3011       int need_eof;
3012       _ckvmssts_noperl(sys$setast(0));
3013       if (info->in && !info->in->shut_on_empty) {
3014         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3015                                  0, 0, 0, 0, 0, 0));
3016         info->waiting = 1;
3017         did_stuff = 1;
3018       }
3019       _ckvmssts_noperl(sys$setast(1));
3020       info = info->next;
3021     }
3022
3023     /* wait for EOF to have effect, up to ~ 30 sec [default] */
3024
3025     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3026         int nwait = 0;
3027
3028         info = open_pipes;
3029         while (info) {
3030           _ckvmssts_noperl(sys$setast(0));
3031           if (info->waiting && info->done)
3032                 info->waiting = 0;
3033           nwait += info->waiting;
3034           _ckvmssts_noperl(sys$setast(1));
3035           info = info->next;
3036         }
3037         if (!nwait) break;
3038         sleep(1);
3039     }
3040
3041     did_stuff = 0;
3042     info = open_pipes;
3043     while (info) {
3044       _ckvmssts_noperl(sys$setast(0));
3045       if (!info->done) { /* Tap them gently on the shoulder . . .*/
3046         sts = sys$forcex(&info->pid,0,&abort);
3047         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3048         did_stuff = 1;
3049       }
3050       _ckvmssts_noperl(sys$setast(1));
3051       info = info->next;
3052     }
3053
3054     /* again, wait for effect */
3055
3056     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3057         int nwait = 0;
3058
3059         info = open_pipes;
3060         while (info) {
3061           _ckvmssts_noperl(sys$setast(0));
3062           if (info->waiting && info->done)
3063                 info->waiting = 0;
3064           nwait += info->waiting;
3065           _ckvmssts_noperl(sys$setast(1));
3066           info = info->next;
3067         }
3068         if (!nwait) break;
3069         sleep(1);
3070     }
3071
3072     info = open_pipes;
3073     while (info) {
3074       _ckvmssts_noperl(sys$setast(0));
3075       if (!info->done) {  /* We tried to be nice . . . */
3076         sts = sys$delprc(&info->pid,0);
3077         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3078         info->done = 1;  /* sys$delprc is as done as we're going to get. */
3079       }
3080       _ckvmssts_noperl(sys$setast(1));
3081       info = info->next;
3082     }
3083
3084     while(open_pipes) {
3085
3086 #if defined(PERL_IMPLICIT_CONTEXT)
3087       /* We need to use the Perl context of the thread that created */
3088       /* the pipe. */
3089       pTHX;
3090       if (open_pipes->err)
3091           aTHX = open_pipes->err->thx;
3092       else if (open_pipes->out)
3093           aTHX = open_pipes->out->thx;
3094       else if (open_pipes->in)
3095           aTHX = open_pipes->in->thx;
3096 #endif
3097       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3098       else if (!(sts & 1)) retsts = sts;
3099     }
3100     return retsts;
3101 }
3102
3103 static struct exit_control_block pipe_exitblock =
3104        {(struct exit_control_block *) 0,
3105         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3106
3107 static void pipe_mbxtofd_ast(pPipe p);
3108 static void pipe_tochild1_ast(pPipe p);
3109 static void pipe_tochild2_ast(pPipe p);
3110
3111 static void
3112 popen_completion_ast(pInfo info)
3113 {
3114   pInfo i = open_pipes;
3115   int iss;
3116   int sts;
3117   pXpipe x;
3118
3119   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3120   closed_list[closed_index].pid = info->pid;
3121   closed_list[closed_index].completion = info->completion;
3122   closed_index++;
3123   if (closed_index == NKEEPCLOSED)
3124     closed_index = 0;
3125   closed_num++;
3126
3127   while (i) {
3128     if (i == info) break;
3129     i = i->next;
3130   }
3131   if (!i) return;       /* unlinked, probably freed too */
3132
3133   info->done = TRUE;
3134
3135 /*
3136     Writing to subprocess ...
3137             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3138
3139             chan_out may be waiting for "done" flag, or hung waiting
3140             for i/o completion to child...cancel the i/o.  This will
3141             put it into "snarf mode" (done but no EOF yet) that discards
3142             input.
3143
3144     Output from subprocess (stdout, stderr) needs to be flushed and
3145     shut down.   We try sending an EOF, but if the mbx is full the pipe
3146     routine should still catch the "shut_on_empty" flag, telling it to
3147     use immediate-style reads so that "mbx empty" -> EOF.
3148
3149
3150 */
3151   if (info->in && !info->in_done) {               /* only for mode=w */
3152         if (info->in->shut_on_empty && info->in->need_wake) {
3153             info->in->need_wake = FALSE;
3154             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3155         } else {
3156             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3157         }
3158   }
3159
3160   if (info->out && !info->out_done) {             /* were we also piping output? */
3161       info->out->shut_on_empty = TRUE;
3162       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3163       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3164       _ckvmssts_noperl(iss);
3165   }
3166
3167   if (info->err && !info->err_done) {        /* we were piping stderr */
3168         info->err->shut_on_empty = TRUE;
3169         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3170         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3171         _ckvmssts_noperl(iss);
3172   }
3173   _ckvmssts_noperl(sys$setef(pipe_ef));
3174
3175 }
3176
3177 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3178 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3179
3180 /*
3181     we actually differ from vmstrnenv since we use this to
3182     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3183     are pointing to the same thing
3184 */
3185
3186 static unsigned short
3187 popen_translate(pTHX_ char *logical, char *result)
3188 {
3189     int iss;
3190     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3191     $DESCRIPTOR(d_log,"");
3192     struct _il3 {
3193         unsigned short length;
3194         unsigned short code;
3195         char *         buffer_addr;
3196         unsigned short *retlenaddr;
3197     } itmlst[2];
3198     unsigned short l, ifi;
3199
3200     d_log.dsc$a_pointer = logical;
3201     d_log.dsc$w_length  = strlen(logical);
3202
3203     itmlst[0].code = LNM$_STRING;
3204     itmlst[0].length = 255;
3205     itmlst[0].buffer_addr = result;
3206     itmlst[0].retlenaddr = &l;
3207
3208     itmlst[1].code = 0;
3209     itmlst[1].length = 0;
3210     itmlst[1].buffer_addr = 0;
3211     itmlst[1].retlenaddr = 0;
3212
3213     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3214     if (iss == SS$_NOLOGNAM) {
3215         iss = SS$_NORMAL;
3216         l = 0;
3217     }
3218     if (!(iss&1)) lib$signal(iss);
3219     result[l] = '\0';
3220 /*
3221     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
3222     strip it off and return the ifi, if any
3223 */
3224     ifi  = 0;
3225     if (result[0] == 0x1b && result[1] == 0x00) {
3226         memmove(&ifi,result+2,2);
3227         strcpy(result,result+4);
3228     }
3229     return ifi;     /* this is the RMS internal file id */
3230 }
3231
3232 static void pipe_infromchild_ast(pPipe p);
3233
3234 /*
3235     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3236     inside an AST routine without worrying about reentrancy and which Perl
3237     memory allocator is being used.
3238
3239     We read data and queue up the buffers, then spit them out one at a
3240     time to the output mailbox when the output mailbox is ready for one.
3241
3242 */
3243 #define INITIAL_TOCHILDQUEUE  2
3244
3245 static pPipe
3246 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3247 {
3248     pPipe p;
3249     pCBuf b;
3250     char mbx1[64], mbx2[64];
3251     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3252                                       DSC$K_CLASS_S, mbx1},
3253                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3254                                       DSC$K_CLASS_S, mbx2};
3255     unsigned int dviitm = DVI$_DEVBUFSIZ;
3256     int j, n;
3257
3258     n = sizeof(Pipe);
3259     _ckvmssts_noperl(lib$get_vm(&n, &p));
3260
3261     create_mbx(&p->chan_in , &d_mbx1);
3262     create_mbx(&p->chan_out, &d_mbx2);
3263     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3264
3265     p->buf           = 0;
3266     p->shut_on_empty = FALSE;
3267     p->need_wake     = FALSE;
3268     p->type          = 0;
3269     p->retry         = 0;
3270     p->iosb.status   = SS$_NORMAL;
3271     p->iosb2.status  = SS$_NORMAL;
3272     p->free          = RQE_ZERO;
3273     p->wait          = RQE_ZERO;
3274     p->curr          = 0;
3275     p->curr2         = 0;
3276     p->info          = 0;
3277 #ifdef PERL_IMPLICIT_CONTEXT
3278     p->thx           = aTHX;
3279 #endif
3280
3281     n = sizeof(CBuf) + p->bufsize;
3282
3283     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3284         _ckvmssts_noperl(lib$get_vm(&n, &b));
3285         b->buf = (char *) b + sizeof(CBuf);
3286         _ckvmssts_noperl(lib$insqhi(b, &p->free));
3287     }
3288
3289     pipe_tochild2_ast(p);
3290     pipe_tochild1_ast(p);
3291     strcpy(wmbx, mbx1);
3292     strcpy(rmbx, mbx2);
3293     return p;
3294 }
3295
3296 /*  reads the MBX Perl is writing, and queues */
3297
3298 static void
3299 pipe_tochild1_ast(pPipe p)
3300 {
3301     pCBuf b = p->curr;
3302     int iss = p->iosb.status;
3303     int eof = (iss == SS$_ENDOFFILE);
3304     int sts;
3305 #ifdef PERL_IMPLICIT_CONTEXT
3306     pTHX = p->thx;
3307 #endif
3308
3309     if (p->retry) {
3310         if (eof) {
3311             p->shut_on_empty = TRUE;
3312             b->eof     = TRUE;
3313             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3314         } else  {
3315             _ckvmssts_noperl(iss);
3316         }
3317
3318         b->eof  = eof;
3319         b->size = p->iosb.count;
3320         _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3321         if (p->need_wake) {
3322             p->need_wake = FALSE;
3323             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3324         }
3325     } else {
3326         p->retry = 1;   /* initial call */
3327     }
3328
3329     if (eof) {                  /* flush the free queue, return when done */
3330         int n = sizeof(CBuf) + p->bufsize;
3331         while (1) {
3332             iss = lib$remqti(&p->free, &b);
3333             if (iss == LIB$_QUEWASEMP) return;
3334             _ckvmssts_noperl(iss);
3335             _ckvmssts_noperl(lib$free_vm(&n, &b));
3336         }
3337     }
3338
3339     iss = lib$remqti(&p->free, &b);
3340     if (iss == LIB$_QUEWASEMP) {
3341         int n = sizeof(CBuf) + p->bufsize;
3342         _ckvmssts_noperl(lib$get_vm(&n, &b));
3343         b->buf = (char *) b + sizeof(CBuf);
3344     } else {
3345        _ckvmssts_noperl(iss);
3346     }
3347
3348     p->curr = b;
3349     iss = sys$qio(0,p->chan_in,
3350              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3351              &p->iosb,
3352              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3353     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3354     _ckvmssts_noperl(iss);
3355 }
3356
3357
3358 /* writes queued buffers to output, waits for each to complete before
3359    doing the next */
3360
3361 static void
3362 pipe_tochild2_ast(pPipe p)
3363 {
3364     pCBuf b = p->curr2;
3365     int iss = p->iosb2.status;
3366     int n = sizeof(CBuf) + p->bufsize;
3367     int done = (p->info && p->info->done) ||
3368               iss == SS$_CANCEL || iss == SS$_ABORT;
3369 #if defined(PERL_IMPLICIT_CONTEXT)
3370     pTHX = p->thx;
3371 #endif
3372
3373     do {
3374         if (p->type) {         /* type=1 has old buffer, dispose */
3375             if (p->shut_on_empty) {
3376                 _ckvmssts_noperl(lib$free_vm(&n, &b));
3377             } else {
3378                 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3379             }
3380             p->type = 0;
3381         }
3382
3383         iss = lib$remqti(&p->wait, &b);
3384         if (iss == LIB$_QUEWASEMP) {
3385             if (p->shut_on_empty) {
3386                 if (done) {
3387                     _ckvmssts_noperl(sys$dassgn(p->chan_out));
3388                     *p->pipe_done = TRUE;
3389                     _ckvmssts_noperl(sys$setef(pipe_ef));
3390                 } else {
3391                     _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3392                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3393                 }
3394                 return;
3395             }
3396             p->need_wake = TRUE;
3397             return;
3398         }
3399         _ckvmssts_noperl(iss);
3400         p->type = 1;
3401     } while (done);
3402
3403
3404     p->curr2 = b;
3405     if (b->eof) {
3406         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3407             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3408     } else {
3409         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3410             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3411     }
3412
3413     return;
3414
3415 }
3416
3417
3418 static pPipe
3419 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3420 {
3421     pPipe p;
3422     char mbx1[64], mbx2[64];
3423     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3424                                       DSC$K_CLASS_S, mbx1},
3425                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3426                                       DSC$K_CLASS_S, mbx2};
3427     unsigned int dviitm = DVI$_DEVBUFSIZ;
3428
3429     int n = sizeof(Pipe);
3430     _ckvmssts_noperl(lib$get_vm(&n, &p));
3431     create_mbx(&p->chan_in , &d_mbx1);
3432     create_mbx(&p->chan_out, &d_mbx2);
3433
3434     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3435     n = p->bufsize * sizeof(char);
3436     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3437     p->shut_on_empty = FALSE;
3438     p->info   = 0;
3439     p->type   = 0;
3440     p->iosb.status = SS$_NORMAL;
3441 #if defined(PERL_IMPLICIT_CONTEXT)
3442     p->thx = aTHX;
3443 #endif
3444     pipe_infromchild_ast(p);
3445
3446     strcpy(wmbx, mbx1);
3447     strcpy(rmbx, mbx2);
3448     return p;
3449 }
3450
3451 static void
3452 pipe_infromchild_ast(pPipe p)
3453 {
3454     int iss = p->iosb.status;
3455     int eof = (iss == SS$_ENDOFFILE);
3456     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3457     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3458 #if defined(PERL_IMPLICIT_CONTEXT)
3459     pTHX = p->thx;
3460 #endif
3461
3462     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3463         _ckvmssts_noperl(sys$dassgn(p->chan_out));
3464         p->chan_out = 0;
3465     }
3466
3467     /* read completed:
3468             input shutdown if EOF from self (done or shut_on_empty)
3469             output shutdown if closing flag set (my_pclose)
3470             send data/eof from child or eof from self
3471             otherwise, re-read (snarf of data from child)
3472     */
3473
3474     if (p->type == 1) {
3475         p->type = 0;
3476         if (myeof && p->chan_in) {                  /* input shutdown */
3477             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3478             p->chan_in = 0;
3479         }
3480
3481         if (p->chan_out) {
3482             if (myeof || kideof) {      /* pass EOF to parent */
3483                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3484                                          pipe_infromchild_ast, p,
3485                                          0, 0, 0, 0, 0, 0));
3486                 return;
3487             } else if (eof) {       /* eat EOF --- fall through to read*/
3488
3489             } else {                /* transmit data */
3490                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3491                                          pipe_infromchild_ast,p,
3492                                          p->buf, p->iosb.count, 0, 0, 0, 0));
3493                 return;
3494             }
3495         }
3496     }
3497
3498     /*  everything shut? flag as done */
3499
3500     if (!p->chan_in && !p->chan_out) {
3501         *p->pipe_done = TRUE;
3502         _ckvmssts_noperl(sys$setef(pipe_ef));
3503         return;
3504     }
3505
3506     /* write completed (or read, if snarfing from child)
3507             if still have input active,
3508                queue read...immediate mode if shut_on_empty so we get EOF if empty
3509             otherwise,
3510                check if Perl reading, generate EOFs as needed
3511     */
3512
3513     if (p->type == 0) {
3514         p->type = 1;
3515         if (p->chan_in) {
3516             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3517                           pipe_infromchild_ast,p,
3518                           p->buf, p->bufsize, 0, 0, 0, 0);
3519             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3520             _ckvmssts_noperl(iss);
3521         } else {           /* send EOFs for extra reads */
3522             p->iosb.status = SS$_ENDOFFILE;
3523             p->iosb.dvispec = 0;
3524             _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3525                                      0, 0, 0,
3526                                      pipe_infromchild_ast, p, 0, 0, 0, 0));
3527         }
3528     }
3529 }
3530
3531 static pPipe
3532 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3533 {
3534     pPipe p;
3535     char mbx[64];
3536     unsigned long dviitm = DVI$_DEVBUFSIZ;
3537     struct stat s;
3538     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3539                                       DSC$K_CLASS_S, mbx};
3540     int n = sizeof(Pipe);
3541
3542     /* things like terminals and mbx's don't need this filter */
3543     if (fd && fstat(fd,&s) == 0) {
3544         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3545         char device[65];
3546         unsigned short dev_len;
3547         struct dsc$descriptor_s d_dev;
3548         char * cptr;
3549         struct item_list_3 items[3];
3550         int status;
3551         unsigned short dvi_iosb[4];
3552
3553         cptr = getname(fd, out, 1);
3554         if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3555         d_dev.dsc$a_pointer = out;
3556         d_dev.dsc$w_length = strlen(out);
3557         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3558         d_dev.dsc$b_class = DSC$K_CLASS_S;
3559
3560         items[0].len = 4;
3561         items[0].code = DVI$_DEVCHAR;
3562         items[0].bufadr = &devchar;
3563         items[0].retadr = NULL;
3564         items[1].len = 64;
3565         items[1].code = DVI$_FULLDEVNAM;
3566         items[1].bufadr = device;
3567         items[1].retadr = &dev_len;
3568         items[2].len = 0;
3569         items[2].code = 0;
3570
3571         status = sys$getdviw
3572                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3573         _ckvmssts_noperl(status);
3574         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3575             device[dev_len] = 0;
3576
3577             if (!(devchar & DEV$M_DIR)) {
3578                 strcpy(out, device);
3579                 return 0;
3580             }
3581         }
3582     }
3583
3584     _ckvmssts_noperl(lib$get_vm(&n, &p));
3585     p->fd_out = dup(fd);
3586     create_mbx(&p->chan_in, &d_mbx);
3587     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3588     n = (p->bufsize+1) * sizeof(char);
3589     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3590     p->shut_on_empty = FALSE;
3591     p->retry = 0;
3592     p->info  = 0;
3593     strcpy(out, mbx);
3594
3595     _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3596                              pipe_mbxtofd_ast, p,
3597                              p->buf, p->bufsize, 0, 0, 0, 0));
3598
3599     return p;
3600 }
3601
3602 static void
3603 pipe_mbxtofd_ast(pPipe p)
3604 {
3605     int iss = p->iosb.status;
3606     int done = p->info->done;
3607     int iss2;
3608     int eof = (iss == SS$_ENDOFFILE);
3609     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3610     int err = !(iss&1) && !eof;
3611 #if defined(PERL_IMPLICIT_CONTEXT)
3612     pTHX = p->thx;
3613 #endif
3614
3615     if (done && myeof) {               /* end piping */
3616         close(p->fd_out);
3617         sys$dassgn(p->chan_in);
3618         *p->pipe_done = TRUE;
3619         _ckvmssts_noperl(sys$setef(pipe_ef));
3620         return;
3621     }
3622
3623     if (!err && !eof) {             /* good data to send to file */
3624         p->buf[p->iosb.count] = '\n';
3625         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3626         if (iss2 < 0) {
3627             p->retry++;
3628             if (p->retry < MAX_RETRY) {
3629                 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3630                 return;
3631             }
3632         }
3633         p->retry = 0;
3634     } else if (err) {
3635         _ckvmssts_noperl(iss);
3636     }
3637
3638
3639     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3640           pipe_mbxtofd_ast, p,
3641           p->buf, p->bufsize, 0, 0, 0, 0);
3642     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3643     _ckvmssts_noperl(iss);
3644 }
3645
3646
3647 typedef struct _pipeloc     PLOC;
3648 typedef struct _pipeloc*   pPLOC;
3649
3650 struct _pipeloc {
3651     pPLOC   next;
3652     char    dir[NAM$C_MAXRSS+1];
3653 };
3654 static pPLOC  head_PLOC = 0;
3655
3656 void
3657 free_pipelocs(pTHX_ void *head)
3658 {
3659     pPLOC p, pnext;
3660     pPLOC *pHead = (pPLOC *)head;
3661
3662     p = *pHead;
3663     while (p) {
3664         pnext = p->next;
3665         PerlMem_free(p);
3666         p = pnext;
3667     }
3668     *pHead = 0;
3669 }
3670
3671 static void
3672 store_pipelocs(pTHX)
3673 {
3674     int    i;
3675     pPLOC  p;
3676     AV    *av = 0;
3677     SV    *dirsv;
3678     GV    *gv;
3679     char  *dir, *x;
3680     char  *unixdir;
3681     char  temp[NAM$C_MAXRSS+1];
3682     STRLEN n_a;
3683
3684     if (head_PLOC)
3685         free_pipelocs(aTHX_ &head_PLOC);
3686
3687 /*  the . directory from @INC comes last */
3688
3689     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3690     if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3691     p->next = head_PLOC;
3692     head_PLOC = p;
3693     strcpy(p->dir,"./");
3694
3695 /*  get the directory from $^X */
3696
3697     unixdir = PerlMem_malloc(VMS_MAXRSS);
3698     if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3699
3700 #ifdef PERL_IMPLICIT_CONTEXT
3701     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3702 #else
3703     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3704 #endif
3705         strcpy(temp, PL_origargv[0]);
3706         x = strrchr(temp,']');
3707         if (x == NULL) {
3708         x = strrchr(temp,'>');
3709           if (x == NULL) {
3710             /* It could be a UNIX path */
3711             x = strrchr(temp,'/');
3712           }
3713         }
3714         if (x)
3715           x[1] = '\0';
3716         else {
3717           /* Got a bare name, so use default directory */
3718           temp[0] = '.';
3719           temp[1] = '\0';
3720         }
3721
3722         if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3723             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3724             if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3725             p->next = head_PLOC;
3726             head_PLOC = p;
3727             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3728             p->dir[NAM$C_MAXRSS] = '\0';
3729         }
3730     }
3731
3732 /*  reverse order of @INC entries, skip "." since entered above */
3733
3734 #ifdef PERL_IMPLICIT_CONTEXT
3735     if (aTHX)
3736 #endif
3737     if (PL_incgv) av = GvAVn(PL_incgv);
3738
3739     for (i = 0; av && i <= AvFILL(av); i++) {
3740         dirsv = *av_fetch(av,i,TRUE);
3741
3742         if (SvROK(dirsv)) continue;
3743         dir = SvPVx(dirsv,n_a);
3744         if (strcmp(dir,".") == 0) continue;
3745         if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3746             continue;
3747
3748         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3749         p->next = head_PLOC;
3750         head_PLOC = p;
3751         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3752         p->dir[NAM$C_MAXRSS] = '\0';
3753     }
3754
3755 /* most likely spot (ARCHLIB) put first in the list */
3756
3757 #ifdef ARCHLIB_EXP
3758     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3759         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3760         if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3761         p->next = head_PLOC;
3762         head_PLOC = p;
3763         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3764         p->dir[NAM$C_MAXRSS] = '\0';
3765     }
3766 #endif
3767     PerlMem_free(unixdir);
3768 }
3769
3770 static I32
3771 Perl_cando_by_name_int
3772    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3773 #if !defined(PERL_IMPLICIT_CONTEXT)
3774 #define cando_by_name_int               Perl_cando_by_name_int
3775 #else
3776 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3777 #endif
3778
3779 static char *
3780 find_vmspipe(pTHX)
3781 {
3782     static int   vmspipe_file_status = 0;
3783     static char  vmspipe_file[NAM$C_MAXRSS+1];
3784
3785     /* already found? Check and use ... need read+execute permission */
3786
3787     if (vmspipe_file_status == 1) {
3788         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3789          && cando_by_name_int
3790            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3791             return vmspipe_file;
3792         }
3793         vmspipe_file_status = 0;
3794     }
3795
3796     /* scan through stored @INC, $^X */
3797
3798     if (vmspipe_file_status == 0) {
3799         char file[NAM$C_MAXRSS+1];
3800         pPLOC  p = head_PLOC;
3801
3802         while (p) {
3803             char * exp_res;
3804             int dirlen;
3805             strcpy(file, p->dir);
3806             dirlen = strlen(file);
3807             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3808             file[NAM$C_MAXRSS] = '\0';
3809             p = p->next;
3810
3811             exp_res = do_rmsexpand
3812                 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3813             if (!exp_res) continue;
3814
3815             if (cando_by_name_int
3816                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3817              && cando_by_name_int
3818                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3819                 vmspipe_file_status = 1;
3820                 return vmspipe_file;
3821             }
3822         }
3823         vmspipe_file_status = -1;   /* failed, use tempfiles */
3824     }
3825
3826     return 0;
3827 }
3828
3829 static FILE *
3830 vmspipe_tempfile(pTHX)
3831 {
3832     char file[NAM$C_MAXRSS+1];
3833     FILE *fp;
3834     static int index = 0;
3835     Stat_t s0, s1;
3836     int cmp_result;
3837
3838     /* create a tempfile */
3839
3840     /* we can't go from   W, shr=get to  R, shr=get without
3841        an intermediate vulnerable state, so don't bother trying...
3842
3843        and lib$spawn doesn't shr=put, so have to close the write
3844
3845        So... match up the creation date/time and the FID to
3846        make sure we're dealing with the same file
3847
3848     */
3849
3850     index++;
3851     if (!decc_filename_unix_only) {
3852       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3853       fp = fopen(file,"w");
3854       if (!fp) {
3855         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3856         fp = fopen(file,"w");
3857         if (!fp) {
3858             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3859             fp = fopen(file,"w");
3860         }
3861       }
3862      }
3863      else {
3864       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3865       fp = fopen(file,"w");
3866       if (!fp) {
3867         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3868         fp = fopen(file,"w");
3869         if (!fp) {
3870           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3871           fp = fopen(file,"w");
3872         }
3873       }
3874     }
3875     if (!fp) return 0;  /* we're hosed */
3876
3877     fprintf(fp,"$! 'f$verify(0)'\n");
3878     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3879     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3880     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3881     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3882     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3883     fprintf(fp,"$ perl_del    = \"delete\"\n");
3884     fprintf(fp,"$ pif         = \"if\"\n");
3885     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3886     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3887     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3888     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3889     fprintf(fp,"$!  --- build command line to get max possible length\n");
3890     fprintf(fp,"$c=perl_popen_cmd0\n");
3891     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3892     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3893     fprintf(fp,"$x=perl_popen_cmd3\n");
3894     fprintf(fp,"$c=c+x\n");
3895     fprintf(fp,"$ perl_on\n");
3896     fprintf(fp,"$ 'c'\n");
3897     fprintf(fp,"$ perl_status = $STATUS\n");
3898     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3899     fprintf(fp,"$ perl_exit 'perl_status'\n");
3900     fsync(fileno(fp));
3901
3902     fgetname(fp, file, 1);
3903     fstat(fileno(fp), (struct stat *)&s0);
3904     fclose(fp);
3905
3906     if (decc_filename_unix_only)
3907         do_tounixspec(file, file, 0, NULL);
3908     fp = fopen(file,"r","shr=get");
3909     if (!fp) return 0;
3910     fstat(fileno(fp), (struct stat *)&s1);
3911
3912     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3913     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3914         fclose(fp);
3915         return 0;
3916     }
3917
3918     return fp;
3919 }
3920
3921
3922 static int vms_is_syscommand_xterm(void)
3923 {
3924     const static struct dsc$descriptor_s syscommand_dsc =
3925       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3926
3927     const static struct dsc$descriptor_s decwdisplay_dsc =
3928       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3929
3930     struct item_list_3 items[2];
3931     unsigned short dvi_iosb[4];
3932     unsigned long devchar;
3933     unsigned long devclass;
3934     int status;
3935
3936     /* Very simple check to guess if sys$command is a decterm? */
3937     /* First see if the DECW$DISPLAY: device exists */
3938     items[0].len = 4;
3939     items[0].code = DVI$_DEVCHAR;
3940     items[0].bufadr = &devchar;
3941     items[0].retadr = NULL;
3942     items[1].len = 0;
3943     items[1].code = 0;
3944
3945     status = sys$getdviw
3946         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3947
3948     if ($VMS_STATUS_SUCCESS(status)) {
3949         status = dvi_iosb[0];
3950     }
3951
3952     if (!$VMS_STATUS_SUCCESS(status)) {
3953         SETERRNO(EVMSERR, status);
3954         return -1;
3955     }
3956
3957     /* If it does, then for now assume that we are on a workstation */
3958     /* Now verify that SYS$COMMAND is a terminal */
3959     /* for creating the debugger DECTerm */
3960
3961     items[0].len = 4;
3962     items[0].code = DVI$_DEVCLASS;
3963     items[0].bufadr = &devclass;
3964     items[0].retadr = NULL;
3965     items[1].len = 0;
3966     items[1].code = 0;
3967
3968     status = sys$getdviw
3969         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3970
3971     if ($VMS_STATUS_SUCCESS(status)) {
3972         status = dvi_iosb[0];
3973     }
3974
3975     if (!$VMS_STATUS_SUCCESS(status)) {
3976         SETERRNO(EVMSERR, status);
3977         return -1;
3978     }
3979     else {
3980         if (devclass == DC$_TERM) {
3981             return 0;
3982         }
3983     }
3984     return -1;
3985 }
3986
3987 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3988 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3989 {
3990     int status;
3991     int ret_stat;
3992     char * ret_char;
3993     char device_name[65];
3994     unsigned short device_name_len;
3995     struct dsc$descriptor_s customization_dsc;
3996     struct dsc$descriptor_s device_name_dsc;
3997     const char * cptr;
3998     char * tptr;
3999     char customization[200];
4000     char title[40];
4001     pInfo info = NULL;
4002     char mbx1[64];
4003     unsigned short p_chan;
4004     int n;
4005     unsigned short iosb[4];
4006     struct item_list_3 items[2];
4007     const char * cust_str =
4008         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
4009     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
4010                                           DSC$K_CLASS_S, mbx1};
4011
4012      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
4013     /*---------------------------------------*/
4014     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
4015
4016
4017     /* Make sure that this is from the Perl debugger */
4018     ret_char = strstr(cmd," xterm ");
4019     if (ret_char == NULL)
4020         return NULL;
4021     cptr = ret_char + 7;
4022     ret_char = strstr(cmd,"tty");
4023     if (ret_char == NULL)
4024         return NULL;
4025     ret_char = strstr(cmd,"sleep");
4026     if (ret_char == NULL)
4027         return NULL;
4028
4029     if (decw_term_port == 0) {
4030         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
4031         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
4032         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
4033
4034        status = lib$find_image_symbol
4035                                (&filename1_dsc,
4036                                 &decw_term_port_dsc,
4037                                 (void *)&decw_term_port,
4038                                 NULL,
4039                                 0);
4040
4041         /* Try again with the other image name */
4042         if (!$VMS_STATUS_SUCCESS(status)) {
4043
4044            status = lib$find_image_symbol
4045                                (&filename2_dsc,
4046                                 &decw_term_port_dsc,
4047                                 (void *)&decw_term_port,
4048                                 NULL,
4049                                 0);
4050
4051         }
4052
4053     }
4054
4055
4056     /* No decw$term_port, give it up */
4057     if (!$VMS_STATUS_SUCCESS(status))
4058         return NULL;
4059
4060     /* Are we on a workstation? */
4061     /* to do: capture the rows / columns and pass their properties */
4062     ret_stat = vms_is_syscommand_xterm();
4063     if (ret_stat < 0)
4064         return NULL;
4065
4066     /* Make the title: */
4067     ret_char = strstr(cptr,"-title");
4068     if (ret_char != NULL) {
4069         while ((*cptr != 0) && (*cptr != '\"')) {
4070             cptr++;
4071         }
4072         if (*cptr == '\"')
4073             cptr++;
4074         n = 0;
4075         while ((*cptr != 0) && (*cptr != '\"')) {
4076             title[n] = *cptr;
4077             n++;
4078             if (n == 39) {
4079                 title[39] == 0;
4080                 break;
4081             }
4082             cptr++;
4083         }
4084         title[n] = 0;
4085     }
4086     else {
4087             /* Default title */
4088             strcpy(title,"Perl Debug DECTerm");
4089     }
4090     sprintf(customization, cust_str, title);
4091
4092     customization_dsc.dsc$a_pointer = customization;
4093     customization_dsc.dsc$w_length = strlen(customization);
4094     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4095     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
4096
4097     device_name_dsc.dsc$a_pointer = device_name;
4098     device_name_dsc.dsc$w_length = sizeof device_name -1;
4099     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4100     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
4101
4102     device_name_len = 0;
4103
4104     /* Try to create the window */
4105      status = (*decw_term_port)
4106        (NULL,
4107         NULL,
4108         &customization_dsc,
4109         &device_name_dsc,
4110         &device_name_len,
4111         NULL,
4112         NULL,
4113         NULL);
4114     if (!$VMS_STATUS_SUCCESS(status)) {
4115         SETERRNO(EVMSERR, status);
4116         return NULL;
4117     }
4118
4119     device_name[device_name_len] = '\0';
4120
4121     /* Need to set this up to look like a pipe for cleanup */
4122     n = sizeof(Info);
4123     status = lib$get_vm(&n, &info);
4124     if (!$VMS_STATUS_SUCCESS(status)) {
4125         SETERRNO(ENOMEM, status);
4126         return NULL;
4127     }
4128
4129     info->mode = *mode;
4130     info->done = FALSE;
4131     info->completion = 0;
4132     info->closing    = FALSE;
4133     info->in         = 0;
4134     info->out        = 0;
4135     info->err        = 0;
4136     info->fp         = NULL;
4137     info->useFILE    = 0;
4138     info->waiting    = 0;
4139     info->in_done    = TRUE;
4140     info->out_done   = TRUE;
4141     info->err_done   = TRUE;
4142
4143     /* Assign a channel on this so that it will persist, and not login */
4144     /* We stash this channel in the info structure for reference. */
4145     /* The created xterm self destructs when the last channel is removed */
4146     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4147     /* So leave this assigned. */
4148     device_name_dsc.dsc$w_length = device_name_len;
4149     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4150     if (!$VMS_STATUS_SUCCESS(status)) {
4151         SETERRNO(EVMSERR, status);
4152         return NULL;
4153     }
4154     info->xchan_valid = 1;
4155
4156     /* Now create a mailbox to be read by the application */
4157
4158     create_mbx(&p_chan, &d_mbx1);
4159
4160     /* write the name of the created terminal to the mailbox */
4161     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4162             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4163
4164     if (!$VMS_STATUS_SUCCESS(status)) {
4165         SETERRNO(EVMSERR, status);
4166         return NULL;
4167     }
4168
4169     info->fp  = PerlIO_open(mbx1, mode);
4170
4171     /* Done with this channel */
4172     sys$dassgn(p_chan);
4173
4174     /* If any errors, then clean up */
4175     if (!info->fp) {
4176         n = sizeof(Info);
4177         _ckvmssts_noperl(lib$free_vm(&n, &info));
4178         return NULL;
4179         }
4180
4181     /* All done */
4182     return info->fp;
4183 }
4184
4185 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4186
4187 static PerlIO *
4188 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4189 {
4190     static int handler_set_up = FALSE;
4191     PerlIO * ret_fp;
4192     unsigned long int sts, flags = CLI$M_NOWAIT;
4193     /* The use of a GLOBAL table (as was done previously) rendered
4194      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4195      * environment.  Hence we've switched to LOCAL symbol table.
4196      */
4197     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4198     int j, wait = 0, n;
4199     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4200     char *in, *out, *err, mbx[512];
4201     FILE *tpipe = 0;
4202     char tfilebuf[NAM$C_MAXRSS+1];
4203     pInfo info = NULL;
4204     char cmd_sym_name[20];
4205     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4206                                       DSC$K_CLASS_S, symbol};
4207     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4208                                       DSC$K_CLASS_S, 0};
4209     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4210                                       DSC$K_CLASS_S, cmd_sym_name};
4211     struct dsc$descriptor_s *vmscmd;
4212     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4213     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4214     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4215
4216     /* Check here for Xterm create request.  This means looking for
4217      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4218      *  is possible to create an xterm.
4219      */
4220     if (*in_mode == 'r') {
4221         PerlIO * xterm_fd;
4222
4223         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4224         if (xterm_fd != NULL)
4225             return xterm_fd;
4226     }
4227
4228     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4229
4230     /* once-per-program initialization...
4231        note that the SETAST calls and the dual test of pipe_ef
4232        makes sure that only the FIRST thread through here does
4233        the initialization...all other threads wait until it's
4234        done.
4235
4236        Yeah, uglier than a pthread call, it's got all the stuff inline
4237        rather than in a separate routine.
4238     */
4239
4240     if (!pipe_ef) {
4241         _ckvmssts_noperl(sys$setast(0));
4242         if (!pipe_ef) {
4243             unsigned long int pidcode = JPI$_PID;
4244             $DESCRIPTOR(d_delay, RETRY_DELAY);
4245             _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4246             _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4247             _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4248         }
4249         if (!handler_set_up) {
4250           _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4251           handler_set_up = TRUE;
4252         }
4253         _ckvmssts_noperl(sys$setast(1));
4254     }
4255
4256     /* see if we can find a VMSPIPE.COM */
4257
4258     tfilebuf[0] = '@';
4259     vmspipe = find_vmspipe(aTHX);
4260     if (vmspipe) {
4261         strcpy(tfilebuf+1,vmspipe);
4262     } else {        /* uh, oh...we're in tempfile hell */
4263         tpipe = vmspipe_tempfile(aTHX);
4264         if (!tpipe) {       /* a fish popular in Boston */
4265             if (ckWARN(WARN_PIPE)) {
4266                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4267             }
4268         return NULL;
4269         }
4270         fgetname(tpipe,tfilebuf+1,1);
4271     }
4272     vmspipedsc.dsc$a_pointer = tfilebuf;
4273     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4274
4275     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4276     if (!(sts & 1)) {
4277       switch (sts) {
4278         case RMS$_FNF:  case RMS$_DNF:
4279           set_errno(ENOENT); break;
4280         case RMS$_DIR:
4281           set_errno(ENOTDIR); break;
4282         case RMS$_DEV:
4283           set_errno(ENODEV); break;
4284         case RMS$_PRV:
4285           set_errno(EACCES); break;
4286         case RMS$_SYN:
4287           set_errno(EINVAL); break;
4288         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4289           set_errno(E2BIG); break;
4290         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4291           _ckvmssts_noperl(sts); /* fall through */
4292         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4293           set_errno(EVMSERR);
4294       }
4295       set_vaxc_errno(sts);
4296       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4297         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4298       }
4299       *psts = sts;
4300       return NULL;
4301     }
4302     n = sizeof(Info);
4303     _ckvmssts_noperl(lib$get_vm(&n, &info));
4304
4305     strcpy(mode,in_mode);
4306     info->mode = *mode;
4307     info->done = FALSE;
4308     info->completion = 0;
4309     info->closing    = FALSE;
4310     info->in         = 0;
4311     info->out        = 0;
4312     info->err        = 0;
4313     info->fp         = NULL;
4314     info->useFILE    = 0;
4315     info->waiting    = 0;
4316     info->in_done    = TRUE;
4317     info->out_done   = TRUE;
4318     info->err_done   = TRUE;
4319     info->xchan      = 0;
4320     info->xchan_valid = 0;
4321
4322     in = PerlMem_malloc(VMS_MAXRSS);
4323     if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4324     out = PerlMem_malloc(VMS_MAXRSS);
4325     if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4326     err = PerlMem_malloc(VMS_MAXRSS);
4327     if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4328
4329     in[0] = out[0] = err[0] = '\0';
4330
4331     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4332         info->useFILE = 1;
4333         strcpy(p,p+1);
4334     }
4335     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4336         wait = 1;
4337         strcpy(p,p+1);
4338     }
4339
4340     if (*mode == 'r') {             /* piping from subroutine */
4341
4342         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4343         if (info->out) {
4344             info->out->pipe_done = &info->out_done;
4345             info->out_done = FALSE;
4346             info->out->info = info;
4347         }
4348         if (!info->useFILE) {
4349             info->fp  = PerlIO_open(mbx, mode);
4350         } else {
4351             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4352             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4353         }
4354
4355         if (!info->fp && info->out) {
4356             sys$cancel(info->out->chan_out);
4357
4358             while (!info->out_done) {
4359                 int done;
4360                 _ckvmssts_noperl(sys$setast(0));
4361                 done = info->out_done;
4362                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4363                 _ckvmssts_noperl(sys$setast(1));
4364                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4365             }
4366
4367             if (info->out->buf) {
4368                 n = info->out->bufsize * sizeof(char);
4369                 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4370             }
4371             n = sizeof(Pipe);
4372             _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4373             n = sizeof(Info);
4374             _ckvmssts_noperl(lib$free_vm(&n, &info));
4375             *psts = RMS$_FNF;
4376             return NULL;
4377         }
4378
4379         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4380         if (info->err) {
4381             info->err->pipe_done = &info->err_done;
4382             info->err_done = FALSE;
4383             info->err->info = info;
4384         }
4385
4386     } else if (*mode == 'w') {      /* piping to subroutine */
4387
4388         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4389         if (info->out) {
4390             info->out->pipe_done = &info->out_done;
4391             info->out_done = FALSE;
4392             info->out->info = info;
4393         }
4394
4395         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4396         if (info->err) {
4397             info->err->pipe_done = &info->err_done;
4398             info->err_done = FALSE;
4399             info->err->info = info;
4400         }
4401
4402         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4403         if (!info->useFILE) {
4404             info->fp  = PerlIO_open(mbx, mode);
4405         } else {
4406             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4407             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4408         }
4409
4410         if (info->in) {
4411             info->in->pipe_done = &info->in_done;
4412             info->in_done = FALSE;
4413             info->in->info = info;
4414         }
4415
4416         /* error cleanup */
4417         if (!info->fp && info->in) {
4418             info->done = TRUE;
4419             _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4420                                       0, 0, 0, 0, 0, 0, 0, 0));
4421
4422             while (!info->in_done) {
4423                 int done;
4424                 _ckvmssts_noperl(sys$setast(0));
4425                 done = info->in_done;
4426                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4427                 _ckvmssts_noperl(sys$setast(1));
4428                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4429             }
4430
4431             if (info->in->buf) {
4432                 n = info->in->bufsize * sizeof(char);
4433                 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4434             }
4435             n = sizeof(Pipe);
4436             _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4437             n = sizeof(Info);
4438             _ckvmssts_noperl(lib$free_vm(&n, &info));
4439             *psts = RMS$_FNF;
4440             return NULL;
4441         }
4442
4443
4444     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4445         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4446         if (info->out) {
4447             info->out->pipe_done = &info->out_done;
4448             info->out_done = FALSE;
4449             info->out->info = info;
4450         }
4451
4452         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4453         if (info->err) {
4454             info->err->pipe_done = &info->err_done;
4455             info->err_done = FALSE;
4456             info->err->info = info;
4457         }
4458     }
4459
4460     symbol[MAX_DCL_SYMBOL] = '\0';
4461
4462     strncpy(symbol, in, MAX_DCL_SYMBOL);
4463     d_symbol.dsc$w_length = strlen(symbol);
4464     _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4465
4466     strncpy(symbol, err, MAX_DCL_SYMBOL);
4467     d_symbol.dsc$w_length = strlen(symbol);
4468     _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4469
4470     strncpy(symbol, out, MAX_DCL_SYMBOL);
4471     d_symbol.dsc$w_length = strlen(symbol);
4472     _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4473
4474     /* Done with the names for the pipes */
4475     PerlMem_free(err);
4476     PerlMem_free(out);
4477     PerlMem_free(in);
4478
4479     p = vmscmd->dsc$a_pointer;
4480     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4481     if (*p == '$') p++;                         /* remove leading $ */
4482     while (*p == ' ' || *p == '\t') p++;
4483
4484     for (j = 0; j < 4; j++) {
4485         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4486         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4487
4488     strncpy(symbol, p, MAX_DCL_SYMBOL);
4489     d_symbol.dsc$w_length = strlen(symbol);
4490     _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4491
4492         if (strlen(p) > MAX_DCL_SYMBOL) {
4493             p += MAX_DCL_SYMBOL;
4494         } else {
4495             p += strlen(p);
4496         }
4497     }
4498     _ckvmssts_noperl(sys$setast(0));
4499     info->next=open_pipes;  /* prepend to list */
4500     open_pipes=info;
4501     _ckvmssts_noperl(sys$setast(1));
4502     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4503      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4504      * have SYS$COMMAND if we need it.
4505      */
4506     _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4507                       0, &info->pid, &info->completion,
4508                       0, popen_completion_ast,info,0,0,0));
4509
4510     /* if we were using a tempfile, close it now */
4511
4512     if (tpipe) fclose(tpipe);
4513
4514     /* once the subprocess is spawned, it has copied the symbols and
4515        we can get rid of ours */
4516
4517     for (j = 0; j < 4; j++) {
4518         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4519         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4520     _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4521     }
4522     _ckvmssts_noperl(lib$delete_symbol(&d_sym_in,  &table));
4523     _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4524     _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4525     vms_execfree(vmscmd);
4526
4527 #ifdef PERL_IMPLICIT_CONTEXT
4528     if (aTHX)
4529 #endif
4530     PL_forkprocess = info->pid;
4531
4532     ret_fp = info->fp;
4533     if (wait) {
4534          dSAVEDERRNO;
4535          int done = 0;
4536          while (!done) {
4537              _ckvmssts_noperl(sys$setast(0));
4538              done = info->done;
4539              if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4540              _ckvmssts_noperl(sys$setast(1));
4541              if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4542          }
4543         *psts = info->completion;
4544 /* Caller thinks it is open and tries to close it. */
4545 /* This causes some problems, as it changes the error status */
4546 /*        my_pclose(info->fp); */
4547
4548          /* If we did not have a file pointer open, then we have to */
4549          /* clean up here or eventually we will run out of something */
4550          SAVE_ERRNO;
4551          if (info->fp == NULL) {
4552              my_pclose_pinfo(aTHX_ info);
4553          }
4554          RESTORE_ERRNO;
4555
4556     } else {
4557         *psts = info->pid;
4558     }
4559     return ret_fp;
4560 }  /* end of safe_popen */
4561
4562
4563 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4564 PerlIO *
4565 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4566 {
4567     int sts;
4568     TAINT_ENV();
4569     TAINT_PROPER("popen");
4570     PERL_FLUSHALL_FOR_CHILD;
4571     return safe_popen(aTHX_ cmd,mode,&sts);
4572 }
4573
4574 /*}}}*/
4575
4576
4577 /* Routine to close and cleanup a pipe info structure */
4578
4579 static I32 my_pclose_pinfo(pTHX_ pInfo info) {
4580
4581     unsigned long int retsts;
4582     int done, iss, n;
4583     int status;
4584     pInfo next, last;
4585
4586     /* If we were writing to a subprocess, insure that someone reading from
4587      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4588      * produce an EOF record in the mailbox.
4589      *
4590      *  well, at least sometimes it *does*, so we have to watch out for
4591      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4592      */
4593      if (info->fp) {
4594         if (!info->useFILE
4595 #if defined(USE_ITHREADS)
4596           && my_perl
4597 #endif
4598           && PL_perlio_fd_refcnt)
4599             PerlIO_flush(info->fp);
4600         else
4601             fflush((FILE *)info->fp);
4602     }
4603
4604     _ckvmssts(sys$setast(0));
4605      info->closing = TRUE;
4606      done = info->done && info->in_done && info->out_done && info->err_done;
4607      /* hanging on write to Perl's input? cancel it */
4608      if (info->mode == 'r' && info->out && !info->out_done) {
4609         if (info->out->chan_out) {
4610             _ckvmssts(sys$cancel(info->out->chan_out));
4611             if (!info->out->chan_in) {   /* EOF generation, need AST */
4612                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4613             }
4614         }
4615      }
4616      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4617          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4618                            0, 0, 0, 0, 0, 0));
4619     _ckvmssts(sys$setast(1));
4620     if (info->fp) {
4621      if (!info->useFILE
4622 #if defined(USE_ITHREADS)
4623          && my_perl
4624 #endif
4625          && PL_perlio_fd_refcnt)
4626         PerlIO_close(info->fp);
4627      else
4628         fclose((FILE *)info->fp);
4629     }
4630      /*
4631         we have to wait until subprocess completes, but ALSO wait until all
4632         the i/o completes...otherwise we'll be freeing the "info" structure
4633         that the i/o ASTs could still be using...
4634      */
4635
4636      while (!done) {
4637          _ckvmssts(sys$setast(0));
4638          done = info->done && info->in_done && info->out_done && info->err_done;
4639          if (!done) _ckvmssts(sys$clref(pipe_ef));
4640          _ckvmssts(sys$setast(1));
4641          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4642      }
4643      retsts = info->completion;
4644
4645     /* remove from list of open pipes */
4646     _ckvmssts(sys$setast(0));
4647     last = NULL;
4648     for (next = open_pipes; next != NULL; last = next, next = next->next) {
4649         if (next == info)
4650             break;
4651     }
4652
4653     if (last)
4654         last->next = info->next;
4655     else
4656         open_pipes = info->next;
4657     _ckvmssts(sys$setast(1));
4658
4659     /* free buffers and structures */
4660
4661     if (info->in) {
4662         if (info->in->buf) {
4663             n = info->in->bufsize * sizeof(char);
4664             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4665         }
4666         n = sizeof(Pipe);
4667         _ckvmssts(lib$free_vm(&n, &info->in));
4668     }
4669     if (info->out) {
4670         if (info->out->buf) {
4671             n = info->out->bufsize * sizeof(char);
4672             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4673         }
4674         n = sizeof(Pipe);
4675         _ckvmssts(lib$free_vm(&n, &info->out));
4676     }
4677     if (info->err) {
4678         if (info->err->buf) {
4679             n = info->err->bufsize * sizeof(char);
4680             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4681         }
4682         n = sizeof(Pipe);
4683         _ckvmssts(lib$free_vm(&n, &info->err));
4684     }
4685     n = sizeof(Info);
4686     _ckvmssts(lib$free_vm(&n, &info));
4687
4688     return retsts;
4689 }
4690
4691
4692 /*{{{  I32 my_pclose(PerlIO *fp)*/
4693 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4694 {
4695     pInfo info, last = NULL;
4696     I32 ret_status;
4697
4698     /* Fixme - need ast and mutex protection here */
4699     for (info = open_pipes; info != NULL; last = info, info = info->next)
4700         if (info->fp == fp) break;
4701
4702     if (info == NULL) {  /* no such pipe open */
4703       set_errno(ECHILD); /* quoth POSIX */
4704       set_vaxc_errno(SS$_NONEXPR);
4705       return -1;
4706     }
4707
4708     ret_status = my_pclose_pinfo(aTHX_ info);
4709
4710     return ret_status;
4711
4712 }  /* end of my_pclose() */
4713
4714 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4715   /* Roll our own prototype because we want this regardless of whether
4716    * _VMS_WAIT is defined.
4717    */
4718   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4719 #endif
4720 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4721    created with popen(); otherwise partially emulate waitpid() unless
4722    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4723    Also check processes not considered by the CRTL waitpid().
4724  */
4725 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4726 Pid_t
4727 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4728 {
4729     pInfo info;
4730     int done;
4731     int sts;
4732     int j;
4733
4734     if (statusp) *statusp = 0;
4735
4736     for (info = open_pipes; info != NULL; info = info->next)
4737         if (info->pid == pid) break;
4738
4739     if (info != NULL) {  /* we know about this child */
4740       while (!info->done) {
4741           _ckvmssts(sys$setast(0));
4742           done = info->done;
4743           if (!done) _ckvmssts(sys$clref(pipe_ef));
4744           _ckvmssts(sys$setast(1));
4745           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4746       }
4747
4748       if (statusp) *statusp = info->completion;
4749       return pid;
4750     }
4751
4752     /* child that already terminated? */
4753
4754     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4755         if (closed_list[j].pid == pid) {
4756             if (statusp) *statusp = closed_list[j].completion;
4757             return pid;
4758         }
4759     }
4760
4761     /* fall through if this child is not one of our own pipe children */
4762
4763 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4764
4765       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4766        * in 7.2 did we get a version that fills in the VMS completion
4767        * status as Perl has always tried to do.
4768        */
4769
4770       sts = __vms_waitpid( pid, statusp, flags );
4771
4772       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4773          return sts;
4774
4775       /* If the real waitpid tells us the child does not exist, we
4776        * fall through here to implement waiting for a child that
4777        * was created by some means other than exec() (say, spawned
4778        * from DCL) or to wait for a process that is not a subprocess
4779        * of the current process.
4780        */
4781
4782 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4783
4784     {
4785       $DESCRIPTOR(intdsc,"0 00:00:01");
4786       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4787       unsigned long int pidcode = JPI$_PID, mypid;
4788       unsigned long int interval[2];
4789       unsigned int jpi_iosb[2];
4790       struct itmlst_3 jpilist[2] = {
4791           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4792           {                      0,         0,                 0, 0}
4793       };
4794
4795       if (pid <= 0) {
4796         /* Sorry folks, we don't presently implement rooting around for
4797            the first child we can find, and we definitely don't want to
4798            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4799          */
4800         set_errno(ENOTSUP);
4801         return -1;
4802       }
4803
4804       /* Get the owner of the child so I can warn if it's not mine. If the
4805        * process doesn't exist or I don't have the privs to look at it,
4806        * I can go home early.
4807        */
4808       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4809       if (sts & 1) sts = jpi_iosb[0];
4810       if (!(sts & 1)) {
4811         switch (sts) {
4812             case SS$_NONEXPR:
4813                 set_errno(ECHILD);
4814                 break;
4815             case SS$_NOPRIV:
4816                 set_errno(EACCES);
4817                 break;
4818             default:
4819                 _ckvmssts(sts);
4820         }
4821         set_vaxc_errno(sts);
4822         return -1;
4823       }
4824
4825       if (ckWARN(WARN_EXEC)) {
4826         /* remind folks they are asking for non-standard waitpid behavior */
4827         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4828         if (ownerpid != mypid)
4829           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4830                       "waitpid: process %x is not a child of process %x",
4831                       pid,mypid);
4832       }
4833
4834       /* simply check on it once a second until it's not there anymore. */
4835
4836       _ckvmssts(sys$bintim(&intdsc,interval));
4837       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4838             _ckvmssts(sys$schdwk(0,0,interval,0));
4839             _ckvmssts(sys$hiber());
4840       }
4841       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4842
4843       _ckvmssts(sts);
4844       return pid;
4845     }
4846 }  /* end of waitpid() */
4847 /*}}}*/
4848 /*}}}*/
4849 /*}}}*/
4850
4851 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4852 char *
4853 my_gconvert(double val, int ndig, int trail, char *buf)
4854 {
4855   static char __gcvtbuf[DBL_DIG+1];
4856   char *loc;
4857
4858   loc = buf ? buf : __gcvtbuf;
4859
4860 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4861   if (val < 1) {
4862     sprintf(loc,"%.*g",ndig,val);
4863     return loc;
4864   }
4865 #endif
4866
4867   if (val) {
4868     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4869     return gcvt(val,ndig,loc);
4870   }
4871   else {
4872     loc[0] = '0'; loc[1] = '\0';
4873     return loc;
4874   }
4875
4876 }
4877 /*}}}*/
4878
4879 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4880 static int rms_free_search_context(struct FAB * fab)
4881 {
4882 struct NAM * nam;
4883
4884     nam = fab->fab$l_nam;
4885     nam->nam$b_nop |= NAM$M_SYNCHK;
4886     nam->nam$l_rlf = NULL;
4887     fab->fab$b_dns = 0;
4888     return sys$parse(fab, NULL, NULL);
4889 }
4890
4891 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4892 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4893 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4894 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4895 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4896 #define rms_nam_esll(nam) nam.nam$b_esl
4897 #define rms_nam_esl(nam) nam.nam$b_esl
4898 #define rms_nam_name(nam) nam.nam$l_name
4899 #define rms_nam_namel(nam) nam.nam$l_name
4900 #define rms_nam_type(nam) nam.nam$l_type
4901 #define rms_nam_typel(nam) nam.nam$l_type
4902 #define rms_nam_ver(nam) nam.nam$l_ver
4903 #define rms_nam_verl(nam) nam.nam$l_ver
4904 #define rms_nam_rsll(nam) nam.nam$b_rsl
4905 #define rms_nam_rsl(nam) nam.nam$b_rsl
4906 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4907 #define rms_set_fna(fab, nam, name, size) \
4908         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4909 #define rms_get_fna(fab, nam) fab.fab$l_fna
4910 #define rms_set_dna(fab, nam, name, size) \
4911         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4912 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4913 #define rms_set_esa(nam, name, size) \
4914         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4915 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4916         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4917 #define rms_set_rsa(nam, name, size) \
4918         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4919 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4920         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4921 #define rms_nam_name_type_l_size(nam) \
4922         (nam.nam$b_name + nam.nam$b_type)
4923 #else
4924 static int rms_free_search_context(struct FAB * fab)
4925 {
4926 struct NAML * nam;
4927
4928     nam = fab->fab$l_naml;
4929     nam->naml$b_nop |= NAM$M_SYNCHK;
4930     nam->naml$l_rlf = NULL;
4931     nam->naml$l_long_defname_size = 0;
4932
4933     fab->fab$b_dns = 0;
4934     return sys$parse(fab, NULL, NULL);
4935 }
4936
4937 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4938 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4939 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4940 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4941 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4942 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4943 #define rms_nam_esl(nam) nam.naml$b_esl
4944 #define rms_nam_name(nam) nam.naml$l_name
4945 #define rms_nam_namel(nam) nam.naml$l_long_name
4946 #define rms_nam_type(nam) nam.naml$l_type
4947 #define rms_nam_typel(nam) nam.naml$l_long_type
4948 #define rms_nam_ver(nam) nam.naml$l_ver
4949 #define rms_nam_verl(nam) nam.naml$l_long_ver
4950 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4951 #define rms_nam_rsl(nam) nam.naml$b_rsl
4952 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4953 #define rms_set_fna(fab, nam, name, size) \
4954         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4955         nam.naml$l_long_filename_size = size; \
4956         nam.naml$l_long_filename = name;}
4957 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4958 #define rms_set_dna(fab, nam, name, size) \
4959         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4960         nam.naml$l_long_defname_size = size; \
4961         nam.naml$l_long_defname = name; }
4962 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4963 #define rms_set_esa(nam, name, size) \
4964         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4965         nam.naml$l_long_expand_alloc = size; \
4966         nam.naml$l_long_expand = name; }
4967 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4968         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4969         nam.naml$l_long_expand = l_name; \
4970         nam.naml$l_long_expand_alloc = l_size; }
4971 #define rms_set_rsa(nam, name, size) \
4972         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4973         nam.naml$l_long_result = name; \
4974         nam.naml$l_long_result_alloc = size; }
4975 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4976         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4977         nam.naml$l_long_result = l_name; \
4978         nam.naml$l_long_result_alloc = l_size; }
4979 #define rms_nam_name_type_l_size(nam) \
4980         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4981 #endif
4982
4983
4984 /* rms_erase
4985  * The CRTL for 8.3 and later can create symbolic links in any mode,
4986  * however in 8.3 the unlink/remove/delete routines will only properly handle
4987  * them if one of the PCP modes is active.
4988  */
4989 static int rms_erase(const char * vmsname)
4990 {
4991   int status;
4992   struct FAB myfab = cc$rms_fab;
4993   rms_setup_nam(mynam);
4994
4995   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4996   rms_bind_fab_nam(myfab, mynam);
4997
4998   /* Are we removing all versions? */
4999   if (vms_unlink_all_versions == 1) {
5000     const char * defspec = ";*";
5001     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
5002   }
5003
5004 #ifdef NAML$M_OPEN_SPECIAL
5005   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5006 #endif
5007
5008   status = sys$erase(&myfab, 0, 0);
5009
5010   return status;
5011 }
5012
5013
5014 static int
5015 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
5016                     const struct dsc$descriptor_s * vms_dst_dsc,
5017                     unsigned long flags)
5018 {
5019     /*  VMS and UNIX handle file permissions differently and the
5020      * the same ACL trick may be needed for renaming files,
5021      * especially if they are directories.
5022      */
5023
5024    /* todo: get kill_file and rename to share common code */
5025    /* I can not find online documentation for $change_acl
5026     * it appears to be replaced by $set_security some time ago */
5027
5028 const unsigned int access_mode = 0;
5029 $DESCRIPTOR(obj_file_dsc,"FILE");
5030 char *vmsname;
5031 char *rslt;
5032 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
5033 int aclsts, fndsts, rnsts = -1;
5034 unsigned int ctx = 0;
5035 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5036 struct dsc$descriptor_s * clean_dsc;
5037
5038 struct myacedef {
5039     unsigned char myace$b_length;
5040     unsigned char myace$b_type;
5041     unsigned short int myace$w_flags;
5042     unsigned long int myace$l_access;
5043     unsigned long int myace$l_ident;
5044 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
5045              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
5046              0},
5047              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
5048
5049 struct item_list_3
5050         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
5051                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
5052                       {0,0,0,0}},
5053         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
5054         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
5055                      {0,0,0,0}};
5056
5057
5058     /* Expand the input spec using RMS, since we do not want to put
5059      * ACLs on the target of a symbolic link */
5060     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
5061     if (vmsname == NULL)
5062         return SS$_INSFMEM;
5063
5064     rslt = do_rmsexpand(vms_src_dsc->dsc$a_pointer,
5065                         vmsname,
5066                         0,
5067                         NULL,
5068                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
5069                         NULL,
5070                         NULL);
5071     if (rslt == NULL) {
5072         PerlMem_free(vmsname);
5073         return SS$_INSFMEM;
5074     }
5075
5076     /* So we get our own UIC to use as a rights identifier,
5077      * and the insert an ACE at the head of the ACL which allows us
5078      * to delete the file.
5079      */
5080     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
5081
5082     fildsc.dsc$w_length = strlen(vmsname);
5083     fildsc.dsc$a_pointer = vmsname;
5084     ctx = 0;
5085     newace.myace$l_ident = oldace.myace$l_ident;
5086     rnsts = SS$_ABORT;
5087
5088     /* Grab any existing ACEs with this identifier in case we fail */
5089     clean_dsc = &fildsc;
5090     aclsts = fndsts = sys$get_security(&obj_file_dsc,
5091                                &fildsc,
5092                                NULL,
5093                                OSS$M_WLOCK,
5094                                findlst,
5095                                &ctx,
5096                                &access_mode);
5097
5098     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
5099         /* Add the new ACE . . . */
5100
5101         /* if the sys$get_security succeeded, then ctx is valid, and the
5102          * object/file descriptors will be ignored.  But otherwise they
5103          * are needed
5104          */
5105         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
5106                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
5107         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5108             set_errno(EVMSERR);
5109             set_vaxc_errno(aclsts);
5110             PerlMem_free(vmsname);
5111             return aclsts;
5112         }
5113
5114         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5115                                 NULL, NULL,
5116                                 &flags,
5117                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5118
5119         if ($VMS_STATUS_SUCCESS(rnsts)) {
5120             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5121         }
5122
5123         /* Put things back the way they were. */
5124         ctx = 0;
5125         aclsts = sys$get_security(&obj_file_dsc,
5126                                   clean_dsc,
5127                                   NULL,
5128                                   OSS$M_WLOCK,
5129                                   findlst,
5130                                   &ctx,
5131                                   &access_mode);
5132
5133         if ($VMS_STATUS_SUCCESS(aclsts)) {
5134         int sec_flags;
5135
5136             sec_flags = 0;
5137             if (!$VMS_STATUS_SUCCESS(fndsts))
5138                 sec_flags = OSS$M_RELCTX;
5139
5140             /* Get rid of the new ACE */
5141             aclsts = sys$set_security(NULL, NULL, NULL,
5142                                   sec_flags, dellst, &ctx, &access_mode);
5143
5144             /* If there was an old ACE, put it back */
5145             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5146                 addlst[0].bufadr = &oldace;
5147                 aclsts = sys$set_security(NULL, NULL, NULL,
5148                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
5149                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5150                     set_errno(EVMSERR);
5151                     set_vaxc_errno(aclsts);
5152                     rnsts = aclsts;
5153                 }
5154             } else {
5155             int aclsts2;
5156
5157                 /* Try to clear the lock on the ACL list */
5158                 aclsts2 = sys$set_security(NULL, NULL, NULL,
5159                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
5160
5161                 /* Rename errors are most important */
5162                 if (!$VMS_STATUS_SUCCESS(rnsts))
5163                     aclsts = rnsts;
5164                 set_errno(EVMSERR);
5165                 set_vaxc_errno(aclsts);
5166                 rnsts = aclsts;
5167             }
5168         }
5169         else {
5170             if (aclsts != SS$_ACLEMPTY)
5171                 rnsts = aclsts;
5172         }
5173     }
5174     else
5175         rnsts = fndsts;
5176
5177     PerlMem_free(vmsname);
5178     return rnsts;
5179 }
5180
5181
5182 /*{{{int rename(const char *, const char * */
5183 /* Not exactly what X/Open says to do, but doing it absolutely right
5184  * and efficiently would require a lot more work.  This should be close
5185  * enough to pass all but the most strict X/Open compliance test.
5186  */
5187 int
5188 Perl_rename(pTHX_ const char *src, const char * dst)
5189 {
5190 int retval;
5191 int pre_delete = 0;
5192 int src_sts;
5193 int dst_sts;
5194 Stat_t src_st;
5195 Stat_t dst_st;
5196
5197     /* Validate the source file */
5198     src_sts = flex_lstat(src, &src_st);
5199     if (src_sts != 0) {
5200
5201         /* No source file or other problem */
5202         return src_sts;
5203     }
5204
5205     dst_sts = flex_lstat(dst, &dst_st);
5206     if (dst_sts == 0) {
5207
5208         if (dst_st.st_dev != src_st.st_dev) {
5209             /* Must be on the same device */
5210             errno = EXDEV;
5211             return -1;
5212         }
5213
5214         /* VMS_INO_T_COMPARE is true if the inodes are different
5215          * to match the output of memcmp
5216          */
5217
5218         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5219             /* That was easy, the files are the same! */
5220             return 0;
5221         }
5222
5223         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5224             /* If source is a directory, so must be dest */
5225                 errno = EISDIR;
5226                 return -1;
5227         }
5228
5229     }
5230
5231
5232     if ((dst_sts == 0) &&
5233         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5234
5235         /* We have issues here if vms_unlink_all_versions is set
5236          * If the destination exists, and is not a directory, then
5237          * we must delete in advance.
5238          *
5239          * If the src is a directory, then we must always pre-delete
5240          * the destination.
5241          *
5242          * If we successfully delete the dst in advance, and the rename fails
5243          * X/Open requires that errno be EIO.
5244          *
5245          */
5246
5247         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5248             int d_sts;
5249             d_sts = mp_do_kill_file(aTHX_ dst, S_ISDIR(dst_st.st_mode));
5250             if (d_sts != 0)
5251                 return d_sts;
5252
5253             /* We killed the destination, so only errno now is EIO */
5254             pre_delete = 1;
5255         }
5256     }
5257
5258     /* Originally the idea was to call the CRTL rename() and only
5259      * try the lib$rename_file if it failed.
5260      * It turns out that there are too many variants in what the
5261      * the CRTL rename might do, so only use lib$rename_file
5262      */
5263     retval = -1;
5264
5265     {
5266         /* Is the source and dest both in VMS format */
5267         /* if the source is a directory, then need to fileify */
5268         /*  and dest must be a directory or non-existant. */
5269
5270         char * vms_src;
5271         char * vms_dst;
5272         int sts;
5273         char * ret_str;
5274         unsigned long flags;
5275         struct dsc$descriptor_s old_file_dsc;
5276         struct dsc$descriptor_s new_file_dsc;
5277
5278         /* We need to modify the src and dst depending
5279          * on if one or more of them are directories.
5280          */
5281
5282         vms_src = PerlMem_malloc(VMS_MAXRSS);
5283         if (vms_src == NULL)
5284             _ckvmssts_noperl(SS$_INSFMEM);
5285
5286         /* Source is always a VMS format file */
5287         ret_str = do_tovmsspec(src, vms_src, 0, NULL);
5288         if (ret_str == NULL) {
5289             PerlMem_free(vms_src);
5290             errno = EIO;
5291             return -1;
5292         }
5293
5294         vms_dst = PerlMem_malloc(VMS_MAXRSS);
5295         if (vms_dst == NULL)
5296             _ckvmssts_noperl(SS$_INSFMEM);
5297
5298         if (S_ISDIR(src_st.st_mode)) {
5299         char * ret_str;
5300         char * vms_dir_file;
5301
5302             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5303             if (vms_dir_file == NULL)
5304                 _ckvmssts_noperl(SS$_INSFMEM);
5305
5306             /* The source must be a file specification */
5307             ret_str = do_fileify_dirspec(vms_src, vms_dir_file, 0, NULL);
5308             if (ret_str == NULL) {
5309                 PerlMem_free(vms_src);
5310                 PerlMem_free(vms_dst);
5311                 PerlMem_free(vms_dir_file);
5312                 errno = EIO;
5313                 return -1;
5314             }
5315             PerlMem_free(vms_src);
5316             vms_src = vms_dir_file;
5317
5318             /* If the dest is a directory, we must remove it
5319             if (dst_sts == 0) {
5320                 int d_sts;
5321                 d_sts = mp_do_kill_file(aTHX_ dst, 1);
5322                 if (d_sts != 0) {
5323                     PerlMem_free(vms_src);
5324                     PerlMem_free(vms_dst);
5325                     errno = EIO;
5326                     return sts;
5327                 }
5328
5329                 pre_delete = 1;
5330             }
5331
5332            /* The dest must be a VMS file specification */
5333            ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5334            if (ret_str == NULL) {
5335                 PerlMem_free(vms_src);
5336                 PerlMem_free(vms_dst);
5337                 errno = EIO;
5338                 return -1;
5339            }
5340
5341             /* The source must be a file specification */
5342             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5343             if (vms_dir_file == NULL)
5344                 _ckvmssts_noperl(SS$_INSFMEM);
5345
5346             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5347             if (ret_str == NULL) {
5348                 PerlMem_free(vms_src);
5349                 PerlMem_free(vms_dst);
5350                 PerlMem_free(vms_dir_file);
5351                 errno = EIO;
5352                 return -1;
5353             }
5354             PerlMem_free(vms_dst);
5355             vms_dst = vms_dir_file;
5356
5357         } else {
5358             /* File to file or file to new dir */
5359
5360             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5361                 /* VMS pathify a dir target */
5362                 ret_str = do_tovmspath(dst, vms_dst, 0, NULL);
5363                 if (ret_str == NULL) {
5364                     PerlMem_free(vms_src);
5365                     PerlMem_free(vms_dst);
5366                     errno = EIO;
5367                     return -1;
5368                 }
5369             } else {
5370
5371                 /* fileify a target VMS file specification */
5372                 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5373                 if (ret_str == NULL) {
5374                     PerlMem_free(vms_src);
5375                     PerlMem_free(vms_dst);
5376                     errno = EIO;
5377                     return -1;
5378                 }
5379             }
5380         }
5381
5382         old_file_dsc.dsc$a_pointer = vms_src;
5383         old_file_dsc.dsc$w_length = strlen(vms_src);
5384         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5385         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5386
5387         new_file_dsc.dsc$a_pointer = vms_dst;
5388         new_file_dsc.dsc$w_length = strlen(vms_dst);
5389         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5390         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5391
5392         flags = 0;
5393 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5394         flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5395 #endif
5396
5397         sts = lib$rename_file(&old_file_dsc,
5398                               &new_file_dsc,
5399                               NULL, NULL,
5400                               &flags,
5401                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5402         if (!$VMS_STATUS_SUCCESS(sts)) {
5403
5404            /* We could have failed because VMS style permissions do not
5405             * permit renames that UNIX will allow.  Just like the hack
5406             * in for kill_file.
5407             */
5408            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5409         }
5410
5411         PerlMem_free(vms_src);
5412         PerlMem_free(vms_dst);
5413         if (!$VMS_STATUS_SUCCESS(sts)) {
5414             errno = EIO;
5415             return -1;
5416         }
5417         retval = 0;
5418     }
5419
5420     if (vms_unlink_all_versions) {
5421         /* Now get rid of any previous versions of the source file that
5422          * might still exist
5423          */
5424         int save_errno;
5425         save_errno = errno;
5426         src_sts = mp_do_kill_file(aTHX_ src, S_ISDIR(src_st.st_mode));
5427         errno = save_errno;
5428     }
5429
5430     /* We deleted the destination, so must force the error to be EIO */
5431     if ((retval != 0) && (pre_delete != 0))
5432         errno = EIO;
5433
5434     return retval;
5435 }
5436 /*}}}*/
5437
5438
5439 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5440 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5441  * to expand file specification.  Allows for a single default file
5442  * specification and a simple mask of options.  If outbuf is non-NULL,
5443  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5444  * the resultant file specification is placed.  If outbuf is NULL, the
5445  * resultant file specification is placed into a static buffer.
5446  * The third argument, if non-NULL, is taken to be a default file
5447  * specification string.  The fourth argument is unused at present.
5448  * rmesexpand() returns the address of the resultant string if
5449  * successful, and NULL on error.
5450  *
5451  * New functionality for previously unused opts value:
5452  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5453  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5454  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5455  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5456  */
5457 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5458
5459 static char *
5460 mp_do_rmsexpand
5461    (pTHX_ const char *filespec,
5462     char *outbuf,
5463     int ts,
5464     const char *defspec,
5465     unsigned opts,
5466     int * fs_utf8,
5467     int * dfs_utf8)
5468 {
5469   static char __rmsexpand_retbuf[VMS_MAXRSS];
5470   char * vmsfspec, *tmpfspec;
5471   char * esa, *cp, *out = NULL;
5472   char * tbuf;
5473   char * esal = NULL;
5474   char * outbufl;
5475   struct FAB myfab = cc$rms_fab;
5476   rms_setup_nam(mynam);
5477   STRLEN speclen;
5478   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5479   int sts;
5480
5481   /* temp hack until UTF8 is actually implemented */
5482   if (fs_utf8 != NULL)
5483     *fs_utf8 = 0;
5484
5485   if (!filespec || !*filespec) {
5486     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5487     return NULL;
5488   }
5489   if (!outbuf) {
5490     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
5491     else    outbuf = __rmsexpand_retbuf;
5492   }
5493
5494   vmsfspec = NULL;
5495   tmpfspec = NULL;
5496   outbufl = NULL;
5497
5498   isunix = 0;
5499   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5500     isunix = is_unix_filespec(filespec);
5501     if (isunix) {
5502       vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5503       if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5504       if (int_tovmsspec(filespec, vmsfspec, 0, fs_utf8) == NULL) {
5505         PerlMem_free(vmsfspec);
5506         if (out)
5507            Safefree(out);
5508         return NULL;
5509       }
5510       filespec = 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 !defined(__VAX) && defined(NAML$C_MAXRSS)
5516       if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5517         opts |= PERL_RMSEXPAND_M_LONG;
5518       else
5519 #endif
5520         isunix = 0;
5521       }
5522     }
5523
5524   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
5525   rms_bind_fab_nam(myfab, mynam);
5526
5527   if (defspec && *defspec) {
5528     int t_isunix;
5529     t_isunix = is_unix_filespec(defspec);
5530     if (t_isunix) {
5531       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5532       if (tmpfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5533       if (int_tovmsspec(defspec, tmpfspec, 0, dfs_utf8) == NULL) {
5534         PerlMem_free(tmpfspec);
5535         if (vmsfspec != NULL)
5536             PerlMem_free(vmsfspec);
5537         if (out)
5538            Safefree(out);
5539         return NULL;
5540       }
5541       defspec = tmpfspec;
5542     }
5543     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
5544   }
5545
5546   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5547   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5548 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5549   esal = PerlMem_malloc(VMS_MAXRSS);
5550   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5551 #endif
5552   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5553
5554   /* If a NAML block is used RMS always writes to the long and short
5555    * addresses unless you suppress the short name.
5556    */
5557 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5558   outbufl = PerlMem_malloc(VMS_MAXRSS);
5559   if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5560 #endif
5561    rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5562
5563 #ifdef NAM$M_NO_SHORT_UPCASE
5564   if (decc_efs_case_preserve)
5565     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5566 #endif
5567
5568    /* We may not want to follow symbolic links */
5569 #ifdef NAML$M_OPEN_SPECIAL
5570   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5571     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5572 #endif
5573
5574   /* First attempt to parse as an existing file */
5575   retsts = sys$parse(&myfab,0,0);
5576   if (!(retsts & STS$K_SUCCESS)) {
5577
5578     /* Could not find the file, try as syntax only if error is not fatal */
5579     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5580     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
5581       retsts = sys$parse(&myfab,0,0);
5582       if (retsts & STS$K_SUCCESS) goto expanded;
5583     }
5584
5585      /* Still could not parse the file specification */
5586     /*----------------------------------------------*/
5587     sts = rms_free_search_context(&myfab); /* Free search context */
5588     if (out) Safefree(out);
5589     if (tmpfspec != NULL)
5590         PerlMem_free(tmpfspec);
5591     if (vmsfspec != NULL)
5592         PerlMem_free(vmsfspec);
5593     if (outbufl != NULL)
5594         PerlMem_free(outbufl);
5595     PerlMem_free(esa);
5596     if (esal != NULL)
5597         PerlMem_free(esal);
5598     set_vaxc_errno(retsts);
5599     if      (retsts == RMS$_PRV) set_errno(EACCES);
5600     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5601     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5602     else                         set_errno(EVMSERR);
5603     return NULL;
5604   }
5605   retsts = sys$search(&myfab,0,0);
5606   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5607     sts = rms_free_search_context(&myfab); /* Free search context */
5608     if (out) Safefree(out);
5609     if (tmpfspec != NULL)
5610         PerlMem_free(tmpfspec);
5611     if (vmsfspec != NULL)
5612         PerlMem_free(vmsfspec);
5613     if (outbufl != NULL)
5614         PerlMem_free(outbufl);
5615     PerlMem_free(esa);
5616     if (esal != NULL)
5617         PerlMem_free(esal);
5618     set_vaxc_errno(retsts);
5619     if      (retsts == RMS$_PRV) set_errno(EACCES);
5620     else                         set_errno(EVMSERR);
5621     return NULL;
5622   }
5623
5624   /* If the input filespec contained any lowercase characters,
5625    * downcase the result for compatibility with Unix-minded code. */
5626   expanded:
5627   if (!decc_efs_case_preserve) {
5628     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5629       if (islower(*tbuf)) { haslower = 1; break; }
5630   }
5631
5632    /* Is a long or a short name expected */
5633   /*------------------------------------*/
5634   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5635     if (rms_nam_rsll(mynam)) {
5636         tbuf = outbufl;
5637         speclen = rms_nam_rsll(mynam);
5638     }
5639     else {
5640         tbuf = esal; /* Not esa */
5641         speclen = rms_nam_esll(mynam);
5642     }
5643   }
5644   else {
5645     if (rms_nam_rsl(mynam)) {
5646         tbuf = outbuf;
5647         speclen = rms_nam_rsl(mynam);
5648     }
5649     else {
5650         tbuf = esa; /* Not esal */
5651         speclen = rms_nam_esl(mynam);
5652     }
5653   }
5654   tbuf[speclen] = '\0';
5655
5656   /* Trim off null fields added by $PARSE
5657    * If type > 1 char, must have been specified in original or default spec
5658    * (not true for version; $SEARCH may have added version of existing file).
5659    */
5660   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5661   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5662     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5663              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5664   }
5665   else {
5666     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5667              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5668   }
5669   if (trimver || trimtype) {
5670     if (defspec && *defspec) {
5671       char *defesal = NULL;
5672       char *defesa = NULL;
5673       defesa = PerlMem_malloc(VMS_MAXRSS + 1);
5674       if (defesa != NULL) {
5675 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5676         defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5677         if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5678 #endif
5679         struct FAB deffab = cc$rms_fab;
5680         rms_setup_nam(defnam);
5681
5682         rms_bind_fab_nam(deffab, defnam);
5683
5684         /* Cast ok */
5685         rms_set_fna
5686             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5687
5688         /* RMS needs the esa/esal as a work area if wildcards are involved */
5689         rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5690
5691         rms_clear_nam_nop(defnam);
5692         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5693 #ifdef NAM$M_NO_SHORT_UPCASE
5694         if (decc_efs_case_preserve)
5695           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5696 #endif
5697 #ifdef NAML$M_OPEN_SPECIAL
5698         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5699           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5700 #endif
5701         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5702           if (trimver) {
5703              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5704           }
5705           if (trimtype) {
5706             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5707           }
5708         }
5709         if (defesal != NULL)
5710             PerlMem_free(defesal);
5711         PerlMem_free(defesa);
5712       }
5713     }
5714     if (trimver) {
5715       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5716         if (*(rms_nam_verl(mynam)) != '\"')
5717           speclen = rms_nam_verl(mynam) - tbuf;
5718       }
5719       else {
5720         if (*(rms_nam_ver(mynam)) != '\"')
5721           speclen = rms_nam_ver(mynam) - tbuf;
5722       }
5723     }
5724     if (trimtype) {
5725       /* If we didn't already trim version, copy down */
5726       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5727         if (speclen > rms_nam_verl(mynam) - tbuf)
5728           memmove
5729            (rms_nam_typel(mynam),
5730             rms_nam_verl(mynam),
5731             speclen - (rms_nam_verl(mynam) - tbuf));
5732           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5733       }
5734       else {
5735         if (speclen > rms_nam_ver(mynam) - tbuf)
5736           memmove
5737            (rms_nam_type(mynam),
5738             rms_nam_ver(mynam),
5739             speclen - (rms_nam_ver(mynam) - tbuf));
5740           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5741       }
5742     }
5743   }
5744
5745    /* Done with these copies of the input files */
5746   /*-------------------------------------------*/
5747   if (vmsfspec != NULL)
5748         PerlMem_free(vmsfspec);
5749   if (tmpfspec != NULL)
5750         PerlMem_free(tmpfspec);
5751
5752   /* If we just had a directory spec on input, $PARSE "helpfully"
5753    * adds an empty name and type for us */
5754 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5755   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5756     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5757         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5758         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5759       speclen = rms_nam_namel(mynam) - tbuf;
5760   }
5761   else
5762 #endif
5763   {
5764     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5765         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5766         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5767       speclen = rms_nam_name(mynam) - tbuf;
5768   }
5769
5770   /* Posix format specifications must have matching quotes */
5771   if (speclen < (VMS_MAXRSS - 1)) {
5772     if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
5773       if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
5774         tbuf[speclen] = '\"';
5775         speclen++;
5776       }
5777     }
5778   }
5779   tbuf[speclen] = '\0';
5780   if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
5781
5782   /* Have we been working with an expanded, but not resultant, spec? */
5783   /* Also, convert back to Unix syntax if necessary. */
5784   {
5785   int rsl;
5786
5787 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5788     if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5789       rsl = rms_nam_rsll(mynam);
5790     } else
5791 #endif
5792     {
5793       rsl = rms_nam_rsl(mynam);
5794     }
5795     if (!rsl) {
5796       if (isunix) {
5797         if (do_tounixspec(tbuf, outbuf ,0 , fs_utf8) == NULL) {
5798           if (out) Safefree(out);
5799           if (esal != NULL)
5800             PerlMem_free(esal);
5801           PerlMem_free(esa);
5802           if (outbufl != NULL)
5803             PerlMem_free(outbufl);
5804           return NULL;
5805         }
5806       }
5807       else strcpy(outbuf, tbuf);
5808     }
5809     else if (isunix) {
5810       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5811       if (tmpfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5812       if (do_tounixspec(tbuf,tmpfspec,0,fs_utf8) == NULL) {
5813         if (out) Safefree(out);
5814         PerlMem_free(esa);
5815         if (esal != NULL)
5816             PerlMem_free(esal);
5817         PerlMem_free(tmpfspec);
5818         if (outbufl != NULL)
5819             PerlMem_free(outbufl);
5820         return NULL;
5821       }
5822       strcpy(outbuf,tmpfspec);
5823       PerlMem_free(tmpfspec);
5824     }
5825   }
5826   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5827   sts = rms_free_search_context(&myfab); /* Free search context */
5828   PerlMem_free(esa);
5829   if (esal != NULL)
5830      PerlMem_free(esal);
5831   if (outbufl != NULL)
5832      PerlMem_free(outbufl);
5833   return outbuf;
5834 }
5835 /*}}}*/
5836 /* External entry points */
5837 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5838 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5839 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5840 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5841 char *Perl_rmsexpand_utf8
5842   (pTHX_ const char *spec, char *buf, const char *def,
5843    unsigned opt, int * fs_utf8, int * dfs_utf8)
5844 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5845 char *Perl_rmsexpand_utf8_ts
5846   (pTHX_ const char *spec, char *buf, const char *def,
5847    unsigned opt, int * fs_utf8, int * dfs_utf8)
5848 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5849
5850
5851 /*
5852 ** The following routines are provided to make life easier when
5853 ** converting among VMS-style and Unix-style directory specifications.
5854 ** All will take input specifications in either VMS or Unix syntax. On
5855 ** failure, all return NULL.  If successful, the routines listed below
5856 ** return a pointer to a buffer containing the appropriately
5857 ** reformatted spec (and, therefore, subsequent calls to that routine
5858 ** will clobber the result), while the routines of the same names with
5859 ** a _ts suffix appended will return a pointer to a mallocd string
5860 ** containing the appropriately reformatted spec.
5861 ** In all cases, only explicit syntax is altered; no check is made that
5862 ** the resulting string is valid or that the directory in question
5863 ** actually exists.
5864 **
5865 **   fileify_dirspec() - convert a directory spec into the name of the
5866 **     directory file (i.e. what you can stat() to see if it's a dir).
5867 **     The style (VMS or Unix) of the result is the same as the style
5868 **     of the parameter passed in.
5869 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5870 **     what you prepend to a filename to indicate what directory it's in).
5871 **     The style (VMS or Unix) of the result is the same as the style
5872 **     of the parameter passed in.
5873 **   tounixpath() - convert a directory spec into a Unix-style path.
5874 **   tovmspath() - convert a directory spec into a VMS-style path.
5875 **   tounixspec() - convert any file spec into a Unix-style file spec.
5876 **   tovmsspec() - convert any file spec into a VMS-style spec.
5877 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5878 **
5879 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5880 ** Permission is given to distribute this code as part of the Perl
5881 ** standard distribution under the terms of the GNU General Public
5882 ** License or the Perl Artistic License.  Copies of each may be
5883 ** found in the Perl standard distribution.
5884  */
5885
5886 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5887 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
5888 {
5889     static char __fileify_retbuf[VMS_MAXRSS];
5890     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5891     char *retspec, *cp1, *cp2, *lastdir;
5892     char *trndir, *vmsdir;
5893     unsigned short int trnlnm_iter_count;
5894     int is_vms = 0;
5895     int is_unix = 0;
5896     int sts;
5897     if (utf8_fl != NULL)
5898         *utf8_fl = 0;
5899
5900     if (!dir || !*dir) {
5901       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5902     }
5903     dirlen = strlen(dir);
5904     while (dirlen && dir[dirlen-1] == '/') --dirlen;
5905     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5906       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5907         dir = "/sys$disk";
5908         dirlen = 9;
5909       }
5910       else
5911         dirlen = 1;
5912     }
5913     if (dirlen > (VMS_MAXRSS - 1)) {
5914       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5915       return NULL;
5916     }
5917     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
5918     if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5919     if (!strpbrk(dir+1,"/]>:")  &&
5920         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5921       strcpy(trndir,*dir == '/' ? dir + 1: dir);
5922       trnlnm_iter_count = 0;
5923       while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
5924         trnlnm_iter_count++;
5925         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5926       }
5927       dirlen = strlen(trndir);
5928     }
5929     else {
5930       strncpy(trndir,dir,dirlen);
5931       trndir[dirlen] = '\0';
5932     }
5933
5934     /* At this point we are done with *dir and use *trndir which is a
5935      * copy that can be modified.  *dir must not be modified.
5936      */
5937
5938     /* If we were handed a rooted logical name or spec, treat it like a
5939      * simple directory, so that
5940      *    $ Define myroot dev:[dir.]
5941      *    ... do_fileify_dirspec("myroot",buf,1) ...
5942      * does something useful.
5943      */
5944     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5945       trndir[--dirlen] = '\0';
5946       trndir[dirlen-1] = ']';
5947     }
5948     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5949       trndir[--dirlen] = '\0';
5950       trndir[dirlen-1] = '>';
5951     }
5952
5953     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5954       /* If we've got an explicit filename, we can just shuffle the string. */
5955       if (*(cp1+1)) hasfilename = 1;
5956       /* Similarly, we can just back up a level if we've got multiple levels
5957          of explicit directories in a VMS spec which ends with directories. */
5958       else {
5959         for (cp2 = cp1; cp2 > trndir; cp2--) {
5960           if (*cp2 == '.') {
5961             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5962 /* fix-me, can not scan EFS file specs backward like this */
5963               *cp2 = *cp1; *cp1 = '\0';
5964               hasfilename = 1;
5965               break;
5966             }
5967           }
5968           if (*cp2 == '[' || *cp2 == '<') break;
5969         }
5970       }
5971     }
5972
5973     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
5974     if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5975     cp1 = strpbrk(trndir,"]:>");
5976     if (hasfilename || !cp1) { /* Unix-style path or filename */
5977       if (trndir[0] == '.') {
5978         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5979           PerlMem_free(trndir);
5980           PerlMem_free(vmsdir);
5981           return do_fileify_dirspec("[]",buf,ts,NULL);
5982         }
5983         else if (trndir[1] == '.' &&
5984                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5985           PerlMem_free(trndir);
5986           PerlMem_free(vmsdir);
5987           return do_fileify_dirspec("[-]",buf,ts,NULL);
5988         }
5989       }
5990       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
5991         dirlen -= 1;                 /* to last element */
5992         lastdir = strrchr(trndir,'/');
5993       }
5994       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
5995         /* If we have "/." or "/..", VMSify it and let the VMS code
5996          * below expand it, rather than repeating the code to handle
5997          * relative components of a filespec here */
5998         do {
5999           if (*(cp1+2) == '.') cp1++;
6000           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
6001             char * ret_chr;
6002             if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
6003                 PerlMem_free(trndir);
6004                 PerlMem_free(vmsdir);
6005                 return NULL;
6006             }
6007             if (strchr(vmsdir,'/') != NULL) {
6008               /* If int_tovmsspec() returned it, it must have VMS syntax
6009                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
6010                * the time to check this here only so we avoid a recursion
6011                * loop; otherwise, gigo.
6012                */
6013               PerlMem_free(trndir);
6014               PerlMem_free(vmsdir);
6015               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
6016               return NULL;
6017             }
6018             if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
6019                 PerlMem_free(trndir);
6020                 PerlMem_free(vmsdir);
6021                 return NULL;
6022             }
6023             ret_chr = do_tounixspec(trndir,buf,ts,NULL);
6024             PerlMem_free(trndir);
6025             PerlMem_free(vmsdir);
6026             return ret_chr;
6027           }
6028           cp1++;
6029         } while ((cp1 = strstr(cp1,"/.")) != NULL);
6030         lastdir = strrchr(trndir,'/');
6031       }
6032       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
6033         char * ret_chr;
6034         /* Ditto for specs that end in an MFD -- let the VMS code
6035          * figure out whether it's a real device or a rooted logical. */
6036
6037         /* This should not happen any more.  Allowing the fake /000000
6038          * in a UNIX pathname causes all sorts of problems when trying
6039          * to run in UNIX emulation.  So the VMS to UNIX conversions
6040          * now remove the fake /000000 directories.
6041          */
6042
6043         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6044         if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6045             PerlMem_free(trndir);
6046             PerlMem_free(vmsdir);
6047             return NULL;
6048         }
6049         if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
6050             PerlMem_free(trndir);
6051             PerlMem_free(vmsdir);
6052             return NULL;
6053         }
6054         ret_chr = do_tounixspec(trndir,buf,ts,NULL);
6055         PerlMem_free(trndir);
6056         PerlMem_free(vmsdir);
6057         return ret_chr;
6058       }
6059       else {
6060
6061         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6062              !(lastdir = cp1 = strrchr(trndir,']')) &&
6063              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6064         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
6065           int ver; char *cp3;
6066
6067           /* For EFS or ODS-5 look for the last dot */
6068           if (decc_efs_charset) {
6069               cp2 = strrchr(cp1,'.');
6070           }
6071           if (vms_process_case_tolerant) {
6072               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
6073                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
6074                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6075                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6076                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6077                             (ver || *cp3)))))) {
6078                   PerlMem_free(trndir);
6079                   PerlMem_free(vmsdir);
6080                   set_errno(ENOTDIR);
6081                   set_vaxc_errno(RMS$_DIR);
6082                   return NULL;
6083               }
6084           }
6085           else {
6086               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
6087                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
6088                   !*(cp2+3) || *(cp2+3) != 'R' ||
6089                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6090                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6091                             (ver || *cp3)))))) {
6092                  PerlMem_free(trndir);
6093                  PerlMem_free(vmsdir);
6094                  set_errno(ENOTDIR);
6095                  set_vaxc_errno(RMS$_DIR);
6096                  return NULL;
6097               }
6098           }
6099           dirlen = cp2 - trndir;
6100         }
6101       }
6102
6103       retlen = dirlen + 6;
6104       if (buf) retspec = buf;
6105       else if (ts) Newx(retspec,retlen+1,char);
6106       else retspec = __fileify_retbuf;
6107       memcpy(retspec,trndir,dirlen);
6108       retspec[dirlen] = '\0';
6109
6110       /* We've picked up everything up to the directory file name.
6111          Now just add the type and version, and we're set. */
6112
6113       /* We should only add type for VMS syntax, but historically Perl
6114          has added it for UNIX style also */
6115
6116       /* Fix me - we should not be using the same routine for VMS and
6117          UNIX format files.  Things are too tangled so we need to lookup
6118          what syntax the output is */
6119
6120       is_unix = 0;
6121       is_vms = 0;
6122       lastdir = strrchr(trndir,'/');
6123       if (lastdir) {
6124           is_unix = 1;
6125       } else {
6126           lastdir = strpbrk(trndir,"]:>");
6127           if (lastdir) {
6128               is_vms = 1;
6129           }
6130       }
6131
6132       if ((is_vms == 0) && (is_unix == 0)) {
6133           /* We still do not  know? */
6134           is_unix = decc_filename_unix_report;
6135           if (is_unix == 0)
6136               is_vms = 1;
6137       }
6138
6139       if ((is_unix && !decc_efs_charset) || is_vms) {
6140
6141            /* It is a bug to add a .dir to a UNIX format directory spec */
6142            /* However Perl on VMS may have programs that expect this so */
6143            /* If not using EFS character specifications allow it. */
6144
6145            if ((!decc_efs_case_preserve) && vms_process_case_tolerant) {
6146                /* Traditionally Perl expects filenames in lower case */
6147                strcat(retspec, ".dir");
6148            } else {
6149                /* VMS expects the .DIR to be in upper case */
6150                strcat(retspec, ".DIR");
6151            }
6152
6153            /* It is also a bug to put a VMS format version on a UNIX file */
6154            /* specification.  Perl self tests are looking for this */
6155            if (is_vms || !(decc_efs_charset || decc_filename_unix_report))
6156                strcat(retspec, ";1");
6157       }
6158       PerlMem_free(trndir);
6159       PerlMem_free(vmsdir);
6160       return retspec;
6161     }
6162     else {  /* VMS-style directory spec */
6163
6164       char *esa, *esal, term, *cp;
6165       char *my_esa;
6166       int my_esa_len;
6167       unsigned long int sts, cmplen, haslower = 0;
6168       unsigned int nam_fnb;
6169       char * nam_type;
6170       struct FAB dirfab = cc$rms_fab;
6171       rms_setup_nam(savnam);
6172       rms_setup_nam(dirnam);
6173
6174       esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6175       if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6176       esal = NULL;
6177 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6178       esal = PerlMem_malloc(VMS_MAXRSS);
6179       if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6180 #endif
6181       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6182       rms_bind_fab_nam(dirfab, dirnam);
6183       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6184       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6185 #ifdef NAM$M_NO_SHORT_UPCASE
6186       if (decc_efs_case_preserve)
6187         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6188 #endif
6189
6190       for (cp = trndir; *cp; cp++)
6191         if (islower(*cp)) { haslower = 1; break; }
6192       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6193         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
6194           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6195           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
6196         }
6197         if (!sts) {
6198           PerlMem_free(esa);
6199           if (esal != NULL)
6200               PerlMem_free(esal);
6201           PerlMem_free(trndir);
6202           PerlMem_free(vmsdir);
6203           set_errno(EVMSERR);
6204           set_vaxc_errno(dirfab.fab$l_sts);
6205           return NULL;
6206         }
6207       }
6208       else {
6209         savnam = dirnam;
6210         /* Does the file really exist? */
6211         if (sys$search(&dirfab)& STS$K_SUCCESS) {
6212           /* Yes; fake the fnb bits so we'll check type below */
6213         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6214         }
6215         else { /* No; just work with potential name */
6216           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6217           else {
6218             int fab_sts;
6219             fab_sts = dirfab.fab$l_sts;
6220             sts = rms_free_search_context(&dirfab);
6221             PerlMem_free(esa);
6222             if (esal != NULL)
6223                 PerlMem_free(esal);
6224             PerlMem_free(trndir);
6225             PerlMem_free(vmsdir);
6226             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
6227             return NULL;
6228           }
6229         }
6230       }
6231
6232       /* Make sure we are using the right buffer */
6233       if (esal != NULL) {
6234         my_esa = esal;
6235         my_esa_len = rms_nam_esll(dirnam);
6236       } else {
6237         my_esa = esa;
6238         my_esa_len = rms_nam_esl(dirnam);
6239       }
6240       my_esa[my_esa_len] = '\0';
6241       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6242         cp1 = strchr(my_esa,']');
6243         if (!cp1) cp1 = strchr(my_esa,'>');
6244         if (cp1) {  /* Should always be true */
6245           my_esa_len -= cp1 - my_esa - 1;
6246           memmove(my_esa, cp1 + 1, my_esa_len);
6247         }
6248       }
6249       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6250         /* Yep; check version while we're at it, if it's there. */
6251         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6252         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6253           /* Something other than .DIR[;1].  Bzzt. */
6254           sts = rms_free_search_context(&dirfab);
6255           PerlMem_free(esa);
6256           if (esal != NULL)
6257              PerlMem_free(esal);
6258           PerlMem_free(trndir);
6259           PerlMem_free(vmsdir);
6260           set_errno(ENOTDIR);
6261           set_vaxc_errno(RMS$_DIR);
6262           return NULL;
6263         }
6264       }
6265
6266       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6267         /* They provided at least the name; we added the type, if necessary, */
6268         if (buf) retspec = buf;                            /* in sys$parse() */
6269         else if (ts) Newx(retspec, my_esa_len + 1, char);
6270         else retspec = __fileify_retbuf;
6271         strcpy(retspec,my_esa);
6272         sts = rms_free_search_context(&dirfab);
6273         PerlMem_free(trndir);
6274         PerlMem_free(esa);
6275         if (esal != NULL)
6276             PerlMem_free(esal);
6277         PerlMem_free(vmsdir);
6278         return retspec;
6279       }
6280       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6281         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6282         *cp1 = '\0';
6283         my_esa_len -= 9;
6284       }
6285       if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6286       if (cp1 == NULL) { /* should never happen */
6287         sts = rms_free_search_context(&dirfab);
6288         PerlMem_free(trndir);
6289         PerlMem_free(esa);
6290         if (esal != NULL)
6291             PerlMem_free(esal);
6292         PerlMem_free(vmsdir);
6293         return NULL;
6294       }
6295       term = *cp1;
6296       *cp1 = '\0';
6297       retlen = strlen(my_esa);
6298       cp1 = strrchr(my_esa,'.');
6299       /* ODS-5 directory specifications can have extra "." in them. */
6300       /* Fix-me, can not scan EFS file specifications backwards */
6301       while (cp1 != NULL) {
6302         if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6303           break;
6304         else {
6305            cp1--;
6306            while ((cp1 > my_esa) && (*cp1 != '.'))
6307              cp1--;
6308         }
6309         if (cp1 == my_esa)
6310           cp1 = NULL;
6311       }
6312
6313       if ((cp1) != NULL) {
6314         /* There's more than one directory in the path.  Just roll back. */
6315         *cp1 = term;
6316         if (buf) retspec = buf;
6317         else if (ts) Newx(retspec,retlen+7,char);
6318         else retspec = __fileify_retbuf;
6319         strcpy(retspec,my_esa);
6320       }
6321       else {
6322         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6323           /* Go back and expand rooted logical name */
6324           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6325 #ifdef NAM$M_NO_SHORT_UPCASE
6326           if (decc_efs_case_preserve)
6327             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6328 #endif
6329           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6330             sts = rms_free_search_context(&dirfab);
6331             PerlMem_free(esa);
6332             if (esal != NULL)
6333                 PerlMem_free(esal);
6334             PerlMem_free(trndir);
6335             PerlMem_free(vmsdir);
6336             set_errno(EVMSERR);
6337             set_vaxc_errno(dirfab.fab$l_sts);
6338             return NULL;
6339           }
6340
6341           /* This changes the length of the string of course */
6342           if (esal != NULL) {
6343               my_esa_len = rms_nam_esll(dirnam);
6344           } else {
6345               my_esa_len = rms_nam_esl(dirnam);
6346           }
6347
6348           retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6349           if (buf) retspec = buf;
6350           else if (ts) Newx(retspec,retlen+16,char);
6351           else retspec = __fileify_retbuf;
6352           cp1 = strstr(my_esa,"][");
6353           if (!cp1) cp1 = strstr(my_esa,"]<");
6354           dirlen = cp1 - my_esa;
6355           memcpy(retspec,my_esa,dirlen);
6356           if (!strncmp(cp1+2,"000000]",7)) {
6357             retspec[dirlen-1] = '\0';
6358             /* fix-me Not full ODS-5, just extra dots in directories for now */
6359             cp1 = retspec + dirlen - 1;
6360             while (cp1 > retspec)
6361             {
6362               if (*cp1 == '[')
6363                 break;
6364               if (*cp1 == '.') {
6365                 if (*(cp1-1) != '^')
6366                   break;
6367               }
6368               cp1--;
6369             }
6370             if (*cp1 == '.') *cp1 = ']';
6371             else {
6372               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6373               memmove(cp1+1,"000000]",7);
6374             }
6375           }
6376           else {
6377             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
6378             retspec[retlen] = '\0';
6379             /* Convert last '.' to ']' */
6380             cp1 = retspec+retlen-1;
6381             while (*cp != '[') {
6382               cp1--;
6383               if (*cp1 == '.') {
6384                 /* Do not trip on extra dots in ODS-5 directories */
6385                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
6386                 break;
6387               }
6388             }
6389             if (*cp1 == '.') *cp1 = ']';
6390             else {
6391               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6392               memmove(cp1+1,"000000]",7);
6393             }
6394           }
6395         }
6396         else {  /* This is a top-level dir.  Add the MFD to the path. */
6397           if (buf) retspec = buf;
6398           else if (ts) Newx(retspec,retlen+16,char);
6399           else retspec = __fileify_retbuf;
6400           cp1 = my_esa;
6401           cp2 = retspec;
6402           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6403           strcpy(cp2,":[000000]");
6404           cp1 += 2;
6405           strcpy(cp2+9,cp1);
6406         }
6407       }
6408       sts = rms_free_search_context(&dirfab);
6409       /* We've set up the string up through the filename.  Add the
6410          type and version, and we're done. */
6411       strcat(retspec,".DIR;1");
6412
6413       /* $PARSE may have upcased filespec, so convert output to lower
6414        * case if input contained any lowercase characters. */
6415       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
6416       PerlMem_free(trndir);
6417       PerlMem_free(esa);
6418       if (esal != NULL)
6419         PerlMem_free(esal);
6420       PerlMem_free(vmsdir);
6421       return retspec;
6422     }
6423 }  /* end of do_fileify_dirspec() */
6424 /*}}}*/
6425 /* External entry points */
6426 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6427 { return do_fileify_dirspec(dir,buf,0,NULL); }
6428 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6429 { return do_fileify_dirspec(dir,buf,1,NULL); }
6430 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6431 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6432 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6433 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6434
6435 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6436 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6437 {
6438     static char __pathify_retbuf[VMS_MAXRSS];
6439     unsigned long int retlen;
6440     char *retpath, *cp1, *cp2, *trndir;
6441     unsigned short int trnlnm_iter_count;
6442     STRLEN trnlen;
6443     int sts;
6444     if (utf8_fl != NULL)
6445         *utf8_fl = 0;
6446
6447     if (!dir || !*dir) {
6448       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6449     }
6450
6451     trndir = PerlMem_malloc(VMS_MAXRSS);
6452     if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6453     if (*dir) strcpy(trndir,dir);
6454     else getcwd(trndir,VMS_MAXRSS - 1);
6455
6456     trnlnm_iter_count = 0;
6457     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6458            && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
6459       trnlnm_iter_count++;
6460       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6461       trnlen = strlen(trndir);
6462
6463       /* Trap simple rooted lnms, and return lnm:[000000] */
6464       if (!strcmp(trndir+trnlen-2,".]")) {
6465         if (buf) retpath = buf;
6466         else if (ts) Newx(retpath,strlen(dir)+10,char);
6467         else retpath = __pathify_retbuf;
6468         strcpy(retpath,dir);
6469         strcat(retpath,":[000000]");
6470         PerlMem_free(trndir);
6471         return retpath;
6472       }
6473     }
6474
6475     /* At this point we do not work with *dir, but the copy in
6476      * *trndir that is modifiable.
6477      */
6478
6479     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
6480       if (*trndir == '.' && (*(trndir+1) == '\0' ||
6481                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
6482         retlen = 2 + (*(trndir+1) != '\0');
6483       else {
6484         if ( !(cp1 = strrchr(trndir,'/')) &&
6485              !(cp1 = strrchr(trndir,']')) &&
6486              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
6487         if ((cp2 = strchr(cp1,'.')) != NULL &&
6488             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
6489              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
6490               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
6491               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
6492           int ver; char *cp3;
6493
6494           /* For EFS or ODS-5 look for the last dot */
6495           if (decc_efs_charset) {
6496             cp2 = strrchr(cp1,'.');
6497           }
6498           if (vms_process_case_tolerant) {
6499               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
6500                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
6501                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6502                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6503                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6504                             (ver || *cp3)))))) {
6505                 PerlMem_free(trndir);
6506                 set_errno(ENOTDIR);
6507                 set_vaxc_errno(RMS$_DIR);
6508                 return NULL;
6509               }
6510           }
6511           else {
6512               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
6513                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
6514                   !*(cp2+3) || *(cp2+3) != 'R' ||
6515                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6516                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6517                             (ver || *cp3)))))) {
6518                 PerlMem_free(trndir);
6519                 set_errno(ENOTDIR);
6520                 set_vaxc_errno(RMS$_DIR);
6521                 return NULL;
6522               }
6523           }
6524           retlen = cp2 - trndir + 1;
6525         }
6526         else {  /* No file type present.  Treat the filename as a directory. */
6527           retlen = strlen(trndir) + 1;
6528         }
6529       }
6530       if (buf) retpath = buf;
6531       else if (ts) Newx(retpath,retlen+1,char);
6532       else retpath = __pathify_retbuf;
6533       strncpy(retpath, trndir, retlen-1);
6534       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
6535         retpath[retlen-1] = '/';      /* with '/', add it. */
6536         retpath[retlen] = '\0';
6537       }
6538       else retpath[retlen-1] = '\0';
6539     }
6540     else {  /* VMS-style directory spec */
6541       char *esa, *esal, *cp;
6542       char *my_esa;
6543       int my_esa_len;
6544       unsigned long int sts, cmplen, haslower;
6545       struct FAB dirfab = cc$rms_fab;
6546       int dirlen;
6547       rms_setup_nam(savnam);
6548       rms_setup_nam(dirnam);
6549
6550       /* If we've got an explicit filename, we can just shuffle the string. */
6551       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
6552              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
6553         if ((cp2 = strchr(cp1,'.')) != NULL) {
6554           int ver; char *cp3;
6555           if (vms_process_case_tolerant) {
6556               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
6557                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
6558                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6559                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6560                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6561                             (ver || *cp3)))))) {
6562                PerlMem_free(trndir);
6563                set_errno(ENOTDIR);
6564                set_vaxc_errno(RMS$_DIR);
6565                return NULL;
6566              }
6567           }
6568           else {
6569               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
6570                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
6571                   !*(cp2+3) || *(cp2+3) != 'R' ||
6572                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6573                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6574                             (ver || *cp3)))))) {
6575                PerlMem_free(trndir);
6576                set_errno(ENOTDIR);
6577                set_vaxc_errno(RMS$_DIR);
6578                return NULL;
6579              }
6580           }
6581         }
6582         else {  /* No file type, so just draw name into directory part */
6583           for (cp2 = cp1; *cp2; cp2++) ;
6584         }
6585         *cp2 = *cp1;
6586         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
6587         *cp1 = '.';
6588         /* We've now got a VMS 'path'; fall through */
6589       }
6590
6591       dirlen = strlen(trndir);
6592       if (trndir[dirlen-1] == ']' ||
6593           trndir[dirlen-1] == '>' ||
6594           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
6595         if (buf) retpath = buf;
6596         else if (ts) Newx(retpath,strlen(trndir)+1,char);
6597         else retpath = __pathify_retbuf;
6598         strcpy(retpath,trndir);
6599         PerlMem_free(trndir);
6600         return retpath;
6601       }
6602       rms_set_fna(dirfab, dirnam, trndir, dirlen);
6603       esa = PerlMem_malloc(VMS_MAXRSS);
6604       if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6605       esal = NULL;
6606 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6607       esal = PerlMem_malloc(VMS_MAXRSS);
6608       if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6609 #endif
6610       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6611       rms_bind_fab_nam(dirfab, dirnam);
6612       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
6613 #ifdef NAM$M_NO_SHORT_UPCASE
6614       if (decc_efs_case_preserve)
6615           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6616 #endif
6617
6618       for (cp = trndir; *cp; cp++)
6619         if (islower(*cp)) { haslower = 1; break; }
6620
6621       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
6622         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
6623           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6624           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
6625         }
6626         if (!sts) {
6627           PerlMem_free(trndir);
6628           PerlMem_free(esa);
6629           if (esal != NULL)
6630             PerlMem_free(esal);
6631           set_errno(EVMSERR);
6632           set_vaxc_errno(dirfab.fab$l_sts);
6633           return NULL;
6634         }
6635       }
6636       else {
6637         savnam = dirnam;
6638         /* Does the file really exist? */
6639         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
6640           if (dirfab.fab$l_sts != RMS$_FNF) {
6641             int sts1;
6642             sts1 = rms_free_search_context(&dirfab);
6643             PerlMem_free(trndir);
6644             PerlMem_free(esa);
6645             if (esal != NULL)
6646                 PerlMem_free(esal);
6647             set_errno(EVMSERR);
6648             set_vaxc_errno(dirfab.fab$l_sts);
6649             return NULL;
6650           }
6651           dirnam = savnam; /* No; just work with potential name */
6652         }
6653       }
6654       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6655         /* Yep; check version while we're at it, if it's there. */
6656         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6657         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
6658           int sts2;
6659           /* Something other than .DIR[;1].  Bzzt. */
6660           sts2 = rms_free_search_context(&dirfab);
6661           PerlMem_free(trndir);
6662           PerlMem_free(esa);
6663           if (esal != NULL)
6664              PerlMem_free(esal);
6665           set_errno(ENOTDIR);
6666           set_vaxc_errno(RMS$_DIR);
6667           return NULL;
6668         }
6669       }
6670       /* Make sure we are using the right buffer */
6671       if (esal != NULL) {
6672         /* We only need one, clean up the other */
6673         my_esa = esal;
6674         my_esa_len = rms_nam_esll(dirnam);
6675       } else {
6676         my_esa = esa;
6677         my_esa_len = rms_nam_esl(dirnam);
6678       }
6679
6680       /* Null terminate the buffer */
6681       my_esa[my_esa_len] = '\0';
6682
6683       /* OK, the type was fine.  Now pull any file name into the
6684          directory path. */
6685       if ((cp1 = strrchr(my_esa,']'))) *(rms_nam_typel(dirnam)) = ']';
6686       else {
6687         cp1 = strrchr(my_esa,'>');
6688         *(rms_nam_typel(dirnam)) = '>';
6689       }
6690       *cp1 = '.';
6691       *(rms_nam_typel(dirnam) + 1) = '\0';
6692       retlen = (rms_nam_typel(dirnam)) - my_esa + 2;
6693       if (buf) retpath = buf;
6694       else if (ts) Newx(retpath,retlen,char);
6695       else retpath = __pathify_retbuf;
6696       strcpy(retpath,my_esa);
6697       PerlMem_free(esa);
6698       if (esal != NULL)
6699           PerlMem_free(esal);
6700       sts = rms_free_search_context(&dirfab);
6701       /* $PARSE may have upcased filespec, so convert output to lower
6702        * case if input contained any lowercase characters. */
6703       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
6704     }
6705
6706     PerlMem_free(trndir);
6707     return retpath;
6708 }  /* end of do_pathify_dirspec() */
6709 /*}}}*/
6710 /* External entry points */
6711 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6712 { return do_pathify_dirspec(dir,buf,0,NULL); }
6713 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6714 { return do_pathify_dirspec(dir,buf,1,NULL); }
6715 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6716 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6717 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6718 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
6719
6720 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
6721 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
6722 {
6723   static char __tounixspec_retbuf[VMS_MAXRSS];
6724   char *dirend, *rslt, *cp1, *cp3, *tmp;
6725   const char *cp2;
6726   int devlen, dirlen, retlen = VMS_MAXRSS;
6727   int expand = 1; /* guarantee room for leading and trailing slashes */
6728   unsigned short int trnlnm_iter_count;
6729   int cmp_rslt;
6730   if (utf8_fl != NULL)
6731     *utf8_fl = 0;
6732
6733   if (spec == NULL) return NULL;
6734   if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
6735   if (buf) rslt = buf;
6736   else if (ts) {
6737     Newx(rslt, VMS_MAXRSS, char);
6738   }
6739   else rslt = __tounixspec_retbuf;
6740
6741   /* New VMS specific format needs translation
6742    * glob passes filenames with trailing '\n' and expects this preserved.
6743    */
6744   if (decc_posix_compliant_pathnames) {
6745     if (strncmp(spec, "\"^UP^", 5) == 0) {
6746       char * uspec;
6747       char *tunix;
6748       int tunix_len;
6749       int nl_flag;
6750
6751       tunix = PerlMem_malloc(VMS_MAXRSS);
6752       if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6753       strcpy(tunix, spec);
6754       tunix_len = strlen(tunix);
6755       nl_flag = 0;
6756       if (tunix[tunix_len - 1] == '\n') {
6757         tunix[tunix_len - 1] = '\"';
6758         tunix[tunix_len] = '\0';
6759         tunix_len--;
6760         nl_flag = 1;
6761       }
6762       uspec = decc$translate_vms(tunix);
6763       PerlMem_free(tunix);
6764       if ((int)uspec > 0) {
6765         strcpy(rslt,uspec);
6766         if (nl_flag) {
6767           strcat(rslt,"\n");
6768         }
6769         else {
6770           /* If we can not translate it, makemaker wants as-is */
6771           strcpy(rslt, spec);
6772         }
6773         return rslt;
6774       }
6775     }
6776   }
6777
6778   cmp_rslt = 0; /* Presume VMS */
6779   cp1 = strchr(spec, '/');
6780   if (cp1 == NULL)
6781     cmp_rslt = 0;
6782
6783     /* Look for EFS ^/ */
6784     if (decc_efs_charset) {
6785       while (cp1 != NULL) {
6786         cp2 = cp1 - 1;
6787         if (*cp2 != '^') {
6788           /* Found illegal VMS, assume UNIX */
6789           cmp_rslt = 1;
6790           break;
6791         }
6792       cp1++;
6793       cp1 = strchr(cp1, '/');
6794     }
6795   }
6796
6797   /* Look for "." and ".." */
6798   if (decc_filename_unix_report) {
6799     if (spec[0] == '.') {
6800       if ((spec[1] == '\0') || (spec[1] == '\n')) {
6801         cmp_rslt = 1;
6802       }
6803       else {
6804         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
6805           cmp_rslt = 1;
6806         }
6807       }
6808     }
6809   }
6810   /* This is already UNIX or at least nothing VMS understands */
6811   if (cmp_rslt) {
6812     strcpy(rslt,spec);
6813     return rslt;
6814   }
6815
6816   cp1 = rslt;
6817   cp2 = spec;
6818   dirend = strrchr(spec,']');
6819   if (dirend == NULL) dirend = strrchr(spec,'>');
6820   if (dirend == NULL) dirend = strchr(spec,':');
6821   if (dirend == NULL) {
6822     strcpy(rslt,spec);
6823     return rslt;
6824   }
6825
6826   /* Special case 1 - sys$posix_root = / */
6827 #if __CRTL_VER >= 70000000
6828   if (!decc_disable_posix_root) {
6829     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6830       *cp1 = '/';
6831       cp1++;
6832       cp2 = cp2 + 15;
6833       }
6834   }
6835 #endif
6836
6837   /* Special case 2 - Convert NLA0: to /dev/null */
6838 #if __CRTL_VER < 70000000
6839   cmp_rslt = strncmp(spec,"NLA0:", 5);
6840   if (cmp_rslt != 0)
6841      cmp_rslt = strncmp(spec,"nla0:", 5);
6842 #else
6843   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6844 #endif
6845   if (cmp_rslt == 0) {
6846     strcpy(rslt, "/dev/null");
6847     cp1 = cp1 + 9;
6848     cp2 = cp2 + 5;
6849     if (spec[6] != '\0') {
6850       cp1[9] == '/';
6851       cp1++;
6852       cp2++;
6853     }
6854   }
6855
6856    /* Also handle special case "SYS$SCRATCH:" */
6857 #if __CRTL_VER < 70000000
6858   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
6859   if (cmp_rslt != 0)
6860      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
6861 #else
6862   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6863 #endif
6864   tmp = PerlMem_malloc(VMS_MAXRSS);
6865   if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6866   if (cmp_rslt == 0) {
6867   int islnm;
6868
6869     islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
6870     if (!islnm) {
6871       strcpy(rslt, "/tmp");
6872       cp1 = cp1 + 4;
6873       cp2 = cp2 + 12;
6874       if (spec[12] != '\0') {
6875         cp1[4] == '/';
6876         cp1++;
6877         cp2++;
6878       }
6879     }
6880   }
6881
6882   if (*cp2 != '[' && *cp2 != '<') {
6883     *(cp1++) = '/';
6884   }
6885   else {  /* the VMS spec begins with directories */
6886     cp2++;
6887     if (*cp2 == ']' || *cp2 == '>') {
6888       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
6889       PerlMem_free(tmp);
6890       return rslt;
6891     }
6892     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
6893       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
6894         if (ts) Safefree(rslt);
6895         PerlMem_free(tmp);
6896         return NULL;
6897       }
6898       trnlnm_iter_count = 0;
6899       do {
6900         cp3 = tmp;
6901         while (*cp3 != ':' && *cp3) cp3++;
6902         *(cp3++) = '\0';
6903         if (strchr(cp3,']') != NULL) break;
6904         trnlnm_iter_count++;
6905         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
6906       } while (vmstrnenv(tmp,tmp,0,fildev,0));
6907       if (ts && !buf &&
6908           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
6909         retlen = devlen + dirlen;
6910         Renew(rslt,retlen+1+2*expand,char);
6911         cp1 = rslt;
6912       }
6913       cp3 = tmp;
6914       *(cp1++) = '/';
6915       while (*cp3) {
6916         *(cp1++) = *(cp3++);
6917         if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
6918             PerlMem_free(tmp);
6919             return NULL; /* No room */
6920         }
6921       }
6922       *(cp1++) = '/';
6923     }
6924     if ((*cp2 == '^')) {
6925         /* EFS file escape, pass the next character as is */
6926         /* Fix me: HEX encoding for Unicode not implemented */
6927         cp2++;
6928     }
6929     else if ( *cp2 == '.') {
6930       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
6931         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6932         cp2 += 3;
6933       }
6934       else cp2++;
6935     }
6936   }
6937   PerlMem_free(tmp);
6938   for (; cp2 <= dirend; cp2++) {
6939     if ((*cp2 == '^')) {
6940         /* EFS file escape, pass the next character as is */
6941         /* Fix me: HEX encoding for Unicode not implemented */
6942         *(cp1++) = *(++cp2);
6943         /* An escaped dot stays as is -- don't convert to slash */
6944         if (*cp2 == '.') cp2++;
6945     }
6946     if (*cp2 == ':') {
6947       *(cp1++) = '/';
6948       if (*(cp2+1) == '[') cp2++;
6949     }
6950     else if (*cp2 == ']' || *cp2 == '>') {
6951       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6952     }
6953     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
6954       *(cp1++) = '/';
6955       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6956         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6957                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6958         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6959             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6960       }
6961       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6962         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6963         cp2 += 2;
6964       }
6965     }
6966     else if (*cp2 == '-') {
6967       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6968         while (*cp2 == '-') {
6969           cp2++;
6970           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6971         }
6972         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
6973           if (ts) Safefree(rslt);                        /* filespecs like */
6974           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
6975           return NULL;
6976         }
6977       }
6978       else *(cp1++) = *cp2;
6979     }
6980     else *(cp1++) = *cp2;
6981   }
6982   while (*cp2) {
6983     if ((*cp2 == '^') && (*(cp2+1) == '.')) cp2++;  /* '^.' --> '.' */
6984     *(cp1++) = *(cp2++);
6985   }
6986   *cp1 = '\0';
6987
6988   /* This still leaves /000000/ when working with a
6989    * VMS device root or concealed root.
6990    */
6991   {
6992   int ulen;
6993   char * zeros;
6994
6995       ulen = strlen(rslt);
6996
6997       /* Get rid of "000000/ in rooted filespecs */
6998       if (ulen > 7) {
6999         zeros = strstr(rslt, "/000000/");
7000         if (zeros != NULL) {
7001           int mlen;
7002           mlen = ulen - (zeros - rslt) - 7;
7003           memmove(zeros, &zeros[7], mlen);
7004           ulen = ulen - 7;
7005           rslt[ulen] = '\0';
7006         }
7007       }
7008   }
7009
7010   return rslt;
7011
7012 }  /* end of do_tounixspec() */
7013 /*}}}*/
7014 /* External entry points */
7015 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
7016   { return do_tounixspec(spec,buf,0, NULL); }
7017 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7018   { return do_tounixspec(spec,buf,1, NULL); }
7019 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7020   { return do_tounixspec(spec,buf,0, utf8_fl); }
7021 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7022   { return do_tounixspec(spec,buf,1, utf8_fl); }
7023
7024 #if __CRTL_VER >= 70200000 && !defined(__VAX)
7025
7026 /*
7027  This procedure is used to identify if a path is based in either
7028  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7029  it returns the OpenVMS format directory for it.
7030
7031  It is expecting specifications of only '/' or '/xxxx/'
7032
7033  If a posix root does not exist, or 'xxxx' is not a directory
7034  in the posix root, it returns a failure.
7035
7036  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7037
7038  It is used only internally by posix_to_vmsspec_hardway().
7039  */
7040
7041 static int posix_root_to_vms
7042   (char *vmspath, int vmspath_len,
7043    const char *unixpath,
7044    const int * utf8_fl)
7045 {
7046 int sts;
7047 struct FAB myfab = cc$rms_fab;
7048 rms_setup_nam(mynam);
7049 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7050 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7051 char * esa, * esal, * rsa, * rsal;
7052 char *vms_delim;
7053 int dir_flag;
7054 int unixlen;
7055
7056     dir_flag = 0;
7057     vmspath[0] = '\0';
7058     unixlen = strlen(unixpath);
7059     if (unixlen == 0) {
7060       return RMS$_FNF;
7061     }
7062
7063 #if __CRTL_VER >= 80200000
7064   /* If not a posix spec already, convert it */
7065   if (decc_posix_compliant_pathnames) {
7066     if (strncmp(unixpath,"\"^UP^",5) != 0) {
7067       sprintf(vmspath,"\"^UP^%s\"",unixpath);
7068     }
7069     else {
7070       /* This is already a VMS specification, no conversion */
7071       unixlen--;
7072       strncpy(vmspath,unixpath, vmspath_len);
7073     }
7074   }
7075   else
7076 #endif
7077   {
7078   int path_len;
7079   int i,j;
7080
7081      /* Check to see if this is under the POSIX root */
7082      if (decc_disable_posix_root) {
7083         return RMS$_FNF;
7084      }
7085
7086      /* Skip leading / */
7087      if (unixpath[0] == '/') {
7088         unixpath++;
7089         unixlen--;
7090      }
7091
7092
7093      strcpy(vmspath,"SYS$POSIX_ROOT:");
7094
7095      /* If this is only the / , or blank, then... */
7096      if (unixpath[0] == '\0') {
7097         /* by definition, this is the answer */
7098         return SS$_NORMAL;
7099      }
7100
7101      /* Need to look up a directory */
7102      vmspath[15] = '[';
7103      vmspath[16] = '\0';
7104
7105      /* Copy and add '^' escape characters as needed */
7106      j = 16;
7107      i = 0;
7108      while (unixpath[i] != 0) {
7109      int k;
7110
7111         j += copy_expand_unix_filename_escape
7112             (&vmspath[j], &unixpath[i], &k, utf8_fl);
7113         i += k;
7114      }
7115
7116      path_len = strlen(vmspath);
7117      if (vmspath[path_len - 1] == '/')
7118         path_len--;
7119      vmspath[path_len] = ']';
7120      path_len++;
7121      vmspath[path_len] = '\0';
7122
7123   }
7124   vmspath[vmspath_len] = 0;
7125   if (unixpath[unixlen - 1] == '/')
7126   dir_flag = 1;
7127   esal = PerlMem_malloc(VMS_MAXRSS);
7128   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7129   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7130   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7131   rsal = PerlMem_malloc(VMS_MAXRSS);
7132   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7133   rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7134   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7135   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7136   rms_bind_fab_nam(myfab, mynam);
7137   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7138   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7139   if (decc_efs_case_preserve)
7140     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7141 #ifdef NAML$M_OPEN_SPECIAL
7142   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7143 #endif
7144
7145   /* Set up the remaining naml fields */
7146   sts = sys$parse(&myfab);
7147
7148   /* It failed! Try again as a UNIX filespec */
7149   if (!(sts & 1)) {
7150     PerlMem_free(esal);
7151     PerlMem_free(esa);
7152     PerlMem_free(rsal);
7153     PerlMem_free(rsa);
7154     return sts;
7155   }
7156
7157    /* get the Device ID and the FID */
7158    sts = sys$search(&myfab);
7159
7160    /* These are no longer needed */
7161    PerlMem_free(esa);
7162    PerlMem_free(rsal);
7163    PerlMem_free(rsa);
7164
7165    /* on any failure, returned the POSIX ^UP^ filespec */
7166    if (!(sts & 1)) {
7167       PerlMem_free(esal);
7168       return sts;
7169    }
7170    specdsc.dsc$a_pointer = vmspath;
7171    specdsc.dsc$w_length = vmspath_len;
7172
7173    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7174    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7175    sts = lib$fid_to_name
7176       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7177
7178   /* on any failure, returned the POSIX ^UP^ filespec */
7179   if (!(sts & 1)) {
7180      /* This can happen if user does not have permission to read directories */
7181      if (strncmp(unixpath,"\"^UP^",5) != 0)
7182        sprintf(vmspath,"\"^UP^%s\"",unixpath);
7183      else
7184        strcpy(vmspath, unixpath);
7185   }
7186   else {
7187     vmspath[specdsc.dsc$w_length] = 0;
7188
7189     /* Are we expecting a directory? */
7190     if (dir_flag != 0) {
7191     int i;
7192     char *eptr;
7193
7194       eptr = NULL;
7195
7196       i = specdsc.dsc$w_length - 1;
7197       while (i > 0) {
7198       int zercnt;
7199         zercnt = 0;
7200         /* Version must be '1' */
7201         if (vmspath[i--] != '1')
7202           break;
7203         /* Version delimiter is one of ".;" */
7204         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7205           break;
7206         i--;
7207         if (vmspath[i--] != 'R')
7208           break;
7209         if (vmspath[i--] != 'I')
7210           break;
7211         if (vmspath[i--] != 'D')
7212           break;
7213         if (vmspath[i--] != '.')
7214           break;
7215         eptr = &vmspath[i+1];
7216         while (i > 0) {
7217           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7218             if (vmspath[i-1] != '^') {
7219               if (zercnt != 6) {
7220                 *eptr = vmspath[i];
7221                 eptr[1] = '\0';
7222                 vmspath[i] = '.';
7223                 break;
7224               }
7225               else {
7226                 /* Get rid of 6 imaginary zero directory filename */
7227                 vmspath[i+1] = '\0';
7228               }
7229             }
7230           }
7231           if (vmspath[i] == '0')
7232             zercnt++;
7233           else
7234             zercnt = 10;
7235           i--;
7236         }
7237         break;
7238       }
7239     }
7240   }
7241   PerlMem_free(esal);
7242   return sts;
7243 }
7244
7245 /* /dev/mumble needs to be handled special.
7246    /dev/null becomes NLA0:, And there is the potential for other stuff
7247    like /dev/tty which may need to be mapped to something.
7248 */
7249
7250 static int
7251 slash_dev_special_to_vms
7252    (const char * unixptr,
7253     char * vmspath,
7254     int vmspath_len)
7255 {
7256 char * nextslash;
7257 int len;
7258 int cmp;
7259 int islnm;
7260
7261     unixptr += 4;
7262     nextslash = strchr(unixptr, '/');
7263     len = strlen(unixptr);
7264     if (nextslash != NULL)
7265         len = nextslash - unixptr;
7266     cmp = strncmp("null", unixptr, 5);
7267     if (cmp == 0) {
7268         if (vmspath_len >= 6) {
7269             strcpy(vmspath, "_NLA0:");
7270             return SS$_NORMAL;
7271         }
7272     }
7273 }
7274
7275
7276 /* The built in routines do not understand perl's special needs, so
7277     doing a manual conversion from UNIX to VMS
7278
7279     If the utf8_fl is not null and points to a non-zero value, then
7280     treat 8 bit characters as UTF-8.
7281
7282     The sequence starting with '$(' and ending with ')' will be passed
7283     through with out interpretation instead of being escaped.
7284
7285   */
7286 static int posix_to_vmsspec_hardway
7287   (char *vmspath, int vmspath_len,
7288    const char *unixpath,
7289    int dir_flag,
7290    int * utf8_fl) {
7291
7292 char *esa;
7293 const char *unixptr;
7294 const char *unixend;
7295 char *vmsptr;
7296 const char *lastslash;
7297 const char *lastdot;
7298 int unixlen;
7299 int vmslen;
7300 int dir_start;
7301 int dir_dot;
7302 int quoted;
7303 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7304 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7305
7306   if (utf8_fl != NULL)
7307     *utf8_fl = 0;
7308
7309   unixptr = unixpath;
7310   dir_dot = 0;
7311
7312   /* Ignore leading "/" characters */
7313   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7314     unixptr++;
7315   }
7316   unixlen = strlen(unixptr);
7317
7318   /* Do nothing with blank paths */
7319   if (unixlen == 0) {
7320     vmspath[0] = '\0';
7321     return SS$_NORMAL;
7322   }
7323
7324   quoted = 0;
7325   /* This could have a "^UP^ on the front */
7326   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7327     quoted = 1;
7328     unixptr+= 5;
7329     unixlen-= 5;
7330   }
7331
7332   lastslash = strrchr(unixptr,'/');
7333   lastdot = strrchr(unixptr,'.');
7334   unixend = strrchr(unixptr,'\"');
7335   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7336     unixend = unixptr + unixlen;
7337   }
7338
7339   /* last dot is last dot or past end of string */
7340   if (lastdot == NULL)
7341     lastdot = unixptr + unixlen;
7342
7343   /* if no directories, set last slash to beginning of string */
7344   if (lastslash == NULL) {
7345     lastslash = unixptr;
7346   }
7347   else {
7348     /* Watch out for trailing "." after last slash, still a directory */
7349     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7350       lastslash = unixptr + unixlen;
7351     }
7352
7353     /* Watch out for traiing ".." after last slash, still a directory */
7354     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7355       lastslash = unixptr + unixlen;
7356     }
7357
7358     /* dots in directories are aways escaped */
7359     if (lastdot < lastslash)
7360       lastdot = unixptr + unixlen;
7361   }
7362
7363   /* if (unixptr < lastslash) then we are in a directory */
7364
7365   dir_start = 0;
7366
7367   vmsptr = vmspath;
7368   vmslen = 0;
7369
7370   /* Start with the UNIX path */
7371   if (*unixptr != '/') {
7372     /* relative paths */
7373
7374     /* If allowing logical names on relative pathnames, then handle here */
7375     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7376         !decc_posix_compliant_pathnames) {
7377     char * nextslash;
7378     int seg_len;
7379     char * trn;
7380     int islnm;
7381
7382         /* Find the next slash */
7383         nextslash = strchr(unixptr,'/');
7384
7385         esa = PerlMem_malloc(vmspath_len);
7386         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7387
7388         trn = PerlMem_malloc(VMS_MAXRSS);
7389         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7390
7391         if (nextslash != NULL) {
7392
7393             seg_len = nextslash - unixptr;
7394             strncpy(esa, unixptr, seg_len);
7395             esa[seg_len] = 0;
7396         }
7397         else {
7398             strcpy(esa, unixptr);
7399             seg_len = strlen(unixptr);
7400         }
7401         /* trnlnm(section) */
7402         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7403
7404         if (islnm) {
7405             /* Now fix up the directory */
7406
7407             /* Split up the path to find the components */
7408             sts = vms_split_path
7409                   (trn,
7410                    &v_spec,
7411                    &v_len,
7412                    &r_spec,
7413                    &r_len,
7414                    &d_spec,
7415                    &d_len,
7416                    &n_spec,
7417                    &n_len,
7418                    &e_spec,
7419                    &e_len,
7420                    &vs_spec,
7421                    &vs_len);
7422
7423             while (sts == 0) {
7424             char * strt;
7425             int cmp;
7426
7427                 /* A logical name must be a directory  or the full
7428                    specification.  It is only a full specification if
7429                    it is the only component */
7430                 if ((unixptr[seg_len] == '\0') ||
7431                     (unixptr[seg_len+1] == '\0')) {
7432
7433                     /* Is a directory being required? */
7434                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7435                         /* Not a logical name */
7436                         break;
7437                     }
7438
7439
7440                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7441                         /* This must be a directory */
7442                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7443                             strcpy(vmsptr, esa);
7444                             vmslen=strlen(vmsptr);
7445                             vmsptr[vmslen] = ':';
7446                             vmslen++;
7447                             vmsptr[vmslen] = '\0';
7448                             return SS$_NORMAL;
7449                         }
7450                     }
7451
7452                 }
7453
7454
7455                 /* must be dev/directory - ignore version */
7456                 if ((n_len + e_len) != 0)
7457                     break;
7458
7459                 /* transfer the volume */
7460                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7461                     strncpy(vmsptr, v_spec, v_len);
7462                     vmsptr += v_len;
7463                     vmsptr[0] = '\0';
7464                     vmslen += v_len;
7465                 }
7466
7467                 /* unroot the rooted directory */
7468                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7469                     r_spec[0] = '[';
7470                     r_spec[r_len - 1] = ']';
7471
7472                     /* This should not be there, but nothing is perfect */
7473                     if (r_len > 9) {
7474                         cmp = strcmp(&r_spec[1], "000000.");
7475                         if (cmp == 0) {
7476                             r_spec += 7;
7477                             r_spec[7] = '[';
7478                             r_len -= 7;
7479                             if (r_len == 2)
7480                                 r_len = 0;
7481                         }
7482                     }
7483                     if (r_len > 0) {
7484                         strncpy(vmsptr, r_spec, r_len);
7485                         vmsptr += r_len;
7486                         vmslen += r_len;
7487                         vmsptr[0] = '\0';
7488                     }
7489                 }
7490                 /* Bring over the directory. */
7491                 if ((d_len > 0) &&
7492                     ((d_len + vmslen) < vmspath_len)) {
7493                     d_spec[0] = '[';
7494                     d_spec[d_len - 1] = ']';
7495                     if (d_len > 9) {
7496                         cmp = strcmp(&d_spec[1], "000000.");
7497                         if (cmp == 0) {
7498                             d_spec += 7;
7499                             d_spec[7] = '[';
7500                             d_len -= 7;
7501                             if (d_len == 2)
7502                                 d_len = 0;
7503                         }
7504                     }
7505
7506                     if (r_len > 0) {
7507                         /* Remove the redundant root */
7508                         if (r_len > 0) {
7509                             /* remove the ][ */
7510                             vmsptr--;
7511                             vmslen--;
7512                             d_spec++;
7513                             d_len--;
7514                         }
7515                         strncpy(vmsptr, d_spec, d_len);
7516                             vmsptr += d_len;
7517                             vmslen += d_len;
7518                             vmsptr[0] = '\0';
7519                     }
7520                 }
7521                 break;
7522             }
7523         }
7524
7525         PerlMem_free(esa);
7526         PerlMem_free(trn);
7527     }
7528
7529     if (lastslash > unixptr) {
7530     int dotdir_seen;
7531
7532       /* skip leading ./ */
7533       dotdir_seen = 0;
7534       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7535         dotdir_seen = 1;
7536         unixptr++;
7537         unixptr++;
7538       }
7539
7540       /* Are we still in a directory? */
7541       if (unixptr <= lastslash) {
7542         *vmsptr++ = '[';
7543         vmslen = 1;
7544         dir_start = 1;
7545
7546         /* if not backing up, then it is relative forward. */
7547         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7548               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7549           *vmsptr++ = '.';
7550           vmslen++;
7551           dir_dot = 1;
7552           }
7553        }
7554        else {
7555          if (dotdir_seen) {
7556            /* Perl wants an empty directory here to tell the difference
7557             * between a DCL commmand and a filename
7558             */
7559           *vmsptr++ = '[';
7560           *vmsptr++ = ']';
7561           vmslen = 2;
7562         }
7563       }
7564     }
7565     else {
7566       /* Handle two special files . and .. */
7567       if (unixptr[0] == '.') {
7568         if (&unixptr[1] == unixend) {
7569           *vmsptr++ = '[';
7570           *vmsptr++ = ']';
7571           vmslen += 2;
7572           *vmsptr++ = '\0';
7573           return SS$_NORMAL;
7574         }
7575         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7576           *vmsptr++ = '[';
7577           *vmsptr++ = '-';
7578           *vmsptr++ = ']';
7579           vmslen += 3;
7580           *vmsptr++ = '\0';
7581           return SS$_NORMAL;
7582         }
7583       }
7584     }
7585   }
7586   else {        /* Absolute PATH handling */
7587   int sts;
7588   char * nextslash;
7589   int seg_len;
7590     /* Need to find out where root is */
7591
7592     /* In theory, this procedure should never get an absolute POSIX pathname
7593      * that can not be found on the POSIX root.
7594      * In practice, that can not be relied on, and things will show up
7595      * here that are a VMS device name or concealed logical name instead.
7596      * So to make things work, this procedure must be tolerant.
7597      */
7598     esa = PerlMem_malloc(vmspath_len);
7599     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7600
7601     sts = SS$_NORMAL;
7602     nextslash = strchr(&unixptr[1],'/');
7603     seg_len = 0;
7604     if (nextslash != NULL) {
7605     int cmp;
7606       seg_len = nextslash - &unixptr[1];
7607       strncpy(vmspath, unixptr, seg_len + 1);
7608       vmspath[seg_len+1] = 0;
7609       cmp = 1;
7610       if (seg_len == 3) {
7611         cmp = strncmp(vmspath, "dev", 4);
7612         if (cmp == 0) {
7613             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7614             if (sts = SS$_NORMAL)
7615                 return SS$_NORMAL;
7616         }
7617       }
7618       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
7619     }
7620
7621     if ($VMS_STATUS_SUCCESS(sts)) {
7622       /* This is verified to be a real path */
7623
7624       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7625       if ($VMS_STATUS_SUCCESS(sts)) {
7626         strcpy(vmspath, esa);
7627         vmslen = strlen(vmspath);
7628         vmsptr = vmspath + vmslen;
7629         unixptr++;
7630         if (unixptr < lastslash) {
7631         char * rptr;
7632           vmsptr--;
7633           *vmsptr++ = '.';
7634           dir_start = 1;
7635           dir_dot = 1;
7636           if (vmslen > 7) {
7637           int cmp;
7638             rptr = vmsptr - 7;
7639             cmp = strcmp(rptr,"000000.");
7640             if (cmp == 0) {
7641               vmslen -= 7;
7642               vmsptr -= 7;
7643               vmsptr[1] = '\0';
7644             } /* removing 6 zeros */
7645           } /* vmslen < 7, no 6 zeros possible */
7646         } /* Not in a directory */
7647       } /* Posix root found */
7648       else {
7649         /* No posix root, fall back to default directory */
7650         strcpy(vmspath, "SYS$DISK:[");
7651         vmsptr = &vmspath[10];
7652         vmslen = 10;
7653         if (unixptr > lastslash) {
7654            *vmsptr = ']';
7655            vmsptr++;
7656            vmslen++;
7657         }
7658         else {
7659            dir_start = 1;
7660         }
7661       }
7662     } /* end of verified real path handling */
7663     else {
7664     int add_6zero;
7665     int islnm;
7666
7667       /* Ok, we have a device or a concealed root that is not in POSIX
7668        * or we have garbage.  Make the best of it.
7669        */
7670
7671       /* Posix to VMS destroyed this, so copy it again */
7672       strncpy(vmspath, &unixptr[1], seg_len);
7673       vmspath[seg_len] = 0;
7674       vmslen = seg_len;
7675       vmsptr = &vmsptr[vmslen];
7676       islnm = 0;
7677
7678       /* Now do we need to add the fake 6 zero directory to it? */
7679       add_6zero = 1;
7680       if ((*lastslash == '/') && (nextslash < lastslash)) {
7681         /* No there is another directory */
7682         add_6zero = 0;
7683       }
7684       else {
7685       int trnend;
7686       int cmp;
7687
7688         /* now we have foo:bar or foo:[000000]bar to decide from */
7689         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
7690
7691         if (!islnm && !decc_posix_compliant_pathnames) {
7692
7693             cmp = strncmp("bin", vmspath, 4);
7694             if (cmp == 0) {
7695                 /* bin => SYS$SYSTEM: */
7696                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7697             }
7698             else {
7699                 /* tmp => SYS$SCRATCH: */
7700                 cmp = strncmp("tmp", vmspath, 4);
7701                 if (cmp == 0) {
7702                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
7703                 }
7704             }
7705         }
7706
7707         trnend = islnm ? islnm - 1 : 0;
7708
7709         /* if this was a logical name, ']' or '>' must be present */
7710         /* if not a logical name, then assume a device and hope. */
7711         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
7712
7713         /* if log name and trailing '.' then rooted - treat as device */
7714         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
7715
7716         /* Fix me, if not a logical name, a device lookup should be
7717          * done to see if the device is file structured.  If the device
7718          * is not file structured, the 6 zeros should not be put on.
7719          *
7720          * As it is, perl is occasionally looking for dev:[000000]tty.
7721          * which looks a little strange.
7722          *
7723          * Not that easy to detect as "/dev" may be file structured with
7724          * special device files.
7725          */
7726
7727         if ((add_6zero == 0) && (*nextslash == '/') &&
7728             (&nextslash[1] == unixend)) {
7729           /* No real directory present */
7730           add_6zero = 1;
7731         }
7732       }
7733
7734       /* Put the device delimiter on */
7735       *vmsptr++ = ':';
7736       vmslen++;
7737       unixptr = nextslash;
7738       unixptr++;
7739
7740       /* Start directory if needed */
7741       if (!islnm || add_6zero) {
7742         *vmsptr++ = '[';
7743         vmslen++;
7744         dir_start = 1;
7745       }
7746
7747       /* add fake 000000] if needed */
7748       if (add_6zero) {
7749         *vmsptr++ = '0';
7750         *vmsptr++ = '0';
7751         *vmsptr++ = '0';
7752         *vmsptr++ = '0';
7753         *vmsptr++ = '0';
7754         *vmsptr++ = '0';
7755         *vmsptr++ = ']';
7756         vmslen += 7;
7757         dir_start = 0;
7758       }
7759
7760     } /* non-POSIX translation */
7761     PerlMem_free(esa);
7762   } /* End of relative/absolute path handling */
7763
7764   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
7765   int dash_flag;
7766   int in_cnt;
7767   int out_cnt;
7768
7769     dash_flag = 0;
7770
7771     if (dir_start != 0) {
7772
7773       /* First characters in a directory are handled special */
7774       while ((*unixptr == '/') ||
7775              ((*unixptr == '.') &&
7776               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
7777                 (&unixptr[1]==unixend)))) {
7778       int loop_flag;
7779
7780         loop_flag = 0;
7781
7782         /* Skip redundant / in specification */
7783         while ((*unixptr == '/') && (dir_start != 0)) {
7784           loop_flag = 1;
7785           unixptr++;
7786           if (unixptr == lastslash)
7787             break;
7788         }
7789         if (unixptr == lastslash)
7790           break;
7791
7792         /* Skip redundant ./ characters */
7793         while ((*unixptr == '.') &&
7794                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
7795           loop_flag = 1;
7796           unixptr++;
7797           if (unixptr == lastslash)
7798             break;
7799           if (*unixptr == '/')
7800             unixptr++;
7801         }
7802         if (unixptr == lastslash)
7803           break;
7804
7805         /* Skip redundant ../ characters */
7806         while ((*unixptr == '.') && (unixptr[1] == '.') &&
7807              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
7808           /* Set the backing up flag */
7809           loop_flag = 1;
7810           dir_dot = 0;
7811           dash_flag = 1;
7812           *vmsptr++ = '-';
7813           vmslen++;
7814           unixptr++; /* first . */
7815           unixptr++; /* second . */
7816           if (unixptr == lastslash)
7817             break;
7818           if (*unixptr == '/') /* The slash */
7819             unixptr++;
7820         }
7821         if (unixptr == lastslash)
7822           break;
7823
7824         /* To do: Perl expects /.../ to be translated to [...] on VMS */
7825         /* Not needed when VMS is pretending to be UNIX. */
7826
7827         /* Is this loop stuck because of too many dots? */
7828         if (loop_flag == 0) {
7829           /* Exit the loop and pass the rest through */
7830           break;
7831         }
7832       }
7833
7834       /* Are we done with directories yet? */
7835       if (unixptr >= lastslash) {
7836
7837         /* Watch out for trailing dots */
7838         if (dir_dot != 0) {
7839             vmslen --;
7840             vmsptr--;
7841         }
7842         *vmsptr++ = ']';
7843         vmslen++;
7844         dash_flag = 0;
7845         dir_start = 0;
7846         if (*unixptr == '/')
7847           unixptr++;
7848       }
7849       else {
7850         /* Have we stopped backing up? */
7851         if (dash_flag) {
7852           *vmsptr++ = '.';
7853           vmslen++;
7854           dash_flag = 0;
7855           /* dir_start continues to be = 1 */
7856         }
7857         if (*unixptr == '-') {
7858           *vmsptr++ = '^';
7859           *vmsptr++ = *unixptr++;
7860           vmslen += 2;
7861           dir_start = 0;
7862
7863           /* Now are we done with directories yet? */
7864           if (unixptr >= lastslash) {
7865
7866             /* Watch out for trailing dots */
7867             if (dir_dot != 0) {
7868               vmslen --;
7869               vmsptr--;
7870             }
7871
7872             *vmsptr++ = ']';
7873             vmslen++;
7874             dash_flag = 0;
7875             dir_start = 0;
7876           }
7877         }
7878       }
7879     }
7880
7881     /* All done? */
7882     if (unixptr >= unixend)
7883       break;
7884
7885     /* Normal characters - More EFS work probably needed */
7886     dir_start = 0;
7887     dir_dot = 0;
7888
7889     switch(*unixptr) {
7890     case '/':
7891         /* remove multiple / */
7892         while (unixptr[1] == '/') {
7893            unixptr++;
7894         }
7895         if (unixptr == lastslash) {
7896           /* Watch out for trailing dots */
7897           if (dir_dot != 0) {
7898             vmslen --;
7899             vmsptr--;
7900           }
7901           *vmsptr++ = ']';
7902         }
7903         else {
7904           dir_start = 1;
7905           *vmsptr++ = '.';
7906           dir_dot = 1;
7907
7908           /* To do: Perl expects /.../ to be translated to [...] on VMS */
7909           /* Not needed when VMS is pretending to be UNIX. */
7910
7911         }
7912         dash_flag = 0;
7913         if (unixptr != unixend)
7914           unixptr++;
7915         vmslen++;
7916         break;
7917     case '.':
7918         if ((unixptr < lastdot) || (unixptr < lastslash) ||
7919             (&unixptr[1] == unixend)) {
7920           *vmsptr++ = '^';
7921           *vmsptr++ = '.';
7922           vmslen += 2;
7923           unixptr++;
7924
7925           /* trailing dot ==> '^..' on VMS */
7926           if (unixptr == unixend) {
7927             *vmsptr++ = '.';
7928             vmslen++;
7929             unixptr++;
7930           }
7931           break;
7932         }
7933
7934         *vmsptr++ = *unixptr++;
7935         vmslen ++;
7936         break;
7937     case '"':
7938         if (quoted && (&unixptr[1] == unixend)) {
7939             unixptr++;
7940             break;
7941         }
7942         in_cnt = copy_expand_unix_filename_escape
7943                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7944         vmsptr += out_cnt;
7945         unixptr += in_cnt;
7946         break;
7947     case '~':
7948     case ';':
7949     case '\\':
7950     case '?':
7951     case ' ':
7952     default:
7953         in_cnt = copy_expand_unix_filename_escape
7954                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7955         vmsptr += out_cnt;
7956         unixptr += in_cnt;
7957         break;
7958     }
7959   }
7960
7961   /* Make sure directory is closed */
7962   if (unixptr == lastslash) {
7963     char *vmsptr2;
7964     vmsptr2 = vmsptr - 1;
7965
7966     if (*vmsptr2 != ']') {
7967       *vmsptr2--;
7968
7969       /* directories do not end in a dot bracket */
7970       if (*vmsptr2 == '.') {
7971         vmsptr2--;
7972
7973         /* ^. is allowed */
7974         if (*vmsptr2 != '^') {
7975           vmsptr--; /* back up over the dot */
7976         }
7977       }
7978       *vmsptr++ = ']';
7979     }
7980   }
7981   else {
7982     char *vmsptr2;
7983     /* Add a trailing dot if a file with no extension */
7984     vmsptr2 = vmsptr - 1;
7985     if ((vmslen > 1) &&
7986         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
7987         (*vmsptr2 != ')') && (*lastdot != '.')) {
7988         *vmsptr++ = '.';
7989         vmslen++;
7990     }
7991   }
7992
7993   *vmsptr = '\0';
7994   return SS$_NORMAL;
7995 }
7996 #endif
7997
7998  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
7999 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
8000 {
8001 char * result;
8002 int utf8_flag;
8003
8004    /* If a UTF8 flag is being passed, honor it */
8005    utf8_flag = 0;
8006    if (utf8_fl != NULL) {
8007      utf8_flag = *utf8_fl;
8008     *utf8_fl = 0;
8009    }
8010
8011    if (utf8_flag) {
8012      /* If there is a possibility of UTF8, then if any UTF8 characters
8013         are present, then they must be converted to VTF-7
8014       */
8015      result = strcpy(rslt, path); /* FIX-ME */
8016    }
8017    else
8018      result = strcpy(rslt, path);
8019
8020    return result;
8021 }
8022
8023
8024
8025 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8026 static char *int_tovmsspec
8027    (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
8028   char *dirend;
8029   char *lastdot;
8030   char *vms_delim;
8031   register char *cp1;
8032   const char *cp2;
8033   unsigned long int infront = 0, hasdir = 1;
8034   int rslt_len;
8035   int no_type_seen;
8036   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8037   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8038
8039   if (vms_debug_fileify) {
8040       if (path == NULL)
8041           fprintf(stderr, "int_tovmsspec: path = NULL\n");
8042       else
8043           fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8044   }
8045
8046   if (path == NULL) {
8047       /* If we fail, we should be setting errno */
8048       set_errno(EINVAL);
8049       set_vaxc_errno(SS$_BADPARAM);
8050       return NULL;
8051   }
8052   rslt_len = VMS_MAXRSS-1;
8053
8054   /* '.' and '..' are "[]" and "[-]" for a quick check */
8055   if (path[0] == '.') {
8056     if (path[1] == '\0') {
8057       strcpy(rslt,"[]");
8058       if (utf8_flag != NULL)
8059         *utf8_flag = 0;
8060       return rslt;
8061     }
8062     else {
8063       if (path[1] == '.' && path[2] == '\0') {
8064         strcpy(rslt,"[-]");
8065         if (utf8_flag != NULL)
8066            *utf8_flag = 0;
8067         return rslt;
8068       }
8069     }
8070   }
8071
8072    /* Posix specifications are now a native VMS format */
8073   /*--------------------------------------------------*/
8074 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8075   if (decc_posix_compliant_pathnames) {
8076     if (strncmp(path,"\"^UP^",5) == 0) {
8077       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8078       return rslt;
8079     }
8080   }
8081 #endif
8082
8083   /* This is really the only way to see if this is already in VMS format */
8084   sts = vms_split_path
8085        (path,
8086         &v_spec,
8087         &v_len,
8088         &r_spec,
8089         &r_len,
8090         &d_spec,
8091         &d_len,
8092         &n_spec,
8093         &n_len,
8094         &e_spec,
8095         &e_len,
8096         &vs_spec,
8097         &vs_len);
8098   if (sts == 0) {
8099     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8100        replacement, because the above parse just took care of most of
8101        what is needed to do vmspath when the specification is already
8102        in VMS format.
8103
8104        And if it is not already, it is easier to do the conversion as
8105        part of this routine than to call this routine and then work on
8106        the result.
8107      */
8108
8109     /* If VMS punctuation was found, it is already VMS format */
8110     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8111       if (utf8_flag != NULL)
8112         *utf8_flag = 0;
8113       strcpy(rslt, path);
8114       if (vms_debug_fileify) {
8115           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8116       }
8117       return rslt;
8118     }
8119     /* Now, what to do with trailing "." cases where there is no
8120        extension?  If this is a UNIX specification, and EFS characters
8121        are enabled, then the trailing "." should be converted to a "^.".
8122        But if this was already a VMS specification, then it should be
8123        left alone.
8124
8125        So in the case of ambiguity, leave the specification alone.
8126      */
8127
8128
8129     /* If there is a possibility of UTF8, then if any UTF8 characters
8130         are present, then they must be converted to VTF-7
8131      */
8132     if (utf8_flag != NULL)
8133       *utf8_flag = 0;
8134     strcpy(rslt, path);
8135     if (vms_debug_fileify) {
8136         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8137     }
8138     return rslt;
8139   }
8140
8141   dirend = strrchr(path,'/');
8142
8143   if (dirend == NULL) {
8144      char *macro_start;
8145      int has_macro;
8146
8147      /* If we get here with no UNIX directory delimiters, then this is
8148         not a complete file specification, either garbage a UNIX glob
8149         specification that can not be converted to a VMS wildcard, or
8150         it a UNIX shell macro.  MakeMaker wants shell macros passed
8151         through AS-IS,
8152
8153         utf8 flag setting needs to be preserved.
8154       */
8155       hasdir = 0;
8156
8157       has_macro = 0;
8158       macro_start = strchr(path,'$');
8159       if (macro_start != NULL) {
8160           if (macro_start[1] == '(') {
8161               has_macro = 1;
8162           }
8163       }
8164       if ((decc_efs_charset == 0) || (has_macro)) {
8165           strcpy(rslt, path);
8166           if (vms_debug_fileify) {
8167               fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8168           }
8169           return rslt;
8170       }
8171   }
8172
8173 /* If POSIX mode active, handle the conversion */
8174 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8175   if (decc_efs_charset) {
8176     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8177     if (vms_debug_fileify) {
8178         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8179     }
8180     return rslt;
8181   }
8182 #endif
8183
8184   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
8185     if (!*(dirend+2)) dirend +=2;
8186     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8187     if (decc_efs_charset == 0) {
8188       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8189     }
8190   }
8191
8192   cp1 = rslt;
8193   cp2 = path;
8194   lastdot = strrchr(cp2,'.');
8195   if (*cp2 == '/') {
8196     char *trndev;
8197     int islnm, rooted;
8198     STRLEN trnend;
8199
8200     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8201     if (!*(cp2+1)) {
8202       if (decc_disable_posix_root) {
8203         strcpy(rslt,"sys$disk:[000000]");
8204       }
8205       else {
8206         strcpy(rslt,"sys$posix_root:[000000]");
8207       }
8208       if (utf8_flag != NULL)
8209         *utf8_flag = 0;
8210       if (vms_debug_fileify) {
8211           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8212       }
8213       return rslt;
8214     }
8215     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8216     *cp1 = '\0';
8217     trndev = PerlMem_malloc(VMS_MAXRSS);
8218     if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8219     islnm =  simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8220
8221      /* DECC special handling */
8222     if (!islnm) {
8223       if (strcmp(rslt,"bin") == 0) {
8224         strcpy(rslt,"sys$system");
8225         cp1 = rslt + 10;
8226         *cp1 = 0;
8227         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8228       }
8229       else if (strcmp(rslt,"tmp") == 0) {
8230         strcpy(rslt,"sys$scratch");
8231         cp1 = rslt + 11;
8232         *cp1 = 0;
8233         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8234       }
8235       else if (!decc_disable_posix_root) {
8236         strcpy(rslt, "sys$posix_root");
8237         cp1 = rslt + 14;
8238         *cp1 = 0;
8239         cp2 = path;
8240         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8241         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8242       }
8243       else if (strcmp(rslt,"dev") == 0) {
8244         if (strncmp(cp2,"/null", 5) == 0) {
8245           if ((cp2[5] == 0) || (cp2[5] == '/')) {
8246             strcpy(rslt,"NLA0");
8247             cp1 = rslt + 4;
8248             *cp1 = 0;
8249             cp2 = cp2 + 5;
8250             islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8251           }
8252         }
8253       }
8254     }
8255
8256     trnend = islnm ? strlen(trndev) - 1 : 0;
8257     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8258     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8259     /* If the first element of the path is a logical name, determine
8260      * whether it has to be translated so we can add more directories. */
8261     if (!islnm || rooted) {
8262       *(cp1++) = ':';
8263       *(cp1++) = '[';
8264       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8265       else cp2++;
8266     }
8267     else {
8268       if (cp2 != dirend) {
8269         strcpy(rslt,trndev);
8270         cp1 = rslt + trnend;
8271         if (*cp2 != 0) {
8272           *(cp1++) = '.';
8273           cp2++;
8274         }
8275       }
8276       else {
8277         if (decc_disable_posix_root) {
8278           *(cp1++) = ':';
8279           hasdir = 0;
8280         }
8281       }
8282     }
8283     PerlMem_free(trndev);
8284   }
8285   else {
8286     *(cp1++) = '[';
8287     if (*cp2 == '.') {
8288       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8289         cp2 += 2;         /* skip over "./" - it's redundant */
8290         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8291       }
8292       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8293         *(cp1++) = '-';                                 /* "../" --> "-" */
8294         cp2 += 3;
8295       }
8296       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8297                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8298         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8299         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8300         cp2 += 4;
8301       }
8302       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8303         /* Escape the extra dots in EFS file specifications */
8304         *(cp1++) = '^';
8305       }
8306       if (cp2 > dirend) cp2 = dirend;
8307     }
8308     else *(cp1++) = '.';
8309   }
8310   for (; cp2 < dirend; cp2++) {
8311     if (*cp2 == '/') {
8312       if (*(cp2-1) == '/') continue;
8313       if (*(cp1-1) != '.') *(cp1++) = '.';
8314       infront = 0;
8315     }
8316     else if (!infront && *cp2 == '.') {
8317       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8318       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8319       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8320         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8321         else if (*(cp1-2) == '[') *(cp1-1) = '-';
8322         else {  /* back up over previous directory name */
8323           cp1--;
8324           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
8325           if (*(cp1-1) == '[') {
8326             memcpy(cp1,"000000.",7);
8327             cp1 += 7;
8328           }
8329         }
8330         cp2 += 2;
8331         if (cp2 == dirend) break;
8332       }
8333       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8334                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8335         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8336         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8337         if (!*(cp2+3)) {
8338           *(cp1++) = '.';  /* Simulate trailing '/' */
8339           cp2 += 2;  /* for loop will incr this to == dirend */
8340         }
8341         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8342       }
8343       else {
8344         if (decc_efs_charset == 0)
8345           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8346         else {
8347           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
8348           *(cp1++) = '.';
8349         }
8350       }
8351     }
8352     else {
8353       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
8354       if (*cp2 == '.') {
8355         if (decc_efs_charset == 0)
8356           *(cp1++) = '_';
8357         else {
8358           *(cp1++) = '^';
8359           *(cp1++) = '.';
8360         }
8361       }
8362       else                  *(cp1++) =  *cp2;
8363       infront = 1;
8364     }
8365   }
8366   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8367   if (hasdir) *(cp1++) = ']';
8368   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
8369   /* fixme for ODS5 */
8370   no_type_seen = 0;
8371   if (cp2 > lastdot)
8372     no_type_seen = 1;
8373   while (*cp2) {
8374     switch(*cp2) {
8375     case '?':
8376         if (decc_efs_charset == 0)
8377           *(cp1++) = '%';
8378         else
8379           *(cp1++) = '?';
8380         cp2++;
8381     case ' ':
8382         *(cp1)++ = '^';
8383         *(cp1)++ = '_';
8384         cp2++;
8385         break;
8386     case '.':
8387         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8388             decc_readdir_dropdotnotype) {
8389           *(cp1)++ = '^';
8390           *(cp1)++ = '.';
8391           cp2++;
8392
8393           /* trailing dot ==> '^..' on VMS */
8394           if (*cp2 == '\0') {
8395             *(cp1++) = '.';
8396             no_type_seen = 0;
8397           }
8398         }
8399         else {
8400           *(cp1++) = *(cp2++);
8401           no_type_seen = 0;
8402         }
8403         break;
8404     case '$':
8405          /* This could be a macro to be passed through */
8406         *(cp1++) = *(cp2++);
8407         if (*cp2 == '(') {
8408         const char * save_cp2;
8409         char * save_cp1;
8410         int is_macro;
8411
8412             /* paranoid check */
8413             save_cp2 = cp2;
8414             save_cp1 = cp1;
8415             is_macro = 0;
8416
8417             /* Test through */
8418             *(cp1++) = *(cp2++);
8419             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8420                 *(cp1++) = *(cp2++);
8421                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8422                     *(cp1++) = *(cp2++);
8423                 }
8424                 if (*cp2 == ')') {
8425                     *(cp1++) = *(cp2++);
8426                     is_macro = 1;
8427                 }
8428             }
8429             if (is_macro == 0) {
8430                 /* Not really a macro - never mind */
8431                 cp2 = save_cp2;
8432                 cp1 = save_cp1;
8433             }
8434         }
8435         break;
8436     case '\"':
8437     case '~':
8438     case '`':
8439     case '!':
8440     case '#':
8441     case '%':
8442     case '^':
8443         /* Don't escape again if following character is
8444          * already something we escape.
8445          */
8446         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8447             *(cp1++) = *(cp2++);
8448             break;
8449         }
8450         /* But otherwise fall through and escape it. */
8451     case '&':
8452     case '(':
8453     case ')':
8454     case '=':
8455     case '+':
8456     case '\'':
8457     case '@':
8458     case '[':
8459     case ']':
8460     case '{':
8461     case '}':
8462     case ':':
8463     case '\\':
8464     case '|':
8465     case '<':
8466     case '>':
8467         *(cp1++) = '^';
8468         *(cp1++) = *(cp2++);
8469         break;
8470     case ';':
8471         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8472          * which is wrong.  UNIX notation should be ".dir." unless
8473          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8474          * changing this behavior could break more things at this time.
8475          * efs character set effectively does not allow "." to be a version
8476          * delimiter as a further complication about changing this.
8477          */
8478         if (decc_filename_unix_report != 0) {
8479           *(cp1++) = '^';
8480         }
8481         *(cp1++) = *(cp2++);
8482         break;
8483     default:
8484         *(cp1++) = *(cp2++);
8485     }
8486   }
8487   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8488   char *lcp1;
8489     lcp1 = cp1;
8490     lcp1--;
8491      /* Fix me for "^]", but that requires making sure that you do
8492       * not back up past the start of the filename
8493       */
8494     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8495       *cp1++ = '.';
8496   }
8497   *cp1 = '\0';
8498
8499   if (utf8_flag != NULL)
8500     *utf8_flag = 0;
8501   if (vms_debug_fileify) {
8502       fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8503   }
8504   return rslt;
8505
8506 }  /* end of int_tovmsspec() */
8507
8508
8509 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8510 static char *mp_do_tovmsspec
8511    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
8512   static char __tovmsspec_retbuf[VMS_MAXRSS];
8513     char * vmsspec, *ret_spec, *ret_buf;
8514
8515     vmsspec = NULL;
8516     ret_buf = buf;
8517     if (ret_buf == NULL) {
8518         if (ts) {
8519             Newx(vmsspec, VMS_MAXRSS, char);
8520             if (vmsspec == NULL)
8521                 _ckvmssts(SS$_INSFMEM);
8522             ret_buf = vmsspec;
8523         } else {
8524             ret_buf = __tovmsspec_retbuf;
8525         }
8526     }
8527
8528     ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
8529
8530     if (ret_spec == NULL) {
8531        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
8532        if (vmsspec)
8533            Safefree(vmsspec);
8534     }
8535
8536     return ret_spec;
8537
8538 }  /* end of mp_do_tovmsspec() */
8539 /*}}}*/
8540 /* External entry points */
8541 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8542   { return do_tovmsspec(path,buf,0,NULL); }
8543 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8544   { return do_tovmsspec(path,buf,1,NULL); }
8545 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8546   { return do_tovmsspec(path,buf,0,utf8_fl); }
8547 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8548   { return do_tovmsspec(path,buf,1,utf8_fl); }
8549
8550 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8551 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8552   static char __tovmspath_retbuf[VMS_MAXRSS];
8553   int vmslen;
8554   char *pathified, *vmsified, *cp;
8555
8556   if (path == NULL) return NULL;
8557   pathified = PerlMem_malloc(VMS_MAXRSS);
8558   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8559   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
8560     PerlMem_free(pathified);
8561     return NULL;
8562   }
8563
8564   vmsified = NULL;
8565   if (buf == NULL)
8566      Newx(vmsified, VMS_MAXRSS, char);
8567   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8568     PerlMem_free(pathified);
8569     if (vmsified) Safefree(vmsified);
8570     return NULL;
8571   }
8572   PerlMem_free(pathified);
8573   if (buf) {
8574     return buf;
8575   }
8576   else if (ts) {
8577     vmslen = strlen(vmsified);
8578     Newx(cp,vmslen+1,char);
8579     memcpy(cp,vmsified,vmslen);
8580     cp[vmslen] = '\0';
8581     Safefree(vmsified);
8582     return cp;
8583   }
8584   else {
8585     strcpy(__tovmspath_retbuf,vmsified);
8586     Safefree(vmsified);
8587     return __tovmspath_retbuf;
8588   }
8589
8590 }  /* end of do_tovmspath() */
8591 /*}}}*/
8592 /* External entry points */
8593 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8594   { return do_tovmspath(path,buf,0, NULL); }
8595 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8596   { return do_tovmspath(path,buf,1, NULL); }
8597 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8598   { return do_tovmspath(path,buf,0,utf8_fl); }
8599 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8600   { return do_tovmspath(path,buf,1,utf8_fl); }
8601
8602
8603 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8604 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8605   static char __tounixpath_retbuf[VMS_MAXRSS];
8606   int unixlen;
8607   char *pathified, *unixified, *cp;
8608
8609   if (path == NULL) return NULL;
8610   pathified = PerlMem_malloc(VMS_MAXRSS);
8611   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8612   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
8613     PerlMem_free(pathified);
8614     return NULL;
8615   }
8616
8617   unixified = NULL;
8618   if (buf == NULL) {
8619       Newx(unixified, VMS_MAXRSS, char);
8620   }
8621   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
8622     PerlMem_free(pathified);
8623     if (unixified) Safefree(unixified);
8624     return NULL;
8625   }
8626   PerlMem_free(pathified);
8627   if (buf) {
8628     return buf;
8629   }
8630   else if (ts) {
8631     unixlen = strlen(unixified);
8632     Newx(cp,unixlen+1,char);
8633     memcpy(cp,unixified,unixlen);
8634     cp[unixlen] = '\0';
8635     Safefree(unixified);
8636     return cp;
8637   }
8638   else {
8639     strcpy(__tounixpath_retbuf,unixified);
8640     Safefree(unixified);
8641     return __tounixpath_retbuf;
8642   }
8643
8644 }  /* end of do_tounixpath() */
8645 /*}}}*/
8646 /* External entry points */
8647 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8648   { return do_tounixpath(path,buf,0,NULL); }
8649 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8650   { return do_tounixpath(path,buf,1,NULL); }
8651 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8652   { return do_tounixpath(path,buf,0,utf8_fl); }
8653 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8654   { return do_tounixpath(path,buf,1,utf8_fl); }
8655
8656 /*
8657  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
8658  *
8659  *****************************************************************************
8660  *                                                                           *
8661  *  Copyright (C) 1989-1994, 2007 by                                         *
8662  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
8663  *                                                                           *
8664  *  Permission is hereby granted for the reproduction of this software       *
8665  *  on condition that this copyright notice is included in source            *
8666  *  distributions of the software.  The code may be modified and             *
8667  *  distributed under the same terms as Perl itself.                         *
8668  *                                                                           *
8669  *  27-Aug-1994 Modified for inclusion in perl5                              *
8670  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
8671  *****************************************************************************
8672  */
8673
8674 /*
8675  * getredirection() is intended to aid in porting C programs
8676  * to VMS (Vax-11 C).  The native VMS environment does not support
8677  * '>' and '<' I/O redirection, or command line wild card expansion,
8678  * or a command line pipe mechanism using the '|' AND background
8679  * command execution '&'.  All of these capabilities are provided to any
8680  * C program which calls this procedure as the first thing in the
8681  * main program.
8682  * The piping mechanism will probably work with almost any 'filter' type
8683  * of program.  With suitable modification, it may useful for other
8684  * portability problems as well.
8685  *
8686  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
8687  */
8688 struct list_item
8689     {
8690     struct list_item *next;
8691     char *value;
8692     };
8693
8694 static void add_item(struct list_item **head,
8695                      struct list_item **tail,
8696                      char *value,
8697                      int *count);
8698
8699 static void mp_expand_wild_cards(pTHX_ char *item,
8700                                 struct list_item **head,
8701                                 struct list_item **tail,
8702                                 int *count);
8703
8704 static int background_process(pTHX_ int argc, char **argv);
8705
8706 static void pipe_and_fork(pTHX_ char **cmargv);
8707
8708 /*{{{ void getredirection(int *ac, char ***av)*/
8709 static void
8710 mp_getredirection(pTHX_ int *ac, char ***av)
8711 /*
8712  * Process vms redirection arg's.  Exit if any error is seen.
8713  * If getredirection() processes an argument, it is erased
8714  * from the vector.  getredirection() returns a new argc and argv value.
8715  * In the event that a background command is requested (by a trailing "&"),
8716  * this routine creates a background subprocess, and simply exits the program.
8717  *
8718  * Warning: do not try to simplify the code for vms.  The code
8719  * presupposes that getredirection() is called before any data is
8720  * read from stdin or written to stdout.
8721  *
8722  * Normal usage is as follows:
8723  *
8724  *      main(argc, argv)
8725  *      int             argc;
8726  *      char            *argv[];
8727  *      {
8728  *              getredirection(&argc, &argv);
8729  *      }
8730  */
8731 {
8732     int                 argc = *ac;     /* Argument Count         */
8733     char                **argv = *av;   /* Argument Vector        */
8734     char                *ap;            /* Argument pointer       */
8735     int                 j;              /* argv[] index           */
8736     int                 item_count = 0; /* Count of Items in List */
8737     struct list_item    *list_head = 0; /* First Item in List       */
8738     struct list_item    *list_tail;     /* Last Item in List        */
8739     char                *in = NULL;     /* Input File Name          */
8740     char                *out = NULL;    /* Output File Name         */
8741     char                *outmode = "w"; /* Mode to Open Output File */
8742     char                *err = NULL;    /* Error File Name          */
8743     char                *errmode = "w"; /* Mode to Open Error File  */
8744     int                 cmargc = 0;     /* Piped Command Arg Count  */
8745     char                **cmargv = NULL;/* Piped Command Arg Vector */
8746
8747     /*
8748      * First handle the case where the last thing on the line ends with
8749      * a '&'.  This indicates the desire for the command to be run in a
8750      * subprocess, so we satisfy that desire.
8751      */
8752     ap = argv[argc-1];
8753     if (0 == strcmp("&", ap))
8754        exit(background_process(aTHX_ --argc, argv));
8755     if (*ap && '&' == ap[strlen(ap)-1])
8756         {
8757         ap[strlen(ap)-1] = '\0';
8758        exit(background_process(aTHX_ argc, argv));
8759         }
8760     /*
8761      * Now we handle the general redirection cases that involve '>', '>>',
8762      * '<', and pipes '|'.
8763      */
8764     for (j = 0; j < argc; ++j)
8765         {
8766         if (0 == strcmp("<", argv[j]))
8767             {
8768             if (j+1 >= argc)
8769                 {
8770                 fprintf(stderr,"No input file after < on command line");
8771                 exit(LIB$_WRONUMARG);
8772                 }
8773             in = argv[++j];
8774             continue;
8775             }
8776         if ('<' == *(ap = argv[j]))
8777             {
8778             in = 1 + ap;
8779             continue;
8780             }
8781         if (0 == strcmp(">", ap))
8782             {
8783             if (j+1 >= argc)
8784                 {
8785                 fprintf(stderr,"No output file after > on command line");
8786                 exit(LIB$_WRONUMARG);
8787                 }
8788             out = argv[++j];
8789             continue;
8790             }
8791         if ('>' == *ap)
8792             {
8793             if ('>' == ap[1])
8794                 {
8795                 outmode = "a";
8796                 if ('\0' == ap[2])
8797                     out = argv[++j];
8798                 else
8799                     out = 2 + ap;
8800                 }
8801             else
8802                 out = 1 + ap;
8803             if (j >= argc)
8804                 {
8805                 fprintf(stderr,"No output file after > or >> on command line");
8806                 exit(LIB$_WRONUMARG);
8807                 }
8808             continue;
8809             }
8810         if (('2' == *ap) && ('>' == ap[1]))
8811             {
8812             if ('>' == ap[2])
8813                 {
8814                 errmode = "a";
8815                 if ('\0' == ap[3])
8816                     err = argv[++j];
8817                 else
8818                     err = 3 + ap;
8819                 }
8820             else
8821                 if ('\0' == ap[2])
8822                     err = argv[++j];
8823                 else
8824                     err = 2 + ap;
8825             if (j >= argc)
8826                 {
8827                 fprintf(stderr,"No output file after 2> or 2>> on command line");
8828                 exit(LIB$_WRONUMARG);
8829                 }
8830             continue;
8831             }
8832         if (0 == strcmp("|", argv[j]))
8833             {
8834             if (j+1 >= argc)
8835                 {
8836                 fprintf(stderr,"No command into which to pipe on command line");
8837                 exit(LIB$_WRONUMARG);
8838                 }
8839             cmargc = argc-(j+1);
8840             cmargv = &argv[j+1];
8841             argc = j;
8842             continue;
8843             }
8844         if ('|' == *(ap = argv[j]))
8845             {
8846             ++argv[j];
8847             cmargc = argc-j;
8848             cmargv = &argv[j];
8849             argc = j;
8850             continue;
8851             }
8852         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
8853         }
8854     /*
8855      * Allocate and fill in the new argument vector, Some Unix's terminate
8856      * the list with an extra null pointer.
8857      */
8858     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
8859     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8860     *av = argv;
8861     for (j = 0; j < item_count; ++j, list_head = list_head->next)
8862         argv[j] = list_head->value;
8863     *ac = item_count;
8864     if (cmargv != NULL)
8865         {
8866         if (out != NULL)
8867             {
8868             fprintf(stderr,"'|' and '>' may not both be specified on command line");
8869             exit(LIB$_INVARGORD);
8870             }
8871         pipe_and_fork(aTHX_ cmargv);
8872         }
8873
8874     /* Check for input from a pipe (mailbox) */
8875
8876     if (in == NULL && 1 == isapipe(0))
8877         {
8878         char mbxname[L_tmpnam];
8879         long int bufsize;
8880         long int dvi_item = DVI$_DEVBUFSIZ;
8881         $DESCRIPTOR(mbxnam, "");
8882         $DESCRIPTOR(mbxdevnam, "");
8883
8884         /* Input from a pipe, reopen it in binary mode to disable       */
8885         /* carriage control processing.                                 */
8886
8887         fgetname(stdin, mbxname);
8888         mbxnam.dsc$a_pointer = mbxname;
8889         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
8890         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
8891         mbxdevnam.dsc$a_pointer = mbxname;
8892         mbxdevnam.dsc$w_length = sizeof(mbxname);
8893         dvi_item = DVI$_DEVNAM;
8894         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
8895         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
8896         set_errno(0);
8897         set_vaxc_errno(1);
8898         freopen(mbxname, "rb", stdin);
8899         if (errno != 0)
8900             {
8901             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
8902             exit(vaxc$errno);
8903             }
8904         }
8905     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
8906         {
8907         fprintf(stderr,"Can't open input file %s as stdin",in);
8908         exit(vaxc$errno);
8909         }
8910     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
8911         {
8912         fprintf(stderr,"Can't open output file %s as stdout",out);
8913         exit(vaxc$errno);
8914         }
8915         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
8916
8917     if (err != NULL) {
8918         if (strcmp(err,"&1") == 0) {
8919             dup2(fileno(stdout), fileno(stderr));
8920             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
8921         } else {
8922         FILE *tmperr;
8923         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
8924             {
8925             fprintf(stderr,"Can't open error file %s as stderr",err);
8926             exit(vaxc$errno);
8927             }
8928             fclose(tmperr);
8929            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
8930                 {
8931                 exit(vaxc$errno);
8932                 }
8933             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
8934         }
8935         }
8936 #ifdef ARGPROC_DEBUG
8937     PerlIO_printf(Perl_debug_log, "Arglist:\n");
8938     for (j = 0; j < *ac;  ++j)
8939         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
8940 #endif
8941    /* Clear errors we may have hit expanding wildcards, so they don't
8942       show up in Perl's $! later */
8943    set_errno(0); set_vaxc_errno(1);
8944 }  /* end of getredirection() */
8945 /*}}}*/
8946
8947 static void add_item(struct list_item **head,
8948                      struct list_item **tail,
8949                      char *value,
8950                      int *count)
8951 {
8952     if (*head == 0)
8953         {
8954         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8955         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8956         *tail = *head;
8957         }
8958     else {
8959         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8960         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8961         *tail = (*tail)->next;
8962         }
8963     (*tail)->value = value;
8964     ++(*count);
8965 }
8966
8967 static void mp_expand_wild_cards(pTHX_ char *item,
8968                               struct list_item **head,
8969                               struct list_item **tail,
8970                               int *count)
8971 {
8972 int expcount = 0;
8973 unsigned long int context = 0;
8974 int isunix = 0;
8975 int item_len = 0;
8976 char *had_version;
8977 char *had_device;
8978 int had_directory;
8979 char *devdir,*cp;
8980 char *vmsspec;
8981 $DESCRIPTOR(filespec, "");
8982 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
8983 $DESCRIPTOR(resultspec, "");
8984 unsigned long int lff_flags = 0;
8985 int sts;
8986 int rms_sts;
8987
8988 #ifdef VMS_LONGNAME_SUPPORT
8989     lff_flags = LIB$M_FIL_LONG_NAMES;
8990 #endif
8991
8992     for (cp = item; *cp; cp++) {
8993         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
8994         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
8995     }
8996     if (!*cp || isspace(*cp))
8997         {
8998         add_item(head, tail, item, count);
8999         return;
9000         }
9001     else
9002         {
9003      /* "double quoted" wild card expressions pass as is */
9004      /* From DCL that means using e.g.:                  */
9005      /* perl program """perl.*"""                        */
9006      item_len = strlen(item);
9007      if ( '"' == *item && '"' == item[item_len-1] )
9008        {
9009        item++;
9010        item[item_len-2] = '\0';
9011        add_item(head, tail, item, count);
9012        return;
9013        }
9014      }
9015     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9016     resultspec.dsc$b_class = DSC$K_CLASS_D;
9017     resultspec.dsc$a_pointer = NULL;
9018     vmsspec = PerlMem_malloc(VMS_MAXRSS);
9019     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9020     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9021       filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9022     if (!isunix || !filespec.dsc$a_pointer)
9023       filespec.dsc$a_pointer = item;
9024     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9025     /*
9026      * Only return version specs, if the caller specified a version
9027      */
9028     had_version = strchr(item, ';');
9029     /*
9030      * Only return device and directory specs, if the caller specifed either.
9031      */
9032     had_device = strchr(item, ':');
9033     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9034
9035     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9036                                  (&filespec, &resultspec, &context,
9037                                   &defaultspec, 0, &rms_sts, &lff_flags)))
9038         {
9039         char *string;
9040         char *c;
9041
9042         string = PerlMem_malloc(resultspec.dsc$w_length+1);
9043         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9044         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
9045         string[resultspec.dsc$w_length] = '\0';
9046         if (NULL == had_version)
9047             *(strrchr(string, ';')) = '\0';
9048         if ((!had_directory) && (had_device == NULL))
9049             {
9050             if (NULL == (devdir = strrchr(string, ']')))
9051                 devdir = strrchr(string, '>');
9052             strcpy(string, devdir + 1);
9053             }
9054         /*
9055          * Be consistent with what the C RTL has already done to the rest of
9056          * the argv items and lowercase all of these names.
9057          */
9058         if (!decc_efs_case_preserve) {
9059             for (c = string; *c; ++c)
9060             if (isupper(*c))
9061                 *c = tolower(*c);
9062         }
9063         if (isunix) trim_unixpath(string,item,1);
9064         add_item(head, tail, string, count);
9065         ++expcount;
9066     }
9067     PerlMem_free(vmsspec);
9068     if (sts != RMS$_NMF)
9069         {
9070         set_vaxc_errno(sts);
9071         switch (sts)
9072             {
9073             case RMS$_FNF: case RMS$_DNF:
9074                 set_errno(ENOENT); break;
9075             case RMS$_DIR:
9076                 set_errno(ENOTDIR); break;
9077             case RMS$_DEV:
9078                 set_errno(ENODEV); break;
9079             case RMS$_FNM: case RMS$_SYN:
9080                 set_errno(EINVAL); break;
9081             case RMS$_PRV:
9082                 set_errno(EACCES); break;
9083             default:
9084                 _ckvmssts_noperl(sts);
9085             }
9086         }
9087     if (expcount == 0)
9088         add_item(head, tail, item, count);
9089     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9090     _ckvmssts_noperl(lib$find_file_end(&context));
9091 }
9092
9093 static int child_st[2];/* Event Flag set when child process completes   */
9094
9095 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
9096
9097 static unsigned long int exit_handler(int *status)
9098 {
9099 short iosb[4];
9100
9101     if (0 == child_st[0])
9102         {
9103 #ifdef ARGPROC_DEBUG
9104         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
9105 #endif
9106         fflush(stdout);     /* Have to flush pipe for binary data to    */
9107                             /* terminate properly -- <tp@mccall.com>    */
9108         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
9109         sys$dassgn(child_chan);
9110         fclose(stdout);
9111         sys$synch(0, child_st);
9112         }
9113     return(1);
9114 }
9115
9116 static void sig_child(int chan)
9117 {
9118 #ifdef ARGPROC_DEBUG
9119     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
9120 #endif
9121     if (child_st[0] == 0)
9122         child_st[0] = 1;
9123 }
9124
9125 static struct exit_control_block exit_block =
9126     {
9127     0,
9128     exit_handler,
9129     1,
9130     &exit_block.exit_status,
9131     0
9132     };
9133
9134 static void
9135 pipe_and_fork(pTHX_ char **cmargv)
9136 {
9137     PerlIO *fp;
9138     struct dsc$descriptor_s *vmscmd;
9139     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9140     int sts, j, l, ismcr, quote, tquote = 0;
9141
9142     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9143     vms_execfree(vmscmd);
9144
9145     j = l = 0;
9146     p = subcmd;
9147     q = cmargv[0];
9148     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
9149               && toupper(*(q+2)) == 'R' && !*(q+3);
9150
9151     while (q && l < MAX_DCL_LINE_LENGTH) {
9152         if (!*q) {
9153             if (j > 0 && quote) {
9154                 *p++ = '"';
9155                 l++;
9156             }
9157             q = cmargv[++j];
9158             if (q) {
9159                 if (ismcr && j > 1) quote = 1;
9160                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
9161                 *p++ = ' ';
9162                 l++;
9163                 if (quote || tquote) {
9164                     *p++ = '"';
9165                     l++;
9166                 }
9167             }
9168         } else {
9169             if ((quote||tquote) && *q == '"') {
9170                 *p++ = '"';
9171                 l++;
9172             }
9173             *p++ = *q++;
9174             l++;
9175         }
9176     }
9177     *p = '\0';
9178
9179     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9180     if (fp == NULL) {
9181         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9182     }
9183 }
9184
9185 static int background_process(pTHX_ int argc, char **argv)
9186 {
9187 char command[MAX_DCL_SYMBOL + 1] = "$";
9188 $DESCRIPTOR(value, "");
9189 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9190 static $DESCRIPTOR(null, "NLA0:");
9191 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9192 char pidstring[80];
9193 $DESCRIPTOR(pidstr, "");
9194 int pid;
9195 unsigned long int flags = 17, one = 1, retsts;
9196 int len;
9197
9198     strcat(command, argv[0]);
9199     len = strlen(command);
9200     while (--argc && (len < MAX_DCL_SYMBOL))
9201         {
9202         strcat(command, " \"");
9203         strcat(command, *(++argv));
9204         strcat(command, "\"");
9205         len = strlen(command);
9206         }
9207     value.dsc$a_pointer = command;
9208     value.dsc$w_length = strlen(value.dsc$a_pointer);
9209     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9210     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9211     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9212         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9213     }
9214     else {
9215         _ckvmssts_noperl(retsts);
9216     }
9217 #ifdef ARGPROC_DEBUG
9218     PerlIO_printf(Perl_debug_log, "%s\n", command);
9219 #endif
9220     sprintf(pidstring, "%08X", pid);
9221     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9222     pidstr.dsc$a_pointer = pidstring;
9223     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9224     lib$set_symbol(&pidsymbol, &pidstr);
9225     return(SS$_NORMAL);
9226 }
9227 /*}}}*/
9228 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9229
9230
9231 /* OS-specific initialization at image activation (not thread startup) */
9232 /* Older VAXC header files lack these constants */
9233 #ifndef JPI$_RIGHTS_SIZE
9234 #  define JPI$_RIGHTS_SIZE 817
9235 #endif
9236 #ifndef KGB$M_SUBSYSTEM
9237 #  define KGB$M_SUBSYSTEM 0x8
9238 #endif
9239
9240 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9241
9242 /*{{{void vms_image_init(int *, char ***)*/
9243 void
9244 vms_image_init(int *argcp, char ***argvp)
9245 {
9246   int status;
9247   char val_str[10];
9248   char eqv[LNM$C_NAMLENGTH+1] = "";
9249   unsigned int len, tabct = 8, tabidx = 0;
9250   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9251   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9252   unsigned short int dummy, rlen;
9253   struct dsc$descriptor_s **tabvec;
9254 #if defined(PERL_IMPLICIT_CONTEXT)
9255   pTHX = NULL;
9256 #endif
9257   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
9258                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
9259                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9260                                  {          0,                0,    0,      0} };
9261
9262 #ifdef KILL_BY_SIGPRC
9263     Perl_csighandler_init();
9264 #endif
9265
9266     /* This was moved from the pre-image init handler because on threaded */
9267     /* Perl it was always returning 0 for the default value. */
9268     status = simple_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
9269     if (status > 0) {
9270         int s;
9271         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9272         if (s > 0) {
9273             int initial;
9274             initial = decc$feature_get_value(s, 4);
9275             if (initial >= 0) {
9276                 /* initial is -1 if nothing has set the feature */
9277                 /* initial is 1 if the logical name is present */
9278                 decc_disable_posix_root = decc$feature_get_value(s, 1);
9279
9280                 /* If the value is not valid, force the feature off */
9281                 if (decc_disable_posix_root < 0) {
9282                     decc$feature_set_value(s, 1, 1);
9283                     decc_disable_posix_root = 1;
9284                 }
9285             }
9286             else {
9287                 /* Traditionally Perl assumes this is off */
9288                 decc_disable_posix_root = 1;
9289                 decc$feature_set_value(s, 1, 1);
9290             }
9291         }
9292     }
9293
9294
9295   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9296   _ckvmssts_noperl(iosb[0]);
9297   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9298     if (iprv[i]) {           /* Running image installed with privs? */
9299       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
9300       will_taint = TRUE;
9301       break;
9302     }
9303   }
9304   /* Rights identifiers might trigger tainting as well. */
9305   if (!will_taint && (rlen || rsz)) {
9306     while (rlen < rsz) {
9307       /* We didn't get all the identifiers on the first pass.  Allocate a
9308        * buffer much larger than $GETJPI wants (rsz is size in bytes that
9309        * were needed to hold all identifiers at time of last call; we'll
9310        * allocate that many unsigned long ints), and go back and get 'em.
9311        * If it gave us less than it wanted to despite ample buffer space,
9312        * something's broken.  Is your system missing a system identifier?
9313        */
9314       if (rsz <= jpilist[1].buflen) {
9315          /* Perl_croak accvios when used this early in startup. */
9316          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9317                          rsz, (unsigned long) jpilist[1].buflen,
9318                          "Check your rights database for corruption.\n");
9319          exit(SS$_ABORT);
9320       }
9321       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9322       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9323       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9324       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9325       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9326       _ckvmssts_noperl(iosb[0]);
9327     }
9328     mask = jpilist[1].bufadr;
9329     /* Check attribute flags for each identifier (2nd longword); protected
9330      * subsystem identifiers trigger tainting.
9331      */
9332     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9333       if (mask[i] & KGB$M_SUBSYSTEM) {
9334         will_taint = TRUE;
9335         break;
9336       }
9337     }
9338     if (mask != rlst) PerlMem_free(mask);
9339   }
9340
9341   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9342    * logical, some versions of the CRTL will add a phanthom /000000/
9343    * directory.  This needs to be removed.
9344    */
9345   if (decc_filename_unix_report) {
9346   char * zeros;
9347   int ulen;
9348     ulen = strlen(argvp[0][0]);
9349     if (ulen > 7) {
9350       zeros = strstr(argvp[0][0], "/000000/");
9351       if (zeros != NULL) {
9352         int mlen;
9353         mlen = ulen - (zeros - argvp[0][0]) - 7;
9354         memmove(zeros, &zeros[7], mlen);
9355         ulen = ulen - 7;
9356         argvp[0][0][ulen] = '\0';
9357       }
9358     }
9359     /* It also may have a trailing dot that needs to be removed otherwise
9360      * it will be converted to VMS mode incorrectly.
9361      */
9362     ulen--;
9363     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9364       argvp[0][0][ulen] = '\0';
9365   }
9366
9367   /* We need to use this hack to tell Perl it should run with tainting,
9368    * since its tainting flag may be part of the PL_curinterp struct, which
9369    * hasn't been allocated when vms_image_init() is called.
9370    */
9371   if (will_taint) {
9372     char **newargv, **oldargv;
9373     oldargv = *argvp;
9374     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9375     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9376     newargv[0] = oldargv[0];
9377     newargv[1] = PerlMem_malloc(3 * sizeof(char));
9378     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9379     strcpy(newargv[1], "-T");
9380     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9381     (*argcp)++;
9382     newargv[*argcp] = NULL;
9383     /* We orphan the old argv, since we don't know where it's come from,
9384      * so we don't know how to free it.
9385      */
9386     *argvp = newargv;
9387   }
9388   else {  /* Did user explicitly request tainting? */
9389     int i;
9390     char *cp, **av = *argvp;
9391     for (i = 1; i < *argcp; i++) {
9392       if (*av[i] != '-') break;
9393       for (cp = av[i]+1; *cp; cp++) {
9394         if (*cp == 'T') { will_taint = 1; break; }
9395         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9396                   strchr("DFIiMmx",*cp)) break;
9397       }
9398       if (will_taint) break;
9399     }
9400   }
9401
9402   for (tabidx = 0;
9403        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9404        tabidx++) {
9405     if (!tabidx) {
9406       tabvec = (struct dsc$descriptor_s **)
9407             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9408       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9409     }
9410     else if (tabidx >= tabct) {
9411       tabct += 8;
9412       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9413       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9414     }
9415     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9416     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9417     tabvec[tabidx]->dsc$w_length  = 0;
9418     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9419     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
9420     tabvec[tabidx]->dsc$a_pointer = NULL;
9421     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9422   }
9423   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9424
9425   getredirection(argcp,argvp);
9426 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9427   {
9428 # include <reentrancy.h>
9429   decc$set_reentrancy(C$C_MULTITHREAD);
9430   }
9431 #endif
9432   return;
9433 }
9434 /*}}}*/
9435
9436
9437 /* trim_unixpath()
9438  * Trim Unix-style prefix off filespec, so it looks like what a shell
9439  * glob expansion would return (i.e. from specified prefix on, not
9440  * full path).  Note that returned filespec is Unix-style, regardless
9441  * of whether input filespec was VMS-style or Unix-style.
9442  *
9443  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9444  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9445  * vector of options; at present, only bit 0 is used, and if set tells
9446  * trim unixpath to try the current default directory as a prefix when
9447  * presented with a possibly ambiguous ... wildcard.
9448  *
9449  * Returns !=0 on success, with trimmed filespec replacing contents of
9450  * fspec, and 0 on failure, with contents of fpsec unchanged.
9451  */
9452 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9453 int
9454 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9455 {
9456   char *unixified, *unixwild,
9457        *template, *base, *end, *cp1, *cp2;
9458   register int tmplen, reslen = 0, dirs = 0;
9459
9460   if (!wildspec || !fspec) return 0;
9461
9462   unixwild = PerlMem_malloc(VMS_MAXRSS);
9463   if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9464   template = unixwild;
9465   if (strpbrk(wildspec,"]>:") != NULL) {
9466     if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
9467         PerlMem_free(unixwild);
9468         return 0;
9469     }
9470   }
9471   else {
9472     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
9473     unixwild[VMS_MAXRSS-1] = 0;
9474   }
9475   unixified = PerlMem_malloc(VMS_MAXRSS);
9476   if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9477   if (strpbrk(fspec,"]>:") != NULL) {
9478     if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
9479         PerlMem_free(unixwild);
9480         PerlMem_free(unixified);
9481         return 0;
9482     }
9483     else base = unixified;
9484     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9485      * check to see that final result fits into (isn't longer than) fspec */
9486     reslen = strlen(fspec);
9487   }
9488   else base = fspec;
9489
9490   /* No prefix or absolute path on wildcard, so nothing to remove */
9491   if (!*template || *template == '/') {
9492     PerlMem_free(unixwild);
9493     if (base == fspec) {
9494         PerlMem_free(unixified);
9495         return 1;
9496     }
9497     tmplen = strlen(unixified);
9498     if (tmplen > reslen) {
9499         PerlMem_free(unixified);
9500         return 0;  /* not enough space */
9501     }
9502     /* Copy unixified resultant, including trailing NUL */
9503     memmove(fspec,unixified,tmplen+1);
9504     PerlMem_free(unixified);
9505     return 1;
9506   }
9507
9508   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
9509   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
9510     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
9511     for (cp1 = end ;cp1 >= base; cp1--)
9512       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9513         { cp1++; break; }
9514     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9515     PerlMem_free(unixified);
9516     PerlMem_free(unixwild);
9517     return 1;
9518   }
9519   else {
9520     char *tpl, *lcres;
9521     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9522     int ells = 1, totells, segdirs, match;
9523     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9524                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9525
9526     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9527     totells = ells;
9528     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9529     tpl = PerlMem_malloc(VMS_MAXRSS);
9530     if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9531     if (ellipsis == template && opts & 1) {
9532       /* Template begins with an ellipsis.  Since we can't tell how many
9533        * directory names at the front of the resultant to keep for an
9534        * arbitrary starting point, we arbitrarily choose the current
9535        * default directory as a starting point.  If it's there as a prefix,
9536        * clip it off.  If not, fall through and act as if the leading
9537        * ellipsis weren't there (i.e. return shortest possible path that
9538        * could match template).
9539        */
9540       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9541           PerlMem_free(tpl);
9542           PerlMem_free(unixified);
9543           PerlMem_free(unixwild);
9544           return 0;
9545       }
9546       if (!decc_efs_case_preserve) {
9547         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9548           if (_tolower(*cp1) != _tolower(*cp2)) break;
9549       }
9550       segdirs = dirs - totells;  /* Min # of dirs we must have left */
9551       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9552       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9553         memmove(fspec,cp2+1,end - cp2);
9554         PerlMem_free(tpl);
9555         PerlMem_free(unixified);
9556         PerlMem_free(unixwild);
9557         return 1;
9558       }
9559     }
9560     /* First off, back up over constant elements at end of path */
9561     if (dirs) {
9562       for (front = end ; front >= base; front--)
9563          if (*front == '/' && !dirs--) { front++; break; }
9564     }
9565     lcres = PerlMem_malloc(VMS_MAXRSS);
9566     if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9567     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9568          cp1++,cp2++) {
9569             if (!decc_efs_case_preserve) {
9570                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
9571             }
9572             else {
9573                 *cp2 = *cp1;
9574             }
9575     }
9576     if (cp1 != '\0') {
9577         PerlMem_free(tpl);
9578         PerlMem_free(unixified);
9579         PerlMem_free(unixwild);
9580         PerlMem_free(lcres);
9581         return 0;  /* Path too long. */
9582     }
9583     lcend = cp2;
9584     *cp2 = '\0';  /* Pick up with memcpy later */
9585     lcfront = lcres + (front - base);
9586     /* Now skip over each ellipsis and try to match the path in front of it. */
9587     while (ells--) {
9588       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
9589         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
9590             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
9591       if (cp1 < template) break; /* template started with an ellipsis */
9592       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9593         ellipsis = cp1; continue;
9594       }
9595       wilddsc.dsc$a_pointer = tpl;
9596       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9597       nextell = cp1;
9598       for (segdirs = 0, cp2 = tpl;
9599            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9600            cp1++, cp2++) {
9601          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9602          else {
9603             if (!decc_efs_case_preserve) {
9604               *cp2 = _tolower(*cp1);  /* else lowercase for match */
9605             }
9606             else {
9607               *cp2 = *cp1;  /* else preserve case for match */
9608             }
9609          }
9610          if (*cp2 == '/') segdirs++;
9611       }
9612       if (cp1 != ellipsis - 1) {
9613           PerlMem_free(tpl);
9614           PerlMem_free(unixified);
9615           PerlMem_free(unixwild);
9616           PerlMem_free(lcres);
9617           return 0; /* Path too long */
9618       }
9619       /* Back up at least as many dirs as in template before matching */
9620       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9621         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9622       for (match = 0; cp1 > lcres;) {
9623         resdsc.dsc$a_pointer = cp1;
9624         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9625           match++;
9626           if (match == 1) lcfront = cp1;
9627         }
9628         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9629       }
9630       if (!match) {
9631         PerlMem_free(tpl);
9632         PerlMem_free(unixified);
9633         PerlMem_free(unixwild);
9634         PerlMem_free(lcres);
9635         return 0;  /* Can't find prefix ??? */
9636       }
9637       if (match > 1 && opts & 1) {
9638         /* This ... wildcard could cover more than one set of dirs (i.e.
9639          * a set of similar dir names is repeated).  If the template
9640          * contains more than 1 ..., upstream elements could resolve the
9641          * ambiguity, but it's not worth a full backtracking setup here.
9642          * As a quick heuristic, clip off the current default directory
9643          * if it's present to find the trimmed spec, else use the
9644          * shortest string that this ... could cover.
9645          */
9646         char def[NAM$C_MAXRSS+1], *st;
9647
9648         if (getcwd(def, sizeof def,0) == NULL) {
9649             PerlMem_free(unixified);
9650             PerlMem_free(unixwild);
9651             PerlMem_free(lcres);
9652             PerlMem_free(tpl);
9653             return 0;
9654         }
9655         if (!decc_efs_case_preserve) {
9656           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9657             if (_tolower(*cp1) != _tolower(*cp2)) break;
9658         }
9659         segdirs = dirs - totells;  /* Min # of dirs we must have left */
9660         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9661         if (*cp1 == '\0' && *cp2 == '/') {
9662           memmove(fspec,cp2+1,end - cp2);
9663           PerlMem_free(tpl);
9664           PerlMem_free(unixified);
9665           PerlMem_free(unixwild);
9666           PerlMem_free(lcres);
9667           return 1;
9668         }
9669         /* Nope -- stick with lcfront from above and keep going. */
9670       }
9671     }
9672     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
9673     PerlMem_free(tpl);
9674     PerlMem_free(unixified);
9675     PerlMem_free(unixwild);
9676     PerlMem_free(lcres);
9677     return 1;
9678     ellipsis = nextell;
9679   }
9680
9681 }  /* end of trim_unixpath() */
9682 /*}}}*/
9683
9684
9685 /*
9686  *  VMS readdir() routines.
9687  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
9688  *
9689  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
9690  *  Minor modifications to original routines.
9691  */
9692
9693 /* readdir may have been redefined by reentr.h, so make sure we get
9694  * the local version for what we do here.
9695  */
9696 #ifdef readdir
9697 # undef readdir
9698 #endif
9699 #if !defined(PERL_IMPLICIT_CONTEXT)
9700 # define readdir Perl_readdir
9701 #else
9702 # define readdir(a) Perl_readdir(aTHX_ a)
9703 #endif
9704
9705     /* Number of elements in vms_versions array */
9706 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
9707
9708 /*
9709  *  Open a directory, return a handle for later use.
9710  */
9711 /*{{{ DIR *opendir(char*name) */
9712 DIR *
9713 Perl_opendir(pTHX_ const char *name)
9714 {
9715     DIR *dd;
9716     char *dir;
9717     Stat_t sb;
9718
9719     Newx(dir, VMS_MAXRSS, char);
9720     if (do_tovmspath(name,dir,0,NULL) == NULL) {
9721       Safefree(dir);
9722       return NULL;
9723     }
9724     /* Check access before stat; otherwise stat does not
9725      * accurately report whether it's a directory.
9726      */
9727     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
9728       /* cando_by_name has already set errno */
9729       Safefree(dir);
9730       return NULL;
9731     }
9732     if (flex_stat(dir,&sb) == -1) return NULL;
9733     if (!S_ISDIR(sb.st_mode)) {
9734       Safefree(dir);
9735       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
9736       return NULL;
9737     }
9738     /* Get memory for the handle, and the pattern. */
9739     Newx(dd,1,DIR);
9740     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
9741
9742     /* Fill in the fields; mainly playing with the descriptor. */
9743     sprintf(dd->pattern, "%s*.*",dir);
9744     Safefree(dir);
9745     dd->context = 0;
9746     dd->count = 0;
9747     dd->flags = 0;
9748     /* By saying we always want the result of readdir() in unix format, we
9749      * are really saying we want all the escapes removed.  Otherwise the caller,
9750      * having no way to know whether it's already in VMS format, might send it
9751      * through tovmsspec again, thus double escaping.
9752      */
9753     dd->flags = PERL_VMSDIR_M_UNIXSPECS;
9754     dd->pat.dsc$a_pointer = dd->pattern;
9755     dd->pat.dsc$w_length = strlen(dd->pattern);
9756     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
9757     dd->pat.dsc$b_class = DSC$K_CLASS_S;
9758 #if defined(USE_ITHREADS)
9759     Newx(dd->mutex,1,perl_mutex);
9760     MUTEX_INIT( (perl_mutex *) dd->mutex );
9761 #else
9762     dd->mutex = NULL;
9763 #endif
9764
9765     return dd;
9766 }  /* end of opendir() */
9767 /*}}}*/
9768
9769 /*
9770  *  Set the flag to indicate we want versions or not.
9771  */
9772 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
9773 void
9774 vmsreaddirversions(DIR *dd, int flag)
9775 {
9776     if (flag)
9777         dd->flags |= PERL_VMSDIR_M_VERSIONS;
9778     else
9779         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9780 }
9781 /*}}}*/
9782
9783 /*
9784  *  Free up an opened directory.
9785  */
9786 /*{{{ void closedir(DIR *dd)*/
9787 void
9788 Perl_closedir(DIR *dd)
9789 {
9790     int sts;
9791
9792     sts = lib$find_file_end(&dd->context);
9793     Safefree(dd->pattern);
9794 #if defined(USE_ITHREADS)
9795     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
9796     Safefree(dd->mutex);
9797 #endif
9798     Safefree(dd);
9799 }
9800 /*}}}*/
9801
9802 /*
9803  *  Collect all the version numbers for the current file.
9804  */
9805 static void
9806 collectversions(pTHX_ DIR *dd)
9807 {
9808     struct dsc$descriptor_s     pat;
9809     struct dsc$descriptor_s     res;
9810     struct dirent *e;
9811     char *p, *text, *buff;
9812     int i;
9813     unsigned long context, tmpsts;
9814
9815     /* Convenient shorthand. */
9816     e = &dd->entry;
9817
9818     /* Add the version wildcard, ignoring the "*.*" put on before */
9819     i = strlen(dd->pattern);
9820     Newx(text,i + e->d_namlen + 3,char);
9821     strcpy(text, dd->pattern);
9822     sprintf(&text[i - 3], "%s;*", e->d_name);
9823
9824     /* Set up the pattern descriptor. */
9825     pat.dsc$a_pointer = text;
9826     pat.dsc$w_length = i + e->d_namlen - 1;
9827     pat.dsc$b_dtype = DSC$K_DTYPE_T;
9828     pat.dsc$b_class = DSC$K_CLASS_S;
9829
9830     /* Set up result descriptor. */
9831     Newx(buff, VMS_MAXRSS, char);
9832     res.dsc$a_pointer = buff;
9833     res.dsc$w_length = VMS_MAXRSS - 1;
9834     res.dsc$b_dtype = DSC$K_DTYPE_T;
9835     res.dsc$b_class = DSC$K_CLASS_S;
9836
9837     /* Read files, collecting versions. */
9838     for (context = 0, e->vms_verscount = 0;
9839          e->vms_verscount < VERSIZE(e);
9840          e->vms_verscount++) {
9841         unsigned long rsts;
9842         unsigned long flags = 0;
9843
9844 #ifdef VMS_LONGNAME_SUPPORT
9845         flags = LIB$M_FIL_LONG_NAMES;
9846 #endif
9847         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
9848         if (tmpsts == RMS$_NMF || context == 0) break;
9849         _ckvmssts(tmpsts);
9850         buff[VMS_MAXRSS - 1] = '\0';
9851         if ((p = strchr(buff, ';')))
9852             e->vms_versions[e->vms_verscount] = atoi(p + 1);
9853         else
9854             e->vms_versions[e->vms_verscount] = -1;
9855     }
9856
9857     _ckvmssts(lib$find_file_end(&context));
9858     Safefree(text);
9859     Safefree(buff);
9860
9861 }  /* end of collectversions() */
9862
9863 /*
9864  *  Read the next entry from the directory.
9865  */
9866 /*{{{ struct dirent *readdir(DIR *dd)*/
9867 struct dirent *
9868 Perl_readdir(pTHX_ DIR *dd)
9869 {
9870     struct dsc$descriptor_s     res;
9871     char *p, *buff;
9872     unsigned long int tmpsts;
9873     unsigned long rsts;
9874     unsigned long flags = 0;
9875     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
9876     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
9877
9878     /* Set up result descriptor, and get next file. */
9879     Newx(buff, VMS_MAXRSS, char);
9880     res.dsc$a_pointer = buff;
9881     res.dsc$w_length = VMS_MAXRSS - 1;
9882     res.dsc$b_dtype = DSC$K_DTYPE_T;
9883     res.dsc$b_class = DSC$K_CLASS_S;
9884
9885 #ifdef VMS_LONGNAME_SUPPORT
9886     flags = LIB$M_FIL_LONG_NAMES;
9887 #endif
9888
9889     tmpsts = lib$find_file
9890         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
9891     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
9892     if (!(tmpsts & 1)) {
9893       set_vaxc_errno(tmpsts);
9894       switch (tmpsts) {
9895         case RMS$_PRV:
9896           set_errno(EACCES); break;
9897         case RMS$_DEV:
9898           set_errno(ENODEV); break;
9899         case RMS$_DIR:
9900           set_errno(ENOTDIR); break;
9901         case RMS$_FNF: case RMS$_DNF:
9902           set_errno(ENOENT); break;
9903         default:
9904           set_errno(EVMSERR);
9905       }
9906       Safefree(buff);
9907       return NULL;
9908     }
9909     dd->count++;
9910     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
9911     buff[res.dsc$w_length] = '\0';
9912     p = buff + res.dsc$w_length;
9913     while (--p >= buff) if (!isspace(*p)) break;
9914     *p = '\0';
9915     if (!decc_efs_case_preserve) {
9916       for (p = buff; *p; p++) *p = _tolower(*p);
9917     }
9918
9919     /* Skip any directory component and just copy the name. */
9920     sts = vms_split_path
9921        (buff,
9922         &v_spec,
9923         &v_len,
9924         &r_spec,
9925         &r_len,
9926         &d_spec,
9927         &d_len,
9928         &n_spec,
9929         &n_len,
9930         &e_spec,
9931         &e_len,
9932         &vs_spec,
9933         &vs_len);
9934
9935     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
9936
9937         /* In Unix report mode, remove the ".dir;1" from the name */
9938         /* if it is a real directory. */
9939         if (decc_filename_unix_report || decc_efs_charset) {
9940             if ((e_len == 4) && (vs_len == 2) && (vs_spec[1] == '1')) {
9941                 if ((toupper(e_spec[1]) == 'D') &&
9942                     (toupper(e_spec[2]) == 'I') &&
9943                     (toupper(e_spec[3]) == 'R')) {
9944                     Stat_t statbuf;
9945                     int ret_sts;
9946
9947                     ret_sts = stat(buff, (stat_t *)&statbuf);
9948                     if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
9949                         e_len = 0;
9950                         e_spec[0] = 0;
9951                     }
9952                 }
9953             }
9954         }
9955
9956         /* Drop NULL extensions on UNIX file specification */
9957         if ((e_len == 1) && decc_readdir_dropdotnotype) {
9958             e_len = 0;
9959             e_spec[0] = '\0';
9960         }
9961     }
9962
9963     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
9964     dd->entry.d_name[n_len + e_len] = '\0';
9965     dd->entry.d_namlen = strlen(dd->entry.d_name);
9966
9967     /* Convert the filename to UNIX format if needed */
9968     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
9969
9970         /* Translate the encoded characters. */
9971         /* Fixme: Unicode handling could result in embedded 0 characters */
9972         if (strchr(dd->entry.d_name, '^') != NULL) {
9973             char new_name[256];
9974             char * q;
9975             p = dd->entry.d_name;
9976             q = new_name;
9977             while (*p != 0) {
9978                 int inchars_read, outchars_added;
9979                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
9980                 p += inchars_read;
9981                 q += outchars_added;
9982                 /* fix-me */
9983                 /* if outchars_added > 1, then this is a wide file specification */
9984                 /* Wide file specifications need to be passed in Perl */
9985                 /* counted strings apparently with a Unicode flag */
9986             }
9987             *q = 0;
9988             strcpy(dd->entry.d_name, new_name);
9989             dd->entry.d_namlen = strlen(dd->entry.d_name);
9990         }
9991     }
9992
9993     dd->entry.vms_verscount = 0;
9994     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
9995     Safefree(buff);
9996     return &dd->entry;
9997
9998 }  /* end of readdir() */
9999 /*}}}*/
10000
10001 /*
10002  *  Read the next entry from the directory -- thread-safe version.
10003  */
10004 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10005 int
10006 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10007 {
10008     int retval;
10009
10010     MUTEX_LOCK( (perl_mutex *) dd->mutex );
10011
10012     entry = readdir(dd);
10013     *result = entry;
10014     retval = ( *result == NULL ? errno : 0 );
10015
10016     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10017
10018     return retval;
10019
10020 }  /* end of readdir_r() */
10021 /*}}}*/
10022
10023 /*
10024  *  Return something that can be used in a seekdir later.
10025  */
10026 /*{{{ long telldir(DIR *dd)*/
10027 long
10028 Perl_telldir(DIR *dd)
10029 {
10030     return dd->count;
10031 }
10032 /*}}}*/
10033
10034 /*
10035  *  Return to a spot where we used to be.  Brute force.
10036  */
10037 /*{{{ void seekdir(DIR *dd,long count)*/
10038 void
10039 Perl_seekdir(pTHX_ DIR *dd, long count)
10040 {
10041     int old_flags;
10042
10043     /* If we haven't done anything yet... */
10044     if (dd->count == 0)
10045         return;
10046
10047     /* Remember some state, and clear it. */
10048     old_flags = dd->flags;
10049     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10050     _ckvmssts(lib$find_file_end(&dd->context));
10051     dd->context = 0;
10052
10053     /* The increment is in readdir(). */
10054     for (dd->count = 0; dd->count < count; )
10055         readdir(dd);
10056
10057     dd->flags = old_flags;
10058
10059 }  /* end of seekdir() */
10060 /*}}}*/
10061
10062 /* VMS subprocess management
10063  *
10064  * my_vfork() - just a vfork(), after setting a flag to record that
10065  * the current script is trying a Unix-style fork/exec.
10066  *
10067  * vms_do_aexec() and vms_do_exec() are called in response to the
10068  * perl 'exec' function.  If this follows a vfork call, then they
10069  * call out the regular perl routines in doio.c which do an
10070  * execvp (for those who really want to try this under VMS).
10071  * Otherwise, they do exactly what the perl docs say exec should
10072  * do - terminate the current script and invoke a new command
10073  * (See below for notes on command syntax.)
10074  *
10075  * do_aspawn() and do_spawn() implement the VMS side of the perl
10076  * 'system' function.
10077  *
10078  * Note on command arguments to perl 'exec' and 'system': When handled
10079  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10080  * are concatenated to form a DCL command string.  If the first non-numeric
10081  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10082  * the command string is handed off to DCL directly.  Otherwise,
10083  * the first token of the command is taken as the filespec of an image
10084  * to run.  The filespec is expanded using a default type of '.EXE' and
10085  * the process defaults for device, directory, etc., and if found, the resultant
10086  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10087  * the command string as parameters.  This is perhaps a bit complicated,
10088  * but I hope it will form a happy medium between what VMS folks expect
10089  * from lib$spawn and what Unix folks expect from exec.
10090  */
10091
10092 static int vfork_called;
10093
10094 /*{{{int my_vfork()*/
10095 int
10096 my_vfork()
10097 {
10098   vfork_called++;
10099   return vfork();
10100 }
10101 /*}}}*/
10102
10103
10104 static void
10105 vms_execfree(struct dsc$descriptor_s *vmscmd)
10106 {
10107   if (vmscmd) {
10108       if (vmscmd->dsc$a_pointer) {
10109           PerlMem_free(vmscmd->dsc$a_pointer);
10110       }
10111       PerlMem_free(vmscmd);
10112   }
10113 }
10114
10115 static char *
10116 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10117 {
10118   char *junk, *tmps = NULL;
10119   register size_t cmdlen = 0;
10120   size_t rlen;
10121   register SV **idx;
10122   STRLEN n_a;
10123
10124   idx = mark;
10125   if (really) {
10126     tmps = SvPV(really,rlen);
10127     if (*tmps) {
10128       cmdlen += rlen + 1;
10129       idx++;
10130     }
10131   }
10132
10133   for (idx++; idx <= sp; idx++) {
10134     if (*idx) {
10135       junk = SvPVx(*idx,rlen);
10136       cmdlen += rlen ? rlen + 1 : 0;
10137     }
10138   }
10139   Newx(PL_Cmd, cmdlen+1, char);
10140
10141   if (tmps && *tmps) {
10142     strcpy(PL_Cmd,tmps);
10143     mark++;
10144   }
10145   else *PL_Cmd = '\0';
10146   while (++mark <= sp) {
10147     if (*mark) {
10148       char *s = SvPVx(*mark,n_a);
10149       if (!*s) continue;
10150       if (*PL_Cmd) strcat(PL_Cmd," ");
10151       strcat(PL_Cmd,s);
10152     }
10153   }
10154   return PL_Cmd;
10155
10156 }  /* end of setup_argstr() */
10157
10158
10159 static unsigned long int
10160 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10161                    struct dsc$descriptor_s **pvmscmd)
10162 {
10163   char * vmsspec;
10164   char * resspec;
10165   char image_name[NAM$C_MAXRSS+1];
10166   char image_argv[NAM$C_MAXRSS+1];
10167   $DESCRIPTOR(defdsc,".EXE");
10168   $DESCRIPTOR(defdsc2,".");
10169   struct dsc$descriptor_s resdsc;
10170   struct dsc$descriptor_s *vmscmd;
10171   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10172   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10173   register char *s, *rest, *cp, *wordbreak;
10174   char * cmd;
10175   int cmdlen;
10176   register int isdcl;
10177
10178   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10179   if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10180
10181   /* vmsspec is a DCL command buffer, not just a filename */
10182   vmsspec = PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10183   if (vmsspec == NULL)
10184       _ckvmssts_noperl(SS$_INSFMEM);
10185
10186   resspec = PerlMem_malloc(VMS_MAXRSS);
10187   if (resspec == NULL)
10188       _ckvmssts_noperl(SS$_INSFMEM);
10189
10190   /* Make a copy for modification */
10191   cmdlen = strlen(incmd);
10192   cmd = PerlMem_malloc(cmdlen+1);
10193   if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10194   strncpy(cmd, incmd, cmdlen);
10195   cmd[cmdlen] = 0;
10196   image_name[0] = 0;
10197   image_argv[0] = 0;
10198
10199   resdsc.dsc$a_pointer = resspec;
10200   resdsc.dsc$b_dtype  = DSC$K_DTYPE_T;
10201   resdsc.dsc$b_class  = DSC$K_CLASS_S;
10202   resdsc.dsc$w_length = VMS_MAXRSS - 1;
10203
10204   vmscmd->dsc$a_pointer = NULL;
10205   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
10206   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
10207   vmscmd->dsc$w_length = 0;
10208   if (pvmscmd) *pvmscmd = vmscmd;
10209
10210   if (suggest_quote) *suggest_quote = 0;
10211
10212   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10213     PerlMem_free(cmd);
10214     PerlMem_free(vmsspec);
10215     PerlMem_free(resspec);
10216     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
10217   }
10218
10219   s = cmd;
10220
10221   while (*s && isspace(*s)) s++;
10222
10223   if (*s == '@' || *s == '$') {
10224     vmsspec[0] = *s;  rest = s + 1;
10225     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10226   }
10227   else { cp = vmsspec; rest = s; }
10228   if (*rest == '.' || *rest == '/') {
10229     char *cp2;
10230     for (cp2 = resspec;
10231          *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10232          rest++, cp2++) *cp2 = *rest;
10233     *cp2 = '\0';
10234     if (int_tovmsspec(resspec, cp, 0, NULL)) {
10235       s = vmsspec;
10236
10237       /* When a UNIX spec with no file type is translated to VMS, */
10238       /* A trailing '.' is appended under ODS-5 rules.            */
10239       /* Here we do not want that trailing "." as it prevents     */
10240       /* Looking for a implied ".exe" type. */
10241       if (decc_efs_charset) {
10242           int i;
10243           i = strlen(vmsspec);
10244           if (vmsspec[i-1] == '.') {
10245               vmsspec[i-1] = '\0';
10246           }
10247       }
10248
10249       if (*rest) {
10250         for (cp2 = vmsspec + strlen(vmsspec);
10251              *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10252              rest++, cp2++) *cp2 = *rest;
10253         *cp2 = '\0';
10254       }
10255     }
10256   }
10257   /* Intuit whether verb (first word of cmd) is a DCL command:
10258    *   - if first nonspace char is '@', it's a DCL indirection
10259    * otherwise
10260    *   - if verb contains a filespec separator, it's not a DCL command
10261    *   - if it doesn't, caller tells us whether to default to a DCL
10262    *     command, or to a local image unless told it's DCL (by leading '$')
10263    */
10264   if (*s == '@') {
10265       isdcl = 1;
10266       if (suggest_quote) *suggest_quote = 1;
10267   } else {
10268     register char *filespec = strpbrk(s,":<[.;");
10269     rest = wordbreak = strpbrk(s," \"\t/");
10270     if (!wordbreak) wordbreak = s + strlen(s);
10271     if (*s == '$') check_img = 0;
10272     if (filespec && (filespec < wordbreak)) isdcl = 0;
10273     else isdcl = !check_img;
10274   }
10275
10276   if (!isdcl) {
10277     int rsts;
10278     imgdsc.dsc$a_pointer = s;
10279     imgdsc.dsc$w_length = wordbreak - s;
10280     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10281     if (!(retsts&1)) {
10282         _ckvmssts_noperl(lib$find_file_end(&cxt));
10283         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10284       if (!(retsts & 1) && *s == '$') {
10285         _ckvmssts_noperl(lib$find_file_end(&cxt));
10286         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10287         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10288         if (!(retsts&1)) {
10289           _ckvmssts_noperl(lib$find_file_end(&cxt));
10290           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10291         }
10292       }
10293     }
10294     _ckvmssts_noperl(lib$find_file_end(&cxt));
10295
10296     if (retsts & 1) {
10297       FILE *fp;
10298       s = resspec;
10299       while (*s && !isspace(*s)) s++;
10300       *s = '\0';
10301
10302       /* check that it's really not DCL with no file extension */
10303       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10304       if (fp) {
10305         char b[256] = {0,0,0,0};
10306         read(fileno(fp), b, 256);
10307         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10308         if (isdcl) {
10309           int shebang_len;
10310
10311           /* Check for script */
10312           shebang_len = 0;
10313           if ((b[0] == '#') && (b[1] == '!'))
10314              shebang_len = 2;
10315 #ifdef ALTERNATE_SHEBANG
10316           else {
10317             shebang_len = strlen(ALTERNATE_SHEBANG);
10318             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10319               char * perlstr;
10320                 perlstr = strstr("perl",b);
10321                 if (perlstr == NULL)
10322                   shebang_len = 0;
10323             }
10324             else
10325               shebang_len = 0;
10326           }
10327 #endif
10328
10329           if (shebang_len > 0) {
10330           int i;
10331           int j;
10332           char tmpspec[NAM$C_MAXRSS + 1];
10333
10334             i = shebang_len;
10335              /* Image is following after white space */
10336             /*--------------------------------------*/
10337             while (isprint(b[i]) && isspace(b[i]))
10338                 i++;
10339
10340             j = 0;
10341             while (isprint(b[i]) && !isspace(b[i])) {
10342                 tmpspec[j++] = b[i++];
10343                 if (j >= NAM$C_MAXRSS)
10344                    break;
10345             }
10346             tmpspec[j] = '\0';
10347
10348              /* There may be some default parameters to the image */
10349             /*---------------------------------------------------*/
10350             j = 0;
10351             while (isprint(b[i])) {
10352                 image_argv[j++] = b[i++];
10353                 if (j >= NAM$C_MAXRSS)
10354                    break;
10355             }
10356             while ((j > 0) && !isprint(image_argv[j-1]))
10357                 j--;
10358             image_argv[j] = 0;
10359
10360             /* It will need to be converted to VMS format and validated */
10361             if (tmpspec[0] != '\0') {
10362               char * iname;
10363
10364                /* Try to find the exact program requested to be run */
10365               /*---------------------------------------------------*/
10366               iname = do_rmsexpand
10367                  (tmpspec, image_name, 0, ".exe",
10368                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10369               if (iname != NULL) {
10370                 if (cando_by_name_int
10371                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10372                   /* MCR prefix needed */
10373                   isdcl = 0;
10374                 }
10375                 else {
10376                    /* Try again with a null type */
10377                   /*----------------------------*/
10378                   iname = do_rmsexpand
10379                     (tmpspec, image_name, 0, ".",
10380                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10381                   if (iname != NULL) {
10382                     if (cando_by_name_int
10383                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10384                       /* MCR prefix needed */
10385                       isdcl = 0;
10386                     }
10387                   }
10388                 }
10389
10390                  /* Did we find the image to run the script? */
10391                 /*------------------------------------------*/
10392                 if (isdcl) {
10393                   char *tchr;
10394
10395                    /* Assume DCL or foreign command exists */
10396                   /*--------------------------------------*/
10397                   tchr = strrchr(tmpspec, '/');
10398                   if (tchr != NULL) {
10399                     tchr++;
10400                   }
10401                   else {
10402                     tchr = tmpspec;
10403                   }
10404                   strcpy(image_name, tchr);
10405                 }
10406               }
10407             }
10408           }
10409         }
10410         fclose(fp);
10411       }
10412       if (check_img && isdcl) {
10413           PerlMem_free(cmd);
10414           PerlMem_free(resspec);
10415           PerlMem_free(vmsspec);
10416           return RMS$_FNF;
10417       }
10418
10419       if (cando_by_name(S_IXUSR,0,resspec)) {
10420         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10421         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10422         if (!isdcl) {
10423             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
10424             if (image_name[0] != 0) {
10425                 strcat(vmscmd->dsc$a_pointer, image_name);
10426                 strcat(vmscmd->dsc$a_pointer, " ");
10427             }
10428         } else if (image_name[0] != 0) {
10429             strcpy(vmscmd->dsc$a_pointer, image_name);
10430             strcat(vmscmd->dsc$a_pointer, " ");
10431         } else {
10432             strcpy(vmscmd->dsc$a_pointer,"@");
10433         }
10434         if (suggest_quote) *suggest_quote = 1;
10435
10436         /* If there is an image name, use original command */
10437         if (image_name[0] == 0)
10438             strcat(vmscmd->dsc$a_pointer,resspec);
10439         else {
10440             rest = cmd;
10441             while (*rest && isspace(*rest)) rest++;
10442         }
10443
10444         if (image_argv[0] != 0) {
10445           strcat(vmscmd->dsc$a_pointer,image_argv);
10446           strcat(vmscmd->dsc$a_pointer, " ");
10447         }
10448         if (rest) {
10449            int rest_len;
10450            int vmscmd_len;
10451
10452            rest_len = strlen(rest);
10453            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10454            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10455               strcat(vmscmd->dsc$a_pointer,rest);
10456            else
10457              retsts = CLI$_BUFOVF;
10458         }
10459         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10460         PerlMem_free(cmd);
10461         PerlMem_free(vmsspec);
10462         PerlMem_free(resspec);
10463         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10464       }
10465       else
10466         retsts = RMS$_PRV;
10467     }
10468   }
10469   /* It's either a DCL command or we couldn't find a suitable image */
10470   vmscmd->dsc$w_length = strlen(cmd);
10471
10472   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
10473   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
10474   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
10475
10476   PerlMem_free(cmd);
10477   PerlMem_free(resspec);
10478   PerlMem_free(vmsspec);
10479
10480   /* check if it's a symbol (for quoting purposes) */
10481   if (suggest_quote && !*suggest_quote) {
10482     int iss;
10483     char equiv[LNM$C_NAMLENGTH];
10484     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10485     eqvdsc.dsc$a_pointer = equiv;
10486
10487     iss = lib$get_symbol(vmscmd,&eqvdsc);
10488     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10489   }
10490   if (!(retsts & 1)) {
10491     /* just hand off status values likely to be due to user error */
10492     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10493         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10494        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10495     else { _ckvmssts_noperl(retsts); }
10496   }
10497
10498   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10499
10500 }  /* end of setup_cmddsc() */
10501
10502
10503 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10504 bool
10505 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10506 {
10507 bool exec_sts;
10508 char * cmd;
10509
10510   if (sp > mark) {
10511     if (vfork_called) {           /* this follows a vfork - act Unixish */
10512       vfork_called--;
10513       if (vfork_called < 0) {
10514         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10515         vfork_called = 0;
10516       }
10517       else return do_aexec(really,mark,sp);
10518     }
10519                                            /* no vfork - act VMSish */
10520     cmd = setup_argstr(aTHX_ really,mark,sp);
10521     exec_sts = vms_do_exec(cmd);
10522     Safefree(cmd);  /* Clean up from setup_argstr() */
10523     return exec_sts;
10524   }
10525
10526   return FALSE;
10527 }  /* end of vms_do_aexec() */
10528 /*}}}*/
10529
10530 /* {{{bool vms_do_exec(char *cmd) */
10531 bool
10532 Perl_vms_do_exec(pTHX_ const char *cmd)
10533 {
10534   struct dsc$descriptor_s *vmscmd;
10535
10536   if (vfork_called) {             /* this follows a vfork - act Unixish */
10537     vfork_called--;
10538     if (vfork_called < 0) {
10539       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10540       vfork_called = 0;
10541     }
10542     else return do_exec(cmd);
10543   }
10544
10545   {                               /* no vfork - act VMSish */
10546     unsigned long int retsts;
10547
10548     TAINT_ENV();
10549     TAINT_PROPER("exec");
10550     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10551       retsts = lib$do_command(vmscmd);
10552
10553     switch (retsts) {
10554       case RMS$_FNF: case RMS$_DNF:
10555         set_errno(ENOENT); break;
10556       case RMS$_DIR:
10557         set_errno(ENOTDIR); break;
10558       case RMS$_DEV:
10559         set_errno(ENODEV); break;
10560       case RMS$_PRV:
10561         set_errno(EACCES); break;
10562       case RMS$_SYN:
10563         set_errno(EINVAL); break;
10564       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10565         set_errno(E2BIG); break;
10566       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10567         _ckvmssts_noperl(retsts); /* fall through */
10568       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10569         set_errno(EVMSERR);
10570     }
10571     set_vaxc_errno(retsts);
10572     if (ckWARN(WARN_EXEC)) {
10573       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10574              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10575     }
10576     vms_execfree(vmscmd);
10577   }
10578
10579   return FALSE;
10580
10581 }  /* end of vms_do_exec() */
10582 /*}}}*/
10583
10584 int do_spawn2(pTHX_ const char *, int);
10585
10586 int
10587 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
10588 {
10589 unsigned long int sts;
10590 char * cmd;
10591 int flags = 0;
10592
10593   if (sp > mark) {
10594
10595     /* We'll copy the (undocumented?) Win32 behavior and allow a
10596      * numeric first argument.  But the only value we'll support
10597      * through do_aspawn is a value of 1, which means spawn without
10598      * waiting for completion -- other values are ignored.
10599      */
10600     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
10601         ++mark;
10602         flags = SvIVx(*mark);
10603     }
10604
10605     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
10606         flags = CLI$M_NOWAIT;
10607     else
10608         flags = 0;
10609
10610     cmd = setup_argstr(aTHX_ really, mark, sp);
10611     sts = do_spawn2(aTHX_ cmd, flags);
10612     /* pp_sys will clean up cmd */
10613     return sts;
10614   }
10615   return SS$_ABORT;
10616 }  /* end of do_aspawn() */
10617 /*}}}*/
10618
10619
10620 /* {{{int do_spawn(char* cmd) */
10621 int
10622 Perl_do_spawn(pTHX_ char* cmd)
10623 {
10624     PERL_ARGS_ASSERT_DO_SPAWN;
10625
10626     return do_spawn2(aTHX_ cmd, 0);
10627 }
10628 /*}}}*/
10629
10630 /* {{{int do_spawn_nowait(char* cmd) */
10631 int
10632 Perl_do_spawn_nowait(pTHX_ char* cmd)
10633 {
10634     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
10635
10636     return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
10637 }
10638 /*}}}*/
10639
10640 /* {{{int do_spawn2(char *cmd) */
10641 int
10642 do_spawn2(pTHX_ const char *cmd, int flags)
10643 {
10644   unsigned long int sts, substs;
10645
10646   /* The caller of this routine expects to Safefree(PL_Cmd) */
10647   Newx(PL_Cmd,10,char);
10648
10649   TAINT_ENV();
10650   TAINT_PROPER("spawn");
10651   if (!cmd || !*cmd) {
10652     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
10653     if (!(sts & 1)) {
10654       switch (sts) {
10655         case RMS$_FNF:  case RMS$_DNF:
10656           set_errno(ENOENT); break;
10657         case RMS$_DIR:
10658           set_errno(ENOTDIR); break;
10659         case RMS$_DEV:
10660           set_errno(ENODEV); break;
10661         case RMS$_PRV:
10662           set_errno(EACCES); break;
10663         case RMS$_SYN:
10664           set_errno(EINVAL); break;
10665         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10666           set_errno(E2BIG); break;
10667         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10668           _ckvmssts_noperl(sts); /* fall through */
10669         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10670           set_errno(EVMSERR);
10671       }
10672       set_vaxc_errno(sts);
10673       if (ckWARN(WARN_EXEC)) {
10674         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
10675                     Strerror(errno));
10676       }
10677     }
10678     sts = substs;
10679   }
10680   else {
10681     char mode[3];
10682     PerlIO * fp;
10683     if (flags & CLI$M_NOWAIT)
10684         strcpy(mode, "n");
10685     else
10686         strcpy(mode, "nW");
10687
10688     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
10689     if (fp != NULL)
10690       my_pclose(fp);
10691     /* sts will be the pid in the nowait case */
10692   }
10693   return sts;
10694 }  /* end of do_spawn2() */
10695 /*}}}*/
10696
10697
10698 static unsigned int *sockflags, sockflagsize;
10699
10700 /*
10701  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
10702  * routines found in some versions of the CRTL can't deal with sockets.
10703  * We don't shim the other file open routines since a socket isn't
10704  * likely to be opened by a name.
10705  */
10706 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
10707 FILE *my_fdopen(int fd, const char *mode)
10708 {
10709   FILE *fp = fdopen(fd, mode);
10710
10711   if (fp) {
10712     unsigned int fdoff = fd / sizeof(unsigned int);
10713     Stat_t sbuf; /* native stat; we don't need flex_stat */
10714     if (!sockflagsize || fdoff > sockflagsize) {
10715       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
10716       else           Newx  (sockflags,fdoff+2,unsigned int);
10717       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
10718       sockflagsize = fdoff + 2;
10719     }
10720     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
10721       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
10722   }
10723   return fp;
10724
10725 }
10726 /*}}}*/
10727
10728
10729 /*
10730  * Clear the corresponding bit when the (possibly) socket stream is closed.
10731  * There still a small hole: we miss an implicit close which might occur
10732  * via freopen().  >> Todo
10733  */
10734 /*{{{ int my_fclose(FILE *fp)*/
10735 int my_fclose(FILE *fp) {
10736   if (fp) {
10737     unsigned int fd = fileno(fp);
10738     unsigned int fdoff = fd / sizeof(unsigned int);
10739
10740     if (sockflagsize && fdoff < sockflagsize)
10741       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
10742   }
10743   return fclose(fp);
10744 }
10745 /*}}}*/
10746
10747
10748 /*
10749  * A simple fwrite replacement which outputs itmsz*nitm chars without
10750  * introducing record boundaries every itmsz chars.
10751  * We are using fputs, which depends on a terminating null.  We may
10752  * well be writing binary data, so we need to accommodate not only
10753  * data with nulls sprinkled in the middle but also data with no null
10754  * byte at the end.
10755  */
10756 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
10757 int
10758 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
10759 {
10760   register char *cp, *end, *cpd, *data;
10761   register unsigned int fd = fileno(dest);
10762   register unsigned int fdoff = fd / sizeof(unsigned int);
10763   int retval;
10764   int bufsize = itmsz * nitm + 1;
10765
10766   if (fdoff < sockflagsize &&
10767       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
10768     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
10769     return nitm;
10770   }
10771
10772   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
10773   memcpy( data, src, itmsz*nitm );
10774   data[itmsz*nitm] = '\0';
10775
10776   end = data + itmsz * nitm;
10777   retval = (int) nitm; /* on success return # items written */
10778
10779   cpd = data;
10780   while (cpd <= end) {
10781     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
10782     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
10783     if (cp < end)
10784       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
10785     cpd = cp + 1;
10786   }
10787
10788   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
10789   return retval;
10790
10791 }  /* end of my_fwrite() */
10792 /*}}}*/
10793
10794 /*{{{ int my_flush(FILE *fp)*/
10795 int
10796 Perl_my_flush(pTHX_ FILE *fp)
10797 {
10798     int res;
10799     if ((res = fflush(fp)) == 0 && fp) {
10800 #ifdef VMS_DO_SOCKETS
10801         Stat_t s;
10802         if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
10803 #endif
10804             res = fsync(fileno(fp));
10805     }
10806 /*
10807  * If the flush succeeded but set end-of-file, we need to clear
10808  * the error because our caller may check ferror().  BTW, this
10809  * probably means we just flushed an empty file.
10810  */
10811     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
10812
10813     return res;
10814 }
10815 /*}}}*/
10816
10817 /*
10818  * Here are replacements for the following Unix routines in the VMS environment:
10819  *      getpwuid    Get information for a particular UIC or UID
10820  *      getpwnam    Get information for a named user
10821  *      getpwent    Get information for each user in the rights database
10822  *      setpwent    Reset search to the start of the rights database
10823  *      endpwent    Finish searching for users in the rights database
10824  *
10825  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
10826  * (defined in pwd.h), which contains the following fields:-
10827  *      struct passwd {
10828  *              char        *pw_name;    Username (in lower case)
10829  *              char        *pw_passwd;  Hashed password
10830  *              unsigned int pw_uid;     UIC
10831  *              unsigned int pw_gid;     UIC group  number
10832  *              char        *pw_unixdir; Default device/directory (VMS-style)
10833  *              char        *pw_gecos;   Owner name
10834  *              char        *pw_dir;     Default device/directory (Unix-style)
10835  *              char        *pw_shell;   Default CLI name (eg. DCL)
10836  *      };
10837  * If the specified user does not exist, getpwuid and getpwnam return NULL.
10838  *
10839  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
10840  * not the UIC member number (eg. what's returned by getuid()),
10841  * getpwuid() can accept either as input (if uid is specified, the caller's
10842  * UIC group is used), though it won't recognise gid=0.
10843  *
10844  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
10845  * information about other users in your group or in other groups, respectively.
10846  * If the required privilege is not available, then these routines fill only
10847  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
10848  * string).
10849  *
10850  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
10851  */
10852
10853 /* sizes of various UAF record fields */
10854 #define UAI$S_USERNAME 12
10855 #define UAI$S_IDENT    31
10856 #define UAI$S_OWNER    31
10857 #define UAI$S_DEFDEV   31
10858 #define UAI$S_DEFDIR   63
10859 #define UAI$S_DEFCLI   31
10860 #define UAI$S_PWD       8
10861
10862 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
10863                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
10864                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
10865
10866 static char __empty[]= "";
10867 static struct passwd __passwd_empty=
10868     {(char *) __empty, (char *) __empty, 0, 0,
10869      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
10870 static int contxt= 0;
10871 static struct passwd __pwdcache;
10872 static char __pw_namecache[UAI$S_IDENT+1];
10873
10874 /*
10875  * This routine does most of the work extracting the user information.
10876  */
10877 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
10878 {
10879     static struct {
10880         unsigned char length;
10881         char pw_gecos[UAI$S_OWNER+1];
10882     } owner;
10883     static union uicdef uic;
10884     static struct {
10885         unsigned char length;
10886         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
10887     } defdev;
10888     static struct {
10889         unsigned char length;
10890         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
10891     } defdir;
10892     static struct {
10893         unsigned char length;
10894         char pw_shell[UAI$S_DEFCLI+1];
10895     } defcli;
10896     static char pw_passwd[UAI$S_PWD+1];
10897
10898     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
10899     struct dsc$descriptor_s name_desc;
10900     unsigned long int sts;
10901
10902     static struct itmlst_3 itmlst[]= {
10903         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
10904         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
10905         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
10906         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
10907         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
10908         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
10909         {0,                0,           NULL,    NULL}};
10910
10911     name_desc.dsc$w_length=  strlen(name);
10912     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
10913     name_desc.dsc$b_class=   DSC$K_CLASS_S;
10914     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
10915
10916 /*  Note that sys$getuai returns many fields as counted strings. */
10917     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
10918     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
10919       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
10920     }
10921     else { _ckvmssts(sts); }
10922     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
10923
10924     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
10925     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
10926     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
10927     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
10928     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
10929     owner.pw_gecos[lowner]=            '\0';
10930     defdev.pw_dir[ldefdev+ldefdir]= '\0';
10931     defcli.pw_shell[ldefcli]=          '\0';
10932     if (valid_uic(uic)) {
10933         pwd->pw_uid= uic.uic$l_uic;
10934         pwd->pw_gid= uic.uic$v_group;
10935     }
10936     else
10937       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
10938     pwd->pw_passwd=  pw_passwd;
10939     pwd->pw_gecos=   owner.pw_gecos;
10940     pwd->pw_dir=     defdev.pw_dir;
10941     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
10942     pwd->pw_shell=   defcli.pw_shell;
10943     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
10944         int ldir;
10945         ldir= strlen(pwd->pw_unixdir) - 1;
10946         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
10947     }
10948     else
10949         strcpy(pwd->pw_unixdir, pwd->pw_dir);
10950     if (!decc_efs_case_preserve)
10951         __mystrtolower(pwd->pw_unixdir);
10952     return 1;
10953 }
10954
10955 /*
10956  * Get information for a named user.
10957 */
10958 /*{{{struct passwd *getpwnam(char *name)*/
10959 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
10960 {
10961     struct dsc$descriptor_s name_desc;
10962     union uicdef uic;
10963     unsigned long int status, sts;
10964
10965     __pwdcache = __passwd_empty;
10966     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
10967       /* We still may be able to determine pw_uid and pw_gid */
10968       name_desc.dsc$w_length=  strlen(name);
10969       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
10970       name_desc.dsc$b_class=   DSC$K_CLASS_S;
10971       name_desc.dsc$a_pointer= (char *) name;
10972       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
10973         __pwdcache.pw_uid= uic.uic$l_uic;
10974         __pwdcache.pw_gid= uic.uic$v_group;
10975       }
10976       else {
10977         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
10978           set_vaxc_errno(sts);
10979           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
10980           return NULL;
10981         }
10982         else { _ckvmssts(sts); }
10983       }
10984     }
10985     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
10986     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
10987     __pwdcache.pw_name= __pw_namecache;
10988     return &__pwdcache;
10989 }  /* end of my_getpwnam() */
10990 /*}}}*/
10991
10992 /*
10993  * Get information for a particular UIC or UID.
10994  * Called by my_getpwent with uid=-1 to list all users.
10995 */
10996 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
10997 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
10998 {
10999     const $DESCRIPTOR(name_desc,__pw_namecache);
11000     unsigned short lname;
11001     union uicdef uic;
11002     unsigned long int status;
11003
11004     if (uid == (unsigned int) -1) {
11005       do {
11006         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11007         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11008           set_vaxc_errno(status);
11009           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11010           my_endpwent();
11011           return NULL;
11012         }
11013         else { _ckvmssts(status); }
11014       } while (!valid_uic (uic));
11015     }
11016     else {
11017       uic.uic$l_uic= uid;
11018       if (!uic.uic$v_group)
11019         uic.uic$v_group= PerlProc_getgid();
11020       if (valid_uic(uic))
11021         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11022       else status = SS$_IVIDENT;
11023       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11024           status == RMS$_PRV) {
11025         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11026         return NULL;
11027       }
11028       else { _ckvmssts(status); }
11029     }
11030     __pw_namecache[lname]= '\0';
11031     __mystrtolower(__pw_namecache);
11032
11033     __pwdcache = __passwd_empty;
11034     __pwdcache.pw_name = __pw_namecache;
11035
11036 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11037     The identifier's value is usually the UIC, but it doesn't have to be,
11038     so if we can, we let fillpasswd update this. */
11039     __pwdcache.pw_uid =  uic.uic$l_uic;
11040     __pwdcache.pw_gid =  uic.uic$v_group;
11041
11042     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11043     return &__pwdcache;
11044
11045 }  /* end of my_getpwuid() */
11046 /*}}}*/
11047
11048 /*
11049  * Get information for next user.
11050 */
11051 /*{{{struct passwd *my_getpwent()*/
11052 struct passwd *Perl_my_getpwent(pTHX)
11053 {
11054     return (my_getpwuid((unsigned int) -1));
11055 }
11056 /*}}}*/
11057
11058 /*
11059  * Finish searching rights database for users.
11060 */
11061 /*{{{void my_endpwent()*/
11062 void Perl_my_endpwent(pTHX)
11063 {
11064     if (contxt) {
11065       _ckvmssts(sys$finish_rdb(&contxt));
11066       contxt= 0;
11067     }
11068 }
11069 /*}}}*/
11070
11071 #ifdef HOMEGROWN_POSIX_SIGNALS
11072   /* Signal handling routines, pulled into the core from POSIX.xs.
11073    *
11074    * We need these for threads, so they've been rolled into the core,
11075    * rather than left in POSIX.xs.
11076    *
11077    * (DRS, Oct 23, 1997)
11078    */
11079
11080   /* sigset_t is atomic under VMS, so these routines are easy */
11081 /*{{{int my_sigemptyset(sigset_t *) */
11082 int my_sigemptyset(sigset_t *set) {
11083     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11084     *set = 0; return 0;
11085 }
11086 /*}}}*/
11087
11088
11089 /*{{{int my_sigfillset(sigset_t *)*/
11090 int my_sigfillset(sigset_t *set) {
11091     int i;
11092     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11093     for (i = 0; i < NSIG; i++) *set |= (1 << i);
11094     return 0;
11095 }
11096 /*}}}*/
11097
11098
11099 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
11100 int my_sigaddset(sigset_t *set, int sig) {
11101     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11102     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11103     *set |= (1 << (sig - 1));
11104     return 0;
11105 }
11106 /*}}}*/
11107
11108
11109 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
11110 int my_sigdelset(sigset_t *set, int sig) {
11111     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11112     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11113     *set &= ~(1 << (sig - 1));
11114     return 0;
11115 }
11116 /*}}}*/
11117
11118
11119 /*{{{int my_sigismember(sigset_t *set, int sig)*/
11120 int my_sigismember(sigset_t *set, int sig) {
11121     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11122     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11123     return *set & (1 << (sig - 1));
11124 }
11125 /*}}}*/
11126
11127
11128 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
11129 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
11130     sigset_t tempmask;
11131
11132     /* If set and oset are both null, then things are badly wrong. Bail out. */
11133     if ((oset == NULL) && (set == NULL)) {
11134       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
11135       return -1;
11136     }
11137
11138     /* If set's null, then we're just handling a fetch. */
11139     if (set == NULL) {
11140         tempmask = sigblock(0);
11141     }
11142     else {
11143       switch (how) {
11144       case SIG_SETMASK:
11145         tempmask = sigsetmask(*set);
11146         break;
11147       case SIG_BLOCK:
11148         tempmask = sigblock(*set);
11149         break;
11150       case SIG_UNBLOCK:
11151         tempmask = sigblock(0);
11152         sigsetmask(*oset & ~tempmask);
11153         break;
11154       default:
11155         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11156         return -1;
11157       }
11158     }
11159
11160     /* Did they pass us an oset? If so, stick our holding mask into it */
11161     if (oset)
11162       *oset = tempmask;
11163
11164     return 0;
11165 }
11166 /*}}}*/
11167 #endif  /* HOMEGROWN_POSIX_SIGNALS */
11168
11169
11170 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11171  * my_utime(), and flex_stat(), all of which operate on UTC unless
11172  * VMSISH_TIMES is true.
11173  */
11174 /* method used to handle UTC conversions:
11175  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
11176  */
11177 static int gmtime_emulation_type;
11178 /* number of secs to add to UTC POSIX-style time to get local time */
11179 static long int utc_offset_secs;
11180
11181 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11182  * in vmsish.h.  #undef them here so we can call the CRTL routines
11183  * directly.
11184  */
11185 #undef gmtime
11186 #undef localtime
11187 #undef time
11188
11189
11190 /*
11191  * DEC C previous to 6.0 corrupts the behavior of the /prefix
11192  * qualifier with the extern prefix pragma.  This provisional
11193  * hack circumvents this prefix pragma problem in previous
11194  * precompilers.
11195  */
11196 #if defined(__VMS_VER) && __VMS_VER >= 70000000
11197 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
11198 #    pragma __extern_prefix save
11199 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
11200 #    define gmtime decc$__utctz_gmtime
11201 #    define localtime decc$__utctz_localtime
11202 #    define time decc$__utc_time
11203 #    pragma __extern_prefix restore
11204
11205      struct tm *gmtime(), *localtime();
11206
11207 #  endif
11208 #endif
11209
11210
11211 static time_t toutc_dst(time_t loc) {
11212   struct tm *rsltmp;
11213
11214   if ((rsltmp = localtime(&loc)) == NULL) return -1;
11215   loc -= utc_offset_secs;
11216   if (rsltmp->tm_isdst) loc -= 3600;
11217   return loc;
11218 }
11219 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11220        ((gmtime_emulation_type || my_time(NULL)), \
11221        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11222        ((secs) - utc_offset_secs))))
11223
11224 static time_t toloc_dst(time_t utc) {
11225   struct tm *rsltmp;
11226
11227   utc += utc_offset_secs;
11228   if ((rsltmp = localtime(&utc)) == NULL) return -1;
11229   if (rsltmp->tm_isdst) utc += 3600;
11230   return utc;
11231 }
11232 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11233        ((gmtime_emulation_type || my_time(NULL)), \
11234        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11235        ((secs) + utc_offset_secs))))
11236
11237 #ifndef RTL_USES_UTC
11238 /*
11239
11240     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
11241         DST starts on 1st sun of april      at 02:00  std time
11242             ends on last sun of october     at 02:00  dst time
11243     see the UCX management command reference, SET CONFIG TIMEZONE
11244     for formatting info.
11245
11246     No, it's not as general as it should be, but then again, NOTHING
11247     will handle UK times in a sensible way.
11248 */
11249
11250
11251 /*
11252     parse the DST start/end info:
11253     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
11254 */
11255
11256 static char *
11257 tz_parse_startend(char *s, struct tm *w, int *past)
11258 {
11259     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
11260     int ly, dozjd, d, m, n, hour, min, sec, j, k;
11261     time_t g;
11262
11263     if (!s)    return 0;
11264     if (!w) return 0;
11265     if (!past) return 0;
11266
11267     ly = 0;
11268     if (w->tm_year % 4        == 0) ly = 1;
11269     if (w->tm_year % 100      == 0) ly = 0;
11270     if (w->tm_year+1900 % 400 == 0) ly = 1;
11271     if (ly) dinm[1]++;
11272
11273     dozjd = isdigit(*s);
11274     if (*s == 'J' || *s == 'j' || dozjd) {
11275         if (!dozjd && !isdigit(*++s)) return 0;
11276         d = *s++ - '0';
11277         if (isdigit(*s)) {
11278             d = d*10 + *s++ - '0';
11279             if (isdigit(*s)) {
11280                 d = d*10 + *s++ - '0';
11281             }
11282         }
11283         if (d == 0) return 0;
11284         if (d > 366) return 0;
11285         d--;
11286         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
11287         g = d * 86400;
11288         dozjd = 1;
11289     } else if (*s == 'M' || *s == 'm') {
11290         if (!isdigit(*++s)) return 0;
11291         m = *s++ - '0';
11292         if (isdigit(*s)) m = 10*m + *s++ - '0';
11293         if (*s != '.') return 0;
11294         if (!isdigit(*++s)) return 0;
11295         n = *s++ - '0';
11296         if (n < 1 || n > 5) return 0;
11297         if (*s != '.') return 0;
11298         if (!isdigit(*++s)) return 0;
11299         d = *s++ - '0';
11300         if (d > 6) return 0;
11301     }
11302
11303     if (*s == '/') {
11304         if (!isdigit(*++s)) return 0;
11305         hour = *s++ - '0';
11306         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
11307         if (*s == ':') {
11308             if (!isdigit(*++s)) return 0;
11309             min = *s++ - '0';
11310             if (isdigit(*s)) min = 10*min + *s++ - '0';
11311             if (*s == ':') {
11312                 if (!isdigit(*++s)) return 0;
11313                 sec = *s++ - '0';
11314                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
11315             }
11316         }
11317     } else {
11318         hour = 2;
11319         min = 0;
11320         sec = 0;
11321     }
11322
11323     if (dozjd) {
11324         if (w->tm_yday < d) goto before;
11325         if (w->tm_yday > d) goto after;
11326     } else {
11327         if (w->tm_mon+1 < m) goto before;
11328         if (w->tm_mon+1 > m) goto after;
11329
11330         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
11331         k = d - j; /* mday of first d */
11332         if (k <= 0) k += 7;
11333         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
11334         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
11335         if (w->tm_mday < k) goto before;
11336         if (w->tm_mday > k) goto after;
11337     }
11338
11339     if (w->tm_hour < hour) goto before;
11340     if (w->tm_hour > hour) goto after;
11341     if (w->tm_min  < min)  goto before;
11342     if (w->tm_min  > min)  goto after;
11343     if (w->tm_sec  < sec)  goto before;
11344     goto after;
11345
11346 before:
11347     *past = 0;
11348     return s;
11349 after:
11350     *past = 1;
11351     return s;
11352 }
11353
11354
11355
11356
11357 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
11358
11359 static char *
11360 tz_parse_offset(char *s, int *offset)
11361 {
11362     int hour = 0, min = 0, sec = 0;
11363     int neg = 0;
11364     if (!s) return 0;
11365     if (!offset) return 0;
11366
11367     if (*s == '-') {neg++; s++;}
11368     if (*s == '+') s++;
11369     if (!isdigit(*s)) return 0;
11370     hour = *s++ - '0';
11371     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
11372     if (hour > 24) return 0;
11373     if (*s == ':') {
11374         if (!isdigit(*++s)) return 0;
11375         min = *s++ - '0';
11376         if (isdigit(*s)) min = min*10 + (*s++ - '0');
11377         if (min > 59) return 0;
11378         if (*s == ':') {
11379             if (!isdigit(*++s)) return 0;
11380             sec = *s++ - '0';
11381             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
11382             if (sec > 59) return 0;
11383         }
11384     }
11385
11386     *offset = (hour*60+min)*60 + sec;
11387     if (neg) *offset = -*offset;
11388     return s;
11389 }
11390
11391 /*
11392     input time is w, whatever type of time the CRTL localtime() uses.
11393     sets dst, the zone, and the gmtoff (seconds)
11394
11395     caches the value of TZ and UCX$TZ env variables; note that
11396     my_setenv looks for these and sets a flag if they're changed
11397     for efficiency.
11398
11399     We have to watch out for the "australian" case (dst starts in
11400     october, ends in april)...flagged by "reverse" and checked by
11401     scanning through the months of the previous year.
11402
11403 */
11404
11405 static int
11406 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
11407 {
11408     time_t when;
11409     struct tm *w2;
11410     char *s,*s2;
11411     char *dstzone, *tz, *s_start, *s_end;
11412     int std_off, dst_off, isdst;
11413     int y, dststart, dstend;
11414     static char envtz[1025];  /* longer than any logical, symbol, ... */
11415     static char ucxtz[1025];
11416     static char reversed = 0;
11417
11418     if (!w) return 0;
11419
11420     if (tz_updated) {
11421         tz_updated = 0;
11422         reversed = -1;  /* flag need to check  */
11423         envtz[0] = ucxtz[0] = '\0';
11424         tz = my_getenv("TZ",0);
11425         if (tz) strcpy(envtz, tz);
11426         tz = my_getenv("UCX$TZ",0);
11427         if (tz) strcpy(ucxtz, tz);
11428         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
11429     }
11430     tz = envtz;
11431     if (!*tz) tz = ucxtz;
11432
11433     s = tz;
11434     while (isalpha(*s)) s++;
11435     s = tz_parse_offset(s, &std_off);
11436     if (!s) return 0;
11437     if (!*s) {                  /* no DST, hurray we're done! */
11438         isdst = 0;
11439         goto done;
11440     }
11441
11442     dstzone = s;
11443     while (isalpha(*s)) s++;
11444     s2 = tz_parse_offset(s, &dst_off);
11445     if (s2) {
11446         s = s2;
11447     } else {
11448         dst_off = std_off - 3600;
11449     }
11450
11451     if (!*s) {      /* default dst start/end?? */
11452         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
11453             s = strchr(ucxtz,',');
11454         }
11455         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
11456     }
11457     if (*s != ',') return 0;
11458
11459     when = *w;
11460     when = _toutc(when);      /* convert to utc */
11461     when = when - std_off;    /* convert to pseudolocal time*/
11462
11463     w2 = localtime(&when);
11464     y = w2->tm_year;
11465     s_start = s+1;
11466     s = tz_parse_startend(s_start,w2,&dststart);
11467     if (!s) return 0;
11468     if (*s != ',') return 0;
11469
11470     when = *w;
11471     when = _toutc(when);      /* convert to utc */
11472     when = when - dst_off;    /* convert to pseudolocal time*/
11473     w2 = localtime(&when);
11474     if (w2->tm_year != y) {   /* spans a year, just check one time */
11475         when += dst_off - std_off;
11476         w2 = localtime(&when);
11477     }
11478     s_end = s+1;
11479     s = tz_parse_startend(s_end,w2,&dstend);
11480     if (!s) return 0;
11481
11482     if (reversed == -1) {  /* need to check if start later than end */
11483         int j, ds, de;
11484
11485         when = *w;
11486         if (when < 2*365*86400) {
11487             when += 2*365*86400;
11488         } else {
11489             when -= 365*86400;
11490         }
11491         w2 =localtime(&when);
11492         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
11493
11494         for (j = 0; j < 12; j++) {
11495             w2 =localtime(&when);
11496             tz_parse_startend(s_start,w2,&ds);
11497             tz_parse_startend(s_end,w2,&de);
11498             if (ds != de) break;
11499             when += 30*86400;
11500         }
11501         reversed = 0;
11502         if (de && !ds) reversed = 1;
11503     }
11504
11505     isdst = dststart && !dstend;
11506     if (reversed) isdst = dststart  || !dstend;
11507
11508 done:
11509     if (dst)    *dst = isdst;
11510     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
11511     if (isdst)  tz = dstzone;
11512     if (zone) {
11513         while(isalpha(*tz))  *zone++ = *tz++;
11514         *zone = '\0';
11515     }
11516     return 1;
11517 }
11518
11519 #endif /* !RTL_USES_UTC */
11520
11521 /* my_time(), my_localtime(), my_gmtime()
11522  * By default traffic in UTC time values, using CRTL gmtime() or
11523  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11524  * Note: We need to use these functions even when the CRTL has working
11525  * UTC support, since they also handle C<use vmsish qw(times);>
11526  *
11527  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
11528  * Modified by Charles Bailey <bailey@newman.upenn.edu>
11529  */
11530
11531 /*{{{time_t my_time(time_t *timep)*/
11532 time_t Perl_my_time(pTHX_ time_t *timep)
11533 {
11534   time_t when;
11535   struct tm *tm_p;
11536
11537   if (gmtime_emulation_type == 0) {
11538     int dstnow;
11539     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
11540                               /* results of calls to gmtime() and localtime() */
11541                               /* for same &base */
11542
11543     gmtime_emulation_type++;
11544     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11545       char off[LNM$C_NAMLENGTH+1];;
11546
11547       gmtime_emulation_type++;
11548       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11549         gmtime_emulation_type++;
11550         utc_offset_secs = 0;
11551         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11552       }
11553       else { utc_offset_secs = atol(off); }
11554     }
11555     else { /* We've got a working gmtime() */
11556       struct tm gmt, local;
11557
11558       gmt = *tm_p;
11559       tm_p = localtime(&base);
11560       local = *tm_p;
11561       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
11562       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11563       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
11564       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
11565     }
11566   }
11567
11568   when = time(NULL);
11569 # ifdef VMSISH_TIME
11570 # ifdef RTL_USES_UTC
11571   if (VMSISH_TIME) when = _toloc(when);
11572 # else
11573   if (!VMSISH_TIME) when = _toutc(when);
11574 # endif
11575 # endif
11576   if (timep != NULL) *timep = when;
11577   return when;
11578
11579 }  /* end of my_time() */
11580 /*}}}*/
11581
11582
11583 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11584 struct tm *
11585 Perl_my_gmtime(pTHX_ const time_t *timep)
11586 {
11587   char *p;
11588   time_t when;
11589   struct tm *rsltmp;
11590
11591   if (timep == NULL) {
11592     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11593     return NULL;
11594   }
11595   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11596
11597   when = *timep;
11598 # ifdef VMSISH_TIME
11599   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11600 #  endif
11601 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
11602   return gmtime(&when);
11603 # else
11604   /* CRTL localtime() wants local time as input, so does no tz correction */
11605   rsltmp = localtime(&when);
11606   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
11607   return rsltmp;
11608 #endif
11609 }  /* end of my_gmtime() */
11610 /*}}}*/
11611
11612
11613 /*{{{struct tm *my_localtime(const time_t *timep)*/
11614 struct tm *
11615 Perl_my_localtime(pTHX_ const time_t *timep)
11616 {
11617   time_t when, whenutc;
11618   struct tm *rsltmp;
11619   int dst, offset;
11620
11621   if (timep == NULL) {
11622     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11623     return NULL;
11624   }
11625   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11626   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11627
11628   when = *timep;
11629 # ifdef RTL_USES_UTC
11630 # ifdef VMSISH_TIME
11631   if (VMSISH_TIME) when = _toutc(when);
11632 # endif
11633   /* CRTL localtime() wants UTC as input, does tz correction itself */
11634   return localtime(&when);
11635
11636 # else /* !RTL_USES_UTC */
11637   whenutc = when;
11638 # ifdef VMSISH_TIME
11639   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
11640   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
11641 # endif
11642   dst = -1;
11643 #ifndef RTL_USES_UTC
11644   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
11645       when = whenutc - offset;                   /* pseudolocal time*/
11646   }
11647 # endif
11648   /* CRTL localtime() wants local time as input, so does no tz correction */
11649   rsltmp = localtime(&when);
11650   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
11651   return rsltmp;
11652 # endif
11653
11654 } /*  end of my_localtime() */
11655 /*}}}*/
11656
11657 /* Reset definitions for later calls */
11658 #define gmtime(t)    my_gmtime(t)
11659 #define localtime(t) my_localtime(t)
11660 #define time(t)      my_time(t)
11661
11662
11663 /* my_utime - update modification/access time of a file
11664  *
11665  * VMS 7.3 and later implementation
11666  * Only the UTC translation is home-grown. The rest is handled by the
11667  * CRTL utime(), which will take into account the relevant feature
11668  * logicals and ODS-5 volume characteristics for true access times.
11669  *
11670  * pre VMS 7.3 implementation:
11671  * The calling sequence is identical to POSIX utime(), but under
11672  * VMS with ODS-2, only the modification time is changed; ODS-2 does
11673  * not maintain access times.  Restrictions differ from the POSIX
11674  * definition in that the time can be changed as long as the
11675  * caller has permission to execute the necessary IO$_MODIFY $QIO;
11676  * no separate checks are made to insure that the caller is the
11677  * owner of the file or has special privs enabled.
11678  * Code here is based on Joe Meadows' FILE utility.
11679  *
11680  */
11681
11682 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11683  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
11684  * in 100 ns intervals.
11685  */
11686 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11687
11688 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11689 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11690 {
11691 #if __CRTL_VER >= 70300000
11692   struct utimbuf utc_utimes, *utc_utimesp;
11693
11694   if (utimes != NULL) {
11695     utc_utimes.actime = utimes->actime;
11696     utc_utimes.modtime = utimes->modtime;
11697 # ifdef VMSISH_TIME
11698     /* If input was local; convert to UTC for sys svc */
11699     if (VMSISH_TIME) {
11700       utc_utimes.actime = _toutc(utimes->actime);
11701       utc_utimes.modtime = _toutc(utimes->modtime);
11702     }
11703 # endif
11704     utc_utimesp = &utc_utimes;
11705   }
11706   else {
11707     utc_utimesp = NULL;
11708   }
11709
11710   return utime(file, utc_utimesp);
11711
11712 #else /* __CRTL_VER < 70300000 */
11713
11714   register int i;
11715   int sts;
11716   long int bintime[2], len = 2, lowbit, unixtime,
11717            secscale = 10000000; /* seconds --> 100 ns intervals */
11718   unsigned long int chan, iosb[2], retsts;
11719   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11720   struct FAB myfab = cc$rms_fab;
11721   struct NAM mynam = cc$rms_nam;
11722 #if defined (__DECC) && defined (__VAX)
11723   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11724    * at least through VMS V6.1, which causes a type-conversion warning.
11725    */
11726 #  pragma message save
11727 #  pragma message disable cvtdiftypes
11728 #endif
11729   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11730   struct fibdef myfib;
11731 #if defined (__DECC) && defined (__VAX)
11732   /* This should be right after the declaration of myatr, but due
11733    * to a bug in VAX DEC C, this takes effect a statement early.
11734    */
11735 #  pragma message restore
11736 #endif
11737   /* cast ok for read only parameter */
11738   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11739                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11740                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
11741
11742   if (file == NULL || *file == '\0') {
11743     SETERRNO(ENOENT, LIB$_INVARG);
11744     return -1;
11745   }
11746
11747   /* Convert to VMS format ensuring that it will fit in 255 characters */
11748   if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
11749       SETERRNO(ENOENT, LIB$_INVARG);
11750       return -1;
11751   }
11752   if (utimes != NULL) {
11753     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
11754      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11755      * Since time_t is unsigned long int, and lib$emul takes a signed long int
11756      * as input, we force the sign bit to be clear by shifting unixtime right
11757      * one bit, then multiplying by an extra factor of 2 in lib$emul().
11758      */
11759     lowbit = (utimes->modtime & 1) ? secscale : 0;
11760     unixtime = (long int) utimes->modtime;
11761 #   ifdef VMSISH_TIME
11762     /* If input was UTC; convert to local for sys svc */
11763     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
11764 #   endif
11765     unixtime >>= 1;  secscale <<= 1;
11766     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11767     if (!(retsts & 1)) {
11768       SETERRNO(EVMSERR, retsts);
11769       return -1;
11770     }
11771     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11772     if (!(retsts & 1)) {
11773       SETERRNO(EVMSERR, retsts);
11774       return -1;
11775     }
11776   }
11777   else {
11778     /* Just get the current time in VMS format directly */
11779     retsts = sys$gettim(bintime);
11780     if (!(retsts & 1)) {
11781       SETERRNO(EVMSERR, retsts);
11782       return -1;
11783     }
11784   }
11785
11786   myfab.fab$l_fna = vmsspec;
11787   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11788   myfab.fab$l_nam = &mynam;
11789   mynam.nam$l_esa = esa;
11790   mynam.nam$b_ess = (unsigned char) sizeof esa;
11791   mynam.nam$l_rsa = rsa;
11792   mynam.nam$b_rss = (unsigned char) sizeof rsa;
11793   if (decc_efs_case_preserve)
11794       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
11795
11796   /* Look for the file to be affected, letting RMS parse the file
11797    * specification for us as well.  I have set errno using only
11798    * values documented in the utime() man page for VMS POSIX.
11799    */
11800   retsts = sys$parse(&myfab,0,0);
11801   if (!(retsts & 1)) {
11802     set_vaxc_errno(retsts);
11803     if      (retsts == RMS$_PRV) set_errno(EACCES);
11804     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11805     else                         set_errno(EVMSERR);
11806     return -1;
11807   }
11808   retsts = sys$search(&myfab,0,0);
11809   if (!(retsts & 1)) {
11810     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11811     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11812     set_vaxc_errno(retsts);
11813     if      (retsts == RMS$_PRV) set_errno(EACCES);
11814     else if (retsts == RMS$_FNF) set_errno(ENOENT);
11815     else                         set_errno(EVMSERR);
11816     return -1;
11817   }
11818
11819   devdsc.dsc$w_length = mynam.nam$b_dev;
11820   /* cast ok for read only parameter */
11821   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11822
11823   retsts = sys$assign(&devdsc,&chan,0,0);
11824   if (!(retsts & 1)) {
11825     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11826     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11827     set_vaxc_errno(retsts);
11828     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
11829     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
11830     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
11831     else                               set_errno(EVMSERR);
11832     return -1;
11833   }
11834
11835   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11836   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11837
11838   memset((void *) &myfib, 0, sizeof myfib);
11839 #if defined(__DECC) || defined(__DECCXX)
11840   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11841   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11842   /* This prevents the revision time of the file being reset to the current
11843    * time as a result of our IO$_MODIFY $QIO. */
11844   myfib.fib$l_acctl = FIB$M_NORECORD;
11845 #else
11846   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11847   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11848   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11849 #endif
11850   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
11851   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11852   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11853   _ckvmssts(sys$dassgn(chan));
11854   if (retsts & 1) retsts = iosb[0];
11855   if (!(retsts & 1)) {
11856     set_vaxc_errno(retsts);
11857     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11858     else                      set_errno(EVMSERR);
11859     return -1;
11860   }
11861
11862   return 0;
11863
11864 #endif /* #if __CRTL_VER >= 70300000 */
11865
11866 }  /* end of my_utime() */
11867 /*}}}*/
11868
11869 /*
11870  * flex_stat, flex_lstat, flex_fstat
11871  * basic stat, but gets it right when asked to stat
11872  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11873  */
11874
11875 #ifndef _USE_STD_STAT
11876 /* encode_dev packs a VMS device name string into an integer to allow
11877  * simple comparisons. This can be used, for example, to check whether two
11878  * files are located on the same device, by comparing their encoded device
11879  * names. Even a string comparison would not do, because stat() reuses the
11880  * device name buffer for each call; so without encode_dev, it would be
11881  * necessary to save the buffer and use strcmp (this would mean a number of
11882  * changes to the standard Perl code, to say nothing of what a Perl script
11883  * would have to do.
11884  *
11885  * The device lock id, if it exists, should be unique (unless perhaps compared
11886  * with lock ids transferred from other nodes). We have a lock id if the disk is
11887  * mounted cluster-wide, which is when we tend to get long (host-qualified)
11888  * device names. Thus we use the lock id in preference, and only if that isn't
11889  * available, do we try to pack the device name into an integer (flagged by
11890  * the sign bit (LOCKID_MASK) being set).
11891  *
11892  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11893  * name and its encoded form, but it seems very unlikely that we will find
11894  * two files on different disks that share the same encoded device names,
11895  * and even more remote that they will share the same file id (if the test
11896  * is to check for the same file).
11897  *
11898  * A better method might be to use sys$device_scan on the first call, and to
11899  * search for the device, returning an index into the cached array.
11900  * The number returned would be more intelligible.
11901  * This is probably not worth it, and anyway would take quite a bit longer
11902  * on the first call.
11903  */
11904 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
11905 static mydev_t encode_dev (pTHX_ const char *dev)
11906 {
11907   int i;
11908   unsigned long int f;
11909   mydev_t enc;
11910   char c;
11911   const char *q;
11912
11913   if (!dev || !dev[0]) return 0;
11914
11915 #if LOCKID_MASK
11916   {
11917     struct dsc$descriptor_s dev_desc;
11918     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11919
11920     /* For cluster-mounted disks, the disk lock identifier is unique, so we
11921        can try that first. */
11922     dev_desc.dsc$w_length =  strlen (dev);
11923     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
11924     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
11925     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
11926     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11927     if (!$VMS_STATUS_SUCCESS(status)) {
11928       switch (status) {
11929         case SS$_NOSUCHDEV:
11930           SETERRNO(ENODEV, status);
11931           return 0;
11932         default:
11933           _ckvmssts(status);
11934       }
11935     }
11936     if (lockid) return (lockid & ~LOCKID_MASK);
11937   }
11938 #endif
11939
11940   /* Otherwise we try to encode the device name */
11941   enc = 0;
11942   f = 1;
11943   i = 0;
11944   for (q = dev + strlen(dev); q--; q >= dev) {
11945     if (*q == ':')
11946         break;
11947     if (isdigit (*q))
11948       c= (*q) - '0';
11949     else if (isalpha (toupper (*q)))
11950       c= toupper (*q) - 'A' + (char)10;
11951     else
11952       continue; /* Skip '$'s */
11953     i++;
11954     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
11955     if (i>1) f *= 36;
11956     enc += f * (unsigned long int) c;
11957   }
11958   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
11959
11960 }  /* end of encode_dev() */
11961 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11962         device_no = encode_dev(aTHX_ devname)
11963 #else
11964 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11965         device_no = new_dev_no
11966 #endif
11967
11968 static int
11969 is_null_device(name)
11970     const char *name;
11971 {
11972   if (decc_bug_devnull != 0) {
11973     if (strncmp("/dev/null", name, 9) == 0)
11974       return 1;
11975   }
11976     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11977        The underscore prefix, controller letter, and unit number are
11978        independently optional; for our purposes, the colon punctuation
11979        is not.  The colon can be trailed by optional directory and/or
11980        filename, but two consecutive colons indicates a nodename rather
11981        than a device.  [pr]  */
11982   if (*name == '_') ++name;
11983   if (tolower(*name++) != 'n') return 0;
11984   if (tolower(*name++) != 'l') return 0;
11985   if (tolower(*name) == 'a') ++name;
11986   if (*name == '0') ++name;
11987   return (*name++ == ':') && (*name != ':');
11988 }
11989
11990
11991 static I32
11992 Perl_cando_by_name_int
11993    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
11994 {
11995   char usrname[L_cuserid];
11996   struct dsc$descriptor_s usrdsc =
11997          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11998   char *vmsname = NULL, *fileified = NULL;
11999   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
12000   unsigned short int retlen, trnlnm_iter_count;
12001   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12002   union prvdef curprv;
12003   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
12004          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
12005          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
12006   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
12007          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
12008          {0,0,0,0}};
12009   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
12010          {0,0,0,0}};
12011   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12012   Stat_t st;
12013   static int profile_context = -1;
12014
12015   if (!fname || !*fname) return FALSE;
12016
12017   /* Make sure we expand logical names, since sys$check_access doesn't */
12018   fileified = PerlMem_malloc(VMS_MAXRSS);
12019   if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12020   if (!strpbrk(fname,"/]>:")) {
12021       strcpy(fileified,fname);
12022       trnlnm_iter_count = 0;
12023       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
12024         trnlnm_iter_count++;
12025         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
12026       }
12027       fname = fileified;
12028   }
12029
12030   vmsname = PerlMem_malloc(VMS_MAXRSS);
12031   if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12032   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
12033     /* Don't know if already in VMS format, so make sure */
12034     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
12035       PerlMem_free(fileified);
12036       PerlMem_free(vmsname);
12037       return FALSE;
12038     }
12039   }
12040   else {
12041     strcpy(vmsname,fname);
12042   }
12043
12044   /* sys$check_access needs a file spec, not a directory spec.
12045    * Don't use flex_stat here, as that depends on thread context
12046    * having been initialized, and we may get here during startup.
12047    */
12048
12049   retlen = namdsc.dsc$w_length = strlen(vmsname);
12050   if (vmsname[retlen-1] == ']'
12051       || vmsname[retlen-1] == '>'
12052       || vmsname[retlen-1] == ':'
12053       || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
12054
12055       if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) {
12056         PerlMem_free(fileified);
12057         PerlMem_free(vmsname);
12058         return FALSE;
12059       }
12060       fname = fileified;
12061   }
12062   else {
12063       fname = vmsname;
12064   }
12065
12066   retlen = namdsc.dsc$w_length = strlen(fname);
12067   namdsc.dsc$a_pointer = (char *)fname;
12068
12069   switch (bit) {
12070     case S_IXUSR: case S_IXGRP: case S_IXOTH:
12071       access = ARM$M_EXECUTE;
12072       flags = CHP$M_READ;
12073       break;
12074     case S_IRUSR: case S_IRGRP: case S_IROTH:
12075       access = ARM$M_READ;
12076       flags = CHP$M_READ | CHP$M_USEREADALL;
12077       break;
12078     case S_IWUSR: case S_IWGRP: case S_IWOTH:
12079       access = ARM$M_WRITE;
12080       flags = CHP$M_READ | CHP$M_WRITE;
12081       break;
12082     case S_IDUSR: case S_IDGRP: case S_IDOTH:
12083       access = ARM$M_DELETE;
12084       flags = CHP$M_READ | CHP$M_WRITE;
12085       break;
12086     default:
12087       if (fileified != NULL)
12088         PerlMem_free(fileified);
12089       if (vmsname != NULL)
12090         PerlMem_free(vmsname);
12091       return FALSE;
12092   }
12093
12094   /* Before we call $check_access, create a user profile with the current
12095    * process privs since otherwise it just uses the default privs from the
12096    * UAF and might give false positives or negatives.  This only works on
12097    * VMS versions v6.0 and later since that's when sys$create_user_profile
12098    * became available.
12099    */
12100
12101   /* get current process privs and username */
12102   _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
12103   _ckvmssts_noperl(iosb[0]);
12104
12105 #if defined(__VMS_VER) && __VMS_VER >= 60000000
12106
12107   /* find out the space required for the profile */
12108   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
12109                                     &usrprodsc.dsc$w_length,&profile_context));
12110
12111   /* allocate space for the profile and get it filled in */
12112   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
12113   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12114   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
12115                                     &usrprodsc.dsc$w_length,&profile_context));
12116
12117   /* use the profile to check access to the file; free profile & analyze results */
12118   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
12119   PerlMem_free(usrprodsc.dsc$a_pointer);
12120   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
12121
12122 #else
12123
12124   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
12125
12126 #endif
12127
12128   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
12129       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
12130       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
12131     set_vaxc_errno(retsts);
12132     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12133     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12134     else set_errno(ENOENT);
12135     if (fileified != NULL)
12136       PerlMem_free(fileified);
12137     if (vmsname != NULL)
12138       PerlMem_free(vmsname);
12139     return FALSE;
12140   }
12141   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12142     if (fileified != NULL)
12143       PerlMem_free(fileified);
12144     if (vmsname != NULL)
12145       PerlMem_free(vmsname);
12146     return TRUE;
12147   }
12148   _ckvmssts_noperl(retsts);
12149
12150   if (fileified != NULL)
12151     PerlMem_free(fileified);
12152   if (vmsname != NULL)
12153     PerlMem_free(vmsname);
12154   return FALSE;  /* Should never get here */
12155
12156 }
12157
12158 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
12159 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12160  * subset of the applicable information.
12161  */
12162 bool
12163 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12164 {
12165   return cando_by_name_int
12166         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12167 }  /* end of cando() */
12168 /*}}}*/
12169
12170
12171 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12172 I32
12173 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12174 {
12175    return cando_by_name_int(bit, effective, fname, 0);
12176
12177 }  /* end of cando_by_name() */
12178 /*}}}*/
12179
12180
12181 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12182 int
12183 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12184 {
12185   if (!fstat(fd,(stat_t *) statbufp)) {
12186     char *cptr;
12187     char *vms_filename;
12188     vms_filename = PerlMem_malloc(VMS_MAXRSS);
12189     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12190
12191     /* Save name for cando by name in VMS format */
12192     cptr = getname(fd, vms_filename, 1);
12193
12194     /* This should not happen, but just in case */
12195     if (cptr == NULL) {
12196         statbufp->st_devnam[0] = 0;
12197     }
12198     else {
12199         /* Make sure that the saved name fits in 255 characters */
12200         cptr = do_rmsexpand
12201                        (vms_filename,
12202                         statbufp->st_devnam,
12203                         0,
12204                         NULL,
12205                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
12206                         NULL,
12207                         NULL);
12208         if (cptr == NULL)
12209             statbufp->st_devnam[0] = 0;
12210     }
12211     PerlMem_free(vms_filename);
12212
12213     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12214     VMS_DEVICE_ENCODE
12215         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12216
12217 #   ifdef RTL_USES_UTC
12218 #   ifdef VMSISH_TIME
12219     if (VMSISH_TIME) {
12220       statbufp->st_mtime = _toloc(statbufp->st_mtime);
12221       statbufp->st_atime = _toloc(statbufp->st_atime);
12222       statbufp->st_ctime = _toloc(statbufp->st_ctime);
12223     }
12224 #   endif
12225 #   else
12226 #   ifdef VMSISH_TIME
12227     if (!VMSISH_TIME) { /* Return UTC instead of local time */
12228 #   else
12229     if (1) {
12230 #   endif
12231       statbufp->st_mtime = _toutc(statbufp->st_mtime);
12232       statbufp->st_atime = _toutc(statbufp->st_atime);
12233       statbufp->st_ctime = _toutc(statbufp->st_ctime);
12234     }
12235 #endif
12236     return 0;
12237   }
12238   return -1;
12239
12240 }  /* end of flex_fstat() */
12241 /*}}}*/
12242
12243 #if !defined(__VAX) && __CRTL_VER >= 80200000
12244 #ifdef lstat
12245 #undef lstat
12246 #endif
12247 #else
12248 #ifdef lstat
12249 #undef lstat
12250 #endif
12251 #define lstat(_x, _y) stat(_x, _y)
12252 #endif
12253
12254 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
12255
12256 static int
12257 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12258 {
12259     char fileified[VMS_MAXRSS];
12260     char temp_fspec[VMS_MAXRSS];
12261     char *save_spec;
12262     int retval = -1;
12263     dSAVEDERRNO;
12264
12265     if (!fspec) return retval;
12266     SAVE_ERRNO;
12267     strcpy(temp_fspec, fspec);
12268
12269     if (decc_bug_devnull != 0) {
12270       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
12271         memset(statbufp,0,sizeof *statbufp);
12272         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12273         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12274         statbufp->st_uid = 0x00010001;
12275         statbufp->st_gid = 0x0001;
12276         time((time_t *)&statbufp->st_mtime);
12277         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12278         return 0;
12279       }
12280     }
12281
12282     /* Try for a directory name first.  If fspec contains a filename without
12283      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12284      * and sea:[wine.dark]water. exist, we prefer the directory here.
12285      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12286      * not sea:[wine.dark]., if the latter exists.  If the intended target is
12287      * the file with null type, specify this by calling flex_stat() with
12288      * a '.' at the end of fspec.
12289      *
12290      * If we are in Posix filespec mode, accept the filename as is.
12291      */
12292
12293
12294 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12295   /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
12296    * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
12297    */
12298   if (!decc_efs_charset)
12299     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
12300 #endif
12301
12302 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12303   if (decc_posix_compliant_pathnames == 0) {
12304 #endif
12305     if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
12306       if (lstat_flag == 0)
12307         retval = stat(fileified,(stat_t *) statbufp);
12308       else
12309         retval = lstat(fileified,(stat_t *) statbufp);
12310       save_spec = fileified;
12311     }
12312     if (retval) {
12313       if (lstat_flag == 0)
12314         retval = stat(temp_fspec,(stat_t *) statbufp);
12315       else
12316         retval = lstat(temp_fspec,(stat_t *) statbufp);
12317       save_spec = temp_fspec;
12318     }
12319 /*
12320  * In debugging, on 8.3 Alpha, I found a case where stat was returning a
12321  * file not found error for a directory named foo:[bar.t] or /foo/bar/t
12322  * and lstat was working correctly for the same file.
12323  * The only syntax that was working for stat was "foo:[bar]t.dir".
12324  *
12325  * Other directories with the same syntax worked fine.
12326  * So work around the problem when it shows up here.
12327  */
12328     if (retval) {
12329         int save_errno = errno;
12330         if (do_tovmsspec(fspec, temp_fspec, 0, NULL) != NULL) {
12331             if (do_fileify_dirspec(temp_fspec, fileified, 0, NULL) != NULL) {
12332                 retval = stat(fileified, (stat_t *) statbufp);
12333                 save_spec = fileified;
12334             }
12335         }
12336         /* Restore the errno value if third stat does not succeed */
12337         if (retval != 0)
12338             errno = save_errno;
12339     }
12340 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12341   } else {
12342     if (lstat_flag == 0)
12343       retval = stat(temp_fspec,(stat_t *) statbufp);
12344     else
12345       retval = lstat(temp_fspec,(stat_t *) statbufp);
12346       save_spec = temp_fspec;
12347   }
12348 #endif
12349
12350 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12351   /* As you were... */
12352   if (!decc_efs_charset)
12353     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12354 #endif
12355
12356     if (!retval) {
12357     char * cptr;
12358     int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12359
12360       /* If this is an lstat, do not follow the link */
12361       if (lstat_flag)
12362         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12363
12364       cptr = do_rmsexpand
12365        (save_spec, statbufp->st_devnam, 0, NULL, rmsex_flags, NULL, NULL);
12366       if (cptr == NULL)
12367         statbufp->st_devnam[0] = 0;
12368
12369       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12370       VMS_DEVICE_ENCODE
12371         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12372 #     ifdef RTL_USES_UTC
12373 #     ifdef VMSISH_TIME
12374       if (VMSISH_TIME) {
12375         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12376         statbufp->st_atime = _toloc(statbufp->st_atime);
12377         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12378       }
12379 #     endif
12380 #     else
12381 #     ifdef VMSISH_TIME
12382       if (!VMSISH_TIME) { /* Return UTC instead of local time */
12383 #     else
12384       if (1) {
12385 #     endif
12386         statbufp->st_mtime = _toutc(statbufp->st_mtime);
12387         statbufp->st_atime = _toutc(statbufp->st_atime);
12388         statbufp->st_ctime = _toutc(statbufp->st_ctime);
12389       }
12390 #     endif
12391     }
12392     /* If we were successful, leave errno where we found it */
12393     if (retval == 0) RESTORE_ERRNO;
12394     return retval;
12395
12396 }  /* end of flex_stat_int() */
12397
12398
12399 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12400 int
12401 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12402 {
12403    return flex_stat_int(fspec, statbufp, 0);
12404 }
12405 /*}}}*/
12406
12407 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12408 int
12409 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12410 {
12411    return flex_stat_int(fspec, statbufp, 1);
12412 }
12413 /*}}}*/
12414
12415
12416 /*{{{char *my_getlogin()*/
12417 /* VMS cuserid == Unix getlogin, except calling sequence */
12418 char *
12419 my_getlogin(void)
12420 {
12421     static char user[L_cuserid];
12422     return cuserid(user);
12423 }
12424 /*}}}*/
12425
12426
12427 /*  rmscopy - copy a file using VMS RMS routines
12428  *
12429  *  Copies contents and attributes of spec_in to spec_out, except owner
12430  *  and protection information.  Name and type of spec_in are used as
12431  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
12432  *  should try to propagate timestamps from the input file to the output file.
12433  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
12434  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
12435  *  propagated to the output file at creation iff the output file specification
12436  *  did not contain an explicit name or type, and the revision date is always
12437  *  updated at the end of the copy operation.  If it is greater than 0, then
12438  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12439  *  other than the revision date should be propagated, and bit 1 indicates
12440  *  that the revision date should be propagated.
12441  *
12442  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12443  *
12444  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12445  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
12446  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
12447  * as part of the Perl standard distribution under the terms of the
12448  * GNU General Public License or the Perl Artistic License.  Copies
12449  * of each may be found in the Perl standard distribution.
12450  */ /* FIXME */
12451 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12452 int
12453 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12454 {
12455     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12456          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12457     unsigned long int i, sts, sts2;
12458     int dna_len;
12459     struct FAB fab_in, fab_out;
12460     struct RAB rab_in, rab_out;
12461     rms_setup_nam(nam);
12462     rms_setup_nam(nam_out);
12463     struct XABDAT xabdat;
12464     struct XABFHC xabfhc;
12465     struct XABRDT xabrdt;
12466     struct XABSUM xabsum;
12467
12468     vmsin = PerlMem_malloc(VMS_MAXRSS);
12469     if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12470     vmsout = PerlMem_malloc(VMS_MAXRSS);
12471     if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12472     if (!spec_in  || !*spec_in  || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
12473         !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
12474       PerlMem_free(vmsin);
12475       PerlMem_free(vmsout);
12476       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12477       return 0;
12478     }
12479
12480     esa = PerlMem_malloc(VMS_MAXRSS);
12481     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12482     esal = NULL;
12483 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12484     esal = PerlMem_malloc(VMS_MAXRSS);
12485     if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12486 #endif
12487     fab_in = cc$rms_fab;
12488     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12489     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12490     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12491     fab_in.fab$l_fop = FAB$M_SQO;
12492     rms_bind_fab_nam(fab_in, nam);
12493     fab_in.fab$l_xab = (void *) &xabdat;
12494
12495     rsa = PerlMem_malloc(VMS_MAXRSS);
12496     if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12497     rsal = NULL;
12498 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12499     rsal = PerlMem_malloc(VMS_MAXRSS);
12500     if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12501 #endif
12502     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12503     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12504     rms_nam_esl(nam) = 0;
12505     rms_nam_rsl(nam) = 0;
12506     rms_nam_esll(nam) = 0;
12507     rms_nam_rsll(nam) = 0;
12508 #ifdef NAM$M_NO_SHORT_UPCASE
12509     if (decc_efs_case_preserve)
12510         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12511 #endif
12512
12513     xabdat = cc$rms_xabdat;        /* To get creation date */
12514     xabdat.xab$l_nxt = (void *) &xabfhc;
12515
12516     xabfhc = cc$rms_xabfhc;        /* To get record length */
12517     xabfhc.xab$l_nxt = (void *) &xabsum;
12518
12519     xabsum = cc$rms_xabsum;        /* To get key and area information */
12520
12521     if (!((sts = sys$open(&fab_in)) & 1)) {
12522       PerlMem_free(vmsin);
12523       PerlMem_free(vmsout);
12524       PerlMem_free(esa);
12525       if (esal != NULL)
12526         PerlMem_free(esal);
12527       PerlMem_free(rsa);
12528       if (rsal != NULL)
12529         PerlMem_free(rsal);
12530       set_vaxc_errno(sts);
12531       switch (sts) {
12532         case RMS$_FNF: case RMS$_DNF:
12533           set_errno(ENOENT); break;
12534         case RMS$_DIR:
12535           set_errno(ENOTDIR); break;
12536         case RMS$_DEV:
12537           set_errno(ENODEV); break;
12538         case RMS$_SYN:
12539           set_errno(EINVAL); break;
12540         case RMS$_PRV:
12541           set_errno(EACCES); break;
12542         default:
12543           set_errno(EVMSERR);
12544       }
12545       return 0;
12546     }
12547
12548     nam_out = nam;
12549     fab_out = fab_in;
12550     fab_out.fab$w_ifi = 0;
12551     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12552     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12553     fab_out.fab$l_fop = FAB$M_SQO;
12554     rms_bind_fab_nam(fab_out, nam_out);
12555     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12556     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12557     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12558     esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12559     if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12560     rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12561     if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12562     esal_out = NULL;
12563     rsal_out = NULL;
12564 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12565     esal_out = PerlMem_malloc(VMS_MAXRSS);
12566     if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12567     rsal_out = PerlMem_malloc(VMS_MAXRSS);
12568     if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12569 #endif
12570     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12571     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12572
12573     if (preserve_dates == 0) {  /* Act like DCL COPY */
12574       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12575       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
12576       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12577         PerlMem_free(vmsin);
12578         PerlMem_free(vmsout);
12579         PerlMem_free(esa);
12580         if (esal != NULL)
12581             PerlMem_free(esal);
12582         PerlMem_free(rsa);
12583         if (rsal != NULL)
12584             PerlMem_free(rsal);
12585         PerlMem_free(esa_out);
12586         if (esal_out != NULL)
12587             PerlMem_free(esal_out);
12588         PerlMem_free(rsa_out);
12589         if (rsal_out != NULL)
12590             PerlMem_free(rsal_out);
12591         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12592         set_vaxc_errno(sts);
12593         return 0;
12594       }
12595       fab_out.fab$l_xab = (void *) &xabdat;
12596       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12597         preserve_dates = 1;
12598     }
12599     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
12600       preserve_dates =0;      /* bitmask from this point forward   */
12601
12602     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12603     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12604       PerlMem_free(vmsin);
12605       PerlMem_free(vmsout);
12606       PerlMem_free(esa);
12607       if (esal != NULL)
12608           PerlMem_free(esal);
12609       PerlMem_free(rsa);
12610       if (rsal != NULL)
12611           PerlMem_free(rsal);
12612       PerlMem_free(esa_out);
12613       if (esal_out != NULL)
12614           PerlMem_free(esal_out);
12615       PerlMem_free(rsa_out);
12616       if (rsal_out != NULL)
12617           PerlMem_free(rsal_out);
12618       set_vaxc_errno(sts);
12619       switch (sts) {
12620         case RMS$_DNF:
12621           set_errno(ENOENT); break;
12622         case RMS$_DIR:
12623           set_errno(ENOTDIR); break;
12624         case RMS$_DEV:
12625           set_errno(ENODEV); break;
12626         case RMS$_SYN:
12627           set_errno(EINVAL); break;
12628         case RMS$_PRV:
12629           set_errno(EACCES); break;
12630         default:
12631           set_errno(EVMSERR);
12632       }
12633       return 0;
12634     }
12635     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
12636     if (preserve_dates & 2) {
12637       /* sys$close() will process xabrdt, not xabdat */
12638       xabrdt = cc$rms_xabrdt;
12639 #ifndef __GNUC__
12640       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12641 #else
12642       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12643        * is unsigned long[2], while DECC & VAXC use a struct */
12644       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12645 #endif
12646       fab_out.fab$l_xab = (void *) &xabrdt;
12647     }
12648
12649     ubf = PerlMem_malloc(32256);
12650     if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12651     rab_in = cc$rms_rab;
12652     rab_in.rab$l_fab = &fab_in;
12653     rab_in.rab$l_rop = RAB$M_BIO;
12654     rab_in.rab$l_ubf = ubf;
12655     rab_in.rab$w_usz = 32256;
12656     if (!((sts = sys$connect(&rab_in)) & 1)) {
12657       sys$close(&fab_in); sys$close(&fab_out);
12658       PerlMem_free(vmsin);
12659       PerlMem_free(vmsout);
12660       PerlMem_free(ubf);
12661       PerlMem_free(esa);
12662       if (esal != NULL)
12663           PerlMem_free(esal);
12664       PerlMem_free(rsa);
12665       if (rsal != NULL)
12666           PerlMem_free(rsal);
12667       PerlMem_free(esa_out);
12668       if (esal_out != NULL)
12669           PerlMem_free(esal_out);
12670       PerlMem_free(rsa_out);
12671       if (rsal_out != NULL)
12672           PerlMem_free(rsal_out);
12673       set_errno(EVMSERR); set_vaxc_errno(sts);
12674       return 0;
12675     }
12676
12677     rab_out = cc$rms_rab;
12678     rab_out.rab$l_fab = &fab_out;
12679     rab_out.rab$l_rbf = ubf;
12680     if (!((sts = sys$connect(&rab_out)) & 1)) {
12681       sys$close(&fab_in); sys$close(&fab_out);
12682       PerlMem_free(vmsin);
12683       PerlMem_free(vmsout);
12684       PerlMem_free(ubf);
12685       PerlMem_free(esa);
12686       if (esal != NULL)
12687           PerlMem_free(esal);
12688       PerlMem_free(rsa);
12689       if (rsal != NULL)
12690           PerlMem_free(rsal);
12691       PerlMem_free(esa_out);
12692       if (esal_out != NULL)
12693           PerlMem_free(esal_out);
12694       PerlMem_free(rsa_out);
12695       if (rsal_out != NULL)
12696           PerlMem_free(rsal_out);
12697       set_errno(EVMSERR); set_vaxc_errno(sts);
12698       return 0;
12699     }
12700
12701     while ((sts = sys$read(&rab_in))) {  /* always true  */
12702       if (sts == RMS$_EOF) break;
12703       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12704       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12705         sys$close(&fab_in); sys$close(&fab_out);
12706         PerlMem_free(vmsin);
12707         PerlMem_free(vmsout);
12708         PerlMem_free(ubf);
12709         PerlMem_free(esa);
12710         if (esal != NULL)
12711             PerlMem_free(esal);
12712         PerlMem_free(rsa);
12713         if (rsal != NULL)
12714             PerlMem_free(rsal);
12715         PerlMem_free(esa_out);
12716         if (esal_out != NULL)
12717             PerlMem_free(esal_out);
12718         PerlMem_free(rsa_out);
12719         if (rsal_out != NULL)
12720             PerlMem_free(rsal_out);
12721         set_errno(EVMSERR); set_vaxc_errno(sts);
12722         return 0;
12723       }
12724     }
12725
12726
12727     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
12728     sys$close(&fab_in);  sys$close(&fab_out);
12729     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12730
12731     PerlMem_free(vmsin);
12732     PerlMem_free(vmsout);
12733     PerlMem_free(ubf);
12734     PerlMem_free(esa);
12735     if (esal != NULL)
12736         PerlMem_free(esal);
12737     PerlMem_free(rsa);
12738     if (rsal != NULL)
12739         PerlMem_free(rsal);
12740     PerlMem_free(esa_out);
12741     if (esal_out != NULL)
12742         PerlMem_free(esal_out);
12743     PerlMem_free(rsa_out);
12744     if (rsal_out != NULL)
12745         PerlMem_free(rsal_out);
12746
12747     if (!(sts & 1)) {
12748       set_errno(EVMSERR); set_vaxc_errno(sts);
12749       return 0;
12750     }
12751
12752     return 1;
12753
12754 }  /* end of rmscopy() */
12755 /*}}}*/
12756
12757
12758 /***  The following glue provides 'hooks' to make some of the routines
12759  * from this file available from Perl.  These routines are sufficiently
12760  * basic, and are required sufficiently early in the build process,
12761  * that's it's nice to have them available to miniperl as well as the
12762  * full Perl, so they're set up here instead of in an extension.  The
12763  * Perl code which handles importation of these names into a given
12764  * package lives in [.VMS]Filespec.pm in @INC.
12765  */
12766
12767 void
12768 rmsexpand_fromperl(pTHX_ CV *cv)
12769 {
12770   dXSARGS;
12771   char *fspec, *defspec = NULL, *rslt;
12772   STRLEN n_a;
12773   int fs_utf8, dfs_utf8;
12774
12775   fs_utf8 = 0;
12776   dfs_utf8 = 0;
12777   if (!items || items > 2)
12778     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12779   fspec = SvPV(ST(0),n_a);
12780   fs_utf8 = SvUTF8(ST(0));
12781   if (!fspec || !*fspec) XSRETURN_UNDEF;
12782   if (items == 2) {
12783     defspec = SvPV(ST(1),n_a);
12784     dfs_utf8 = SvUTF8(ST(1));
12785   }
12786   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12787   ST(0) = sv_newmortal();
12788   if (rslt != NULL) {
12789     sv_usepvn(ST(0),rslt,strlen(rslt));
12790     if (fs_utf8) {
12791         SvUTF8_on(ST(0));
12792     }
12793   }
12794   XSRETURN(1);
12795 }
12796
12797 void
12798 vmsify_fromperl(pTHX_ CV *cv)
12799 {
12800   dXSARGS;
12801   char *vmsified;
12802   STRLEN n_a;
12803   int utf8_fl;
12804
12805   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12806   utf8_fl = SvUTF8(ST(0));
12807   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12808   ST(0) = sv_newmortal();
12809   if (vmsified != NULL) {
12810     sv_usepvn(ST(0),vmsified,strlen(vmsified));
12811     if (utf8_fl) {
12812         SvUTF8_on(ST(0));
12813     }
12814   }
12815   XSRETURN(1);
12816 }
12817
12818 void
12819 unixify_fromperl(pTHX_ CV *cv)
12820 {
12821   dXSARGS;
12822   char *unixified;
12823   STRLEN n_a;
12824   int utf8_fl;
12825
12826   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12827   utf8_fl = SvUTF8(ST(0));
12828   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12829   ST(0) = sv_newmortal();
12830   if (unixified != NULL) {
12831     sv_usepvn(ST(0),unixified,strlen(unixified));
12832     if (utf8_fl) {
12833         SvUTF8_on(ST(0));
12834     }
12835   }
12836   XSRETURN(1);
12837 }
12838
12839 void
12840 fileify_fromperl(pTHX_ CV *cv)
12841 {
12842   dXSARGS;
12843   char *fileified;
12844   STRLEN n_a;
12845   int utf8_fl;
12846
12847   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12848   utf8_fl = SvUTF8(ST(0));
12849   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12850   ST(0) = sv_newmortal();
12851   if (fileified != NULL) {
12852     sv_usepvn(ST(0),fileified,strlen(fileified));
12853     if (utf8_fl) {
12854         SvUTF8_on(ST(0));
12855     }
12856   }
12857   XSRETURN(1);
12858 }
12859
12860 void
12861 pathify_fromperl(pTHX_ CV *cv)
12862 {
12863   dXSARGS;
12864   char *pathified;
12865   STRLEN n_a;
12866   int utf8_fl;
12867
12868   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12869   utf8_fl = SvUTF8(ST(0));
12870   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12871   ST(0) = sv_newmortal();
12872   if (pathified != NULL) {
12873     sv_usepvn(ST(0),pathified,strlen(pathified));
12874     if (utf8_fl) {
12875         SvUTF8_on(ST(0));
12876     }
12877   }
12878   XSRETURN(1);
12879 }
12880
12881 void
12882 vmspath_fromperl(pTHX_ CV *cv)
12883 {
12884   dXSARGS;
12885   char *vmspath;
12886   STRLEN n_a;
12887   int utf8_fl;
12888
12889   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12890   utf8_fl = SvUTF8(ST(0));
12891   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12892   ST(0) = sv_newmortal();
12893   if (vmspath != NULL) {
12894     sv_usepvn(ST(0),vmspath,strlen(vmspath));
12895     if (utf8_fl) {
12896         SvUTF8_on(ST(0));
12897     }
12898   }
12899   XSRETURN(1);
12900 }
12901
12902 void
12903 unixpath_fromperl(pTHX_ CV *cv)
12904 {
12905   dXSARGS;
12906   char *unixpath;
12907   STRLEN n_a;
12908   int utf8_fl;
12909
12910   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12911   utf8_fl = SvUTF8(ST(0));
12912   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12913   ST(0) = sv_newmortal();
12914   if (unixpath != NULL) {
12915     sv_usepvn(ST(0),unixpath,strlen(unixpath));
12916     if (utf8_fl) {
12917         SvUTF8_on(ST(0));
12918     }
12919   }
12920   XSRETURN(1);
12921 }
12922
12923 void
12924 candelete_fromperl(pTHX_ CV *cv)
12925 {
12926   dXSARGS;
12927   char *fspec, *fsp;
12928   SV *mysv;
12929   IO *io;
12930   STRLEN n_a;
12931
12932   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12933
12934   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12935   Newx(fspec, VMS_MAXRSS, char);
12936   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12937   if (SvTYPE(mysv) == SVt_PVGV) {
12938     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12939       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12940       ST(0) = &PL_sv_no;
12941       Safefree(fspec);
12942       XSRETURN(1);
12943     }
12944     fsp = fspec;
12945   }
12946   else {
12947     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12948       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12949       ST(0) = &PL_sv_no;
12950       Safefree(fspec);
12951       XSRETURN(1);
12952     }
12953   }
12954
12955   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12956   Safefree(fspec);
12957   XSRETURN(1);
12958 }
12959
12960 void
12961 rmscopy_fromperl(pTHX_ CV *cv)
12962 {
12963   dXSARGS;
12964   char *inspec, *outspec, *inp, *outp;
12965   int date_flag;
12966   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
12967                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12968   unsigned long int sts;
12969   SV *mysv;
12970   IO *io;
12971   STRLEN n_a;
12972
12973   if (items < 2 || items > 3)
12974     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12975
12976   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12977   Newx(inspec, VMS_MAXRSS, char);
12978   if (SvTYPE(mysv) == SVt_PVGV) {
12979     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12980       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12981       ST(0) = &PL_sv_no;
12982       Safefree(inspec);
12983       XSRETURN(1);
12984     }
12985     inp = inspec;
12986   }
12987   else {
12988     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12989       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12990       ST(0) = &PL_sv_no;
12991       Safefree(inspec);
12992       XSRETURN(1);
12993     }
12994   }
12995   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12996   Newx(outspec, VMS_MAXRSS, char);
12997   if (SvTYPE(mysv) == SVt_PVGV) {
12998     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12999       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13000       ST(0) = &PL_sv_no;
13001       Safefree(inspec);
13002       Safefree(outspec);
13003       XSRETURN(1);
13004     }
13005     outp = outspec;
13006   }
13007   else {
13008     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
13009       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13010       ST(0) = &PL_sv_no;
13011       Safefree(inspec);
13012       Safefree(outspec);
13013       XSRETURN(1);
13014     }
13015   }
13016   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
13017
13018   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
13019   Safefree(inspec);
13020   Safefree(outspec);
13021   XSRETURN(1);
13022 }
13023
13024 /* The mod2fname is limited to shorter filenames by design, so it should
13025  * not be modified to support longer EFS pathnames
13026  */
13027 void
13028 mod2fname(pTHX_ CV *cv)
13029 {
13030   dXSARGS;
13031   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
13032        workbuff[NAM$C_MAXRSS*1 + 1];
13033   int total_namelen = 3, counter, num_entries;
13034   /* ODS-5 ups this, but we want to be consistent, so... */
13035   int max_name_len = 39;
13036   AV *in_array = (AV *)SvRV(ST(0));
13037
13038   num_entries = av_len(in_array);
13039
13040   /* All the names start with PL_. */
13041   strcpy(ultimate_name, "PL_");
13042
13043   /* Clean up our working buffer */
13044   Zero(work_name, sizeof(work_name), char);
13045
13046   /* Run through the entries and build up a working name */
13047   for(counter = 0; counter <= num_entries; counter++) {
13048     /* If it's not the first name then tack on a __ */
13049     if (counter) {
13050       strcat(work_name, "__");
13051     }
13052     strcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)));
13053   }
13054
13055   /* Check to see if we actually have to bother...*/
13056   if (strlen(work_name) + 3 <= max_name_len) {
13057     strcat(ultimate_name, work_name);
13058   } else {
13059     /* It's too darned big, so we need to go strip. We use the same */
13060     /* algorithm as xsubpp does. First, strip out doubled __ */
13061     char *source, *dest, last;
13062     dest = workbuff;
13063     last = 0;
13064     for (source = work_name; *source; source++) {
13065       if (last == *source && last == '_') {
13066         continue;
13067       }
13068       *dest++ = *source;
13069       last = *source;
13070     }
13071     /* Go put it back */
13072     strcpy(work_name, workbuff);
13073     /* Is it still too big? */
13074     if (strlen(work_name) + 3 > max_name_len) {
13075       /* Strip duplicate letters */
13076       last = 0;
13077       dest = workbuff;
13078       for (source = work_name; *source; source++) {
13079         if (last == toupper(*source)) {
13080         continue;
13081         }
13082         *dest++ = *source;
13083         last = toupper(*source);
13084       }
13085       strcpy(work_name, workbuff);
13086     }
13087
13088     /* Is it *still* too big? */
13089     if (strlen(work_name) + 3 > max_name_len) {
13090       /* Too bad, we truncate */
13091       work_name[max_name_len - 2] = 0;
13092     }
13093     strcat(ultimate_name, work_name);
13094   }
13095
13096   /* Okay, return it */
13097   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
13098   XSRETURN(1);
13099 }
13100
13101 void
13102 hushexit_fromperl(pTHX_ CV *cv)
13103 {
13104     dXSARGS;
13105
13106     if (items > 0) {
13107         VMSISH_HUSHED = SvTRUE(ST(0));
13108     }
13109     ST(0) = boolSV(VMSISH_HUSHED);
13110     XSRETURN(1);
13111 }
13112
13113
13114 PerlIO *
13115 Perl_vms_start_glob
13116    (pTHX_ SV *tmpglob,
13117     IO *io)
13118 {
13119     PerlIO *fp;
13120     struct vs_str_st *rslt;
13121     char *vmsspec;
13122     char *rstr;
13123     char *begin, *cp;
13124     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13125     PerlIO *tmpfp;
13126     STRLEN i;
13127     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13128     struct dsc$descriptor_vs rsdsc;
13129     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13130     unsigned long hasver = 0, isunix = 0;
13131     unsigned long int lff_flags = 0;
13132     int rms_sts;
13133
13134     if (!SvOK(tmpglob)) {
13135         SETERRNO(ENOENT,RMS$_FNF);
13136         return NULL;
13137     }
13138
13139 #ifdef VMS_LONGNAME_SUPPORT
13140     lff_flags = LIB$M_FIL_LONG_NAMES;
13141 #endif
13142     /* The Newx macro will not allow me to assign a smaller array
13143      * to the rslt pointer, so we will assign it to the begin char pointer
13144      * and then copy the value into the rslt pointer.
13145      */
13146     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13147     rslt = (struct vs_str_st *)begin;
13148     rslt->length = 0;
13149     rstr = &rslt->str[0];
13150     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13151     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13152     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13153     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13154
13155     Newx(vmsspec, VMS_MAXRSS, char);
13156
13157         /* We could find out if there's an explicit dev/dir or version
13158            by peeking into lib$find_file's internal context at
13159            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13160            but that's unsupported, so I don't want to do it now and
13161            have it bite someone in the future. */
13162         /* Fix-me: vms_split_path() is the only way to do this, the
13163            existing method will fail with many legal EFS or UNIX specifications
13164          */
13165
13166     cp = SvPV(tmpglob,i);
13167
13168     for (; i; i--) {
13169         if (cp[i] == ';') hasver = 1;
13170         if (cp[i] == '.') {
13171             if (sts) hasver = 1;
13172             else sts = 1;
13173         }
13174         if (cp[i] == '/') {
13175             hasdir = isunix = 1;
13176             break;
13177         }
13178         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13179             hasdir = 1;
13180             break;
13181         }
13182     }
13183     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13184         int found = 0;
13185         Stat_t st;
13186         int stat_sts;
13187         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13188         if (!stat_sts && S_ISDIR(st.st_mode)) {
13189             wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
13190             ok = (wilddsc.dsc$a_pointer != NULL);
13191             /* maybe passed 'foo' rather than '[.foo]', thus not detected above */
13192             hasdir = 1;
13193         }
13194         else {
13195             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13196             ok = (wilddsc.dsc$a_pointer != NULL);
13197         }
13198         if (ok)
13199             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13200
13201         /* If not extended character set, replace ? with % */
13202         /* With extended character set, ? is a wildcard single character */
13203         if (!decc_efs_case_preserve) {
13204             for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
13205                 if (*cp == '?') *cp = '%';
13206         }
13207         sts = SS$_NORMAL;
13208         while (ok && $VMS_STATUS_SUCCESS(sts)) {
13209          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13210          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13211
13212             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13213                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
13214             if (!$VMS_STATUS_SUCCESS(sts))
13215                 break;
13216
13217             found++;
13218
13219             /* with varying string, 1st word of buffer contains result length */
13220             rstr[rslt->length] = '\0';
13221
13222              /* Find where all the components are */
13223              v_sts = vms_split_path
13224                        (rstr,
13225                         &v_spec,
13226                         &v_len,
13227                         &r_spec,
13228                         &r_len,
13229                         &d_spec,
13230                         &d_len,
13231                         &n_spec,
13232                         &n_len,
13233                         &e_spec,
13234                         &e_len,
13235                         &vs_spec,
13236                         &vs_len);
13237
13238             /* If no version on input, truncate the version on output */
13239             if (!hasver && (vs_len > 0)) {
13240                 *vs_spec = '\0';
13241                 vs_len = 0;
13242
13243                 /* No version & a null extension on UNIX handling */
13244                 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
13245                     e_len = 0;
13246                     *e_spec = '\0';
13247                 }
13248             }
13249
13250             if (!decc_efs_case_preserve) {
13251                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13252             }
13253
13254             if (hasdir) {
13255                 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13256                 begin = rstr;
13257             }
13258             else {
13259                 /* Start with the name */
13260                 begin = n_spec;
13261             }
13262             strcat(begin,"\n");
13263             ok = (PerlIO_puts(tmpfp,begin) != EOF);
13264         }
13265         if (cxt) (void)lib$find_file_end(&cxt);
13266
13267         if (!found) {
13268             /* Be POSIXish: return the input pattern when no matches */
13269             strcpy(rstr,SvPVX(tmpglob));
13270             strcat(rstr,"\n");
13271             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13272         }
13273
13274         if (ok && sts != RMS$_NMF &&
13275             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13276         if (!ok) {
13277             if (!(sts & 1)) {
13278                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13279             }
13280             PerlIO_close(tmpfp);
13281             fp = NULL;
13282         }
13283         else {
13284             PerlIO_rewind(tmpfp);
13285             IoTYPE(io) = IoTYPE_RDONLY;
13286             IoIFP(io) = fp = tmpfp;
13287             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
13288         }
13289     }
13290     Safefree(vmsspec);
13291     Safefree(rslt);
13292     return fp;
13293 }
13294
13295
13296 static char *
13297 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13298                    int *utf8_fl);
13299
13300 void
13301 unixrealpath_fromperl(pTHX_ CV *cv)
13302 {
13303     dXSARGS;
13304     char *fspec, *rslt_spec, *rslt;
13305     STRLEN n_a;
13306
13307     if (!items || items != 1)
13308         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
13309
13310     fspec = SvPV(ST(0),n_a);
13311     if (!fspec || !*fspec) XSRETURN_UNDEF;
13312
13313     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13314     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13315
13316     ST(0) = sv_newmortal();
13317     if (rslt != NULL)
13318         sv_usepvn(ST(0),rslt,strlen(rslt));
13319     else
13320         Safefree(rslt_spec);
13321         XSRETURN(1);
13322 }
13323
13324 static char *
13325 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13326                    int *utf8_fl);
13327
13328 void
13329 vmsrealpath_fromperl(pTHX_ CV *cv)
13330 {
13331     dXSARGS;
13332     char *fspec, *rslt_spec, *rslt;
13333     STRLEN n_a;
13334
13335     if (!items || items != 1)
13336         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
13337
13338     fspec = SvPV(ST(0),n_a);
13339     if (!fspec || !*fspec) XSRETURN_UNDEF;
13340
13341     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13342     rslt = do_vms_realname(fspec, rslt_spec, NULL);
13343
13344     ST(0) = sv_newmortal();
13345     if (rslt != NULL)
13346         sv_usepvn(ST(0),rslt,strlen(rslt));
13347     else
13348         Safefree(rslt_spec);
13349         XSRETURN(1);
13350 }
13351
13352 #ifdef HAS_SYMLINK
13353 /*
13354  * A thin wrapper around decc$symlink to make sure we follow the
13355  * standard and do not create a symlink with a zero-length name.
13356  *
13357  * Also in ODS-2 mode, existing tests assume that the link target
13358  * will be converted to UNIX format.
13359  */
13360 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
13361 int Perl_my_symlink(pTHX_ const char *contents, const char *link_name) {
13362   if (!link_name || !*link_name) {
13363     SETERRNO(ENOENT, SS$_NOSUCHFILE);
13364     return -1;
13365   }
13366
13367   if (decc_efs_charset) {
13368       return symlink(contents, link_name);
13369   } else {
13370       int sts;
13371       char * utarget;
13372
13373       /* Unless we are in ODS-5 mode, convert the symlink target to UNIX */
13374       /* because in order to work, the symlink target must be in UNIX format */
13375
13376       /* As symbolic links can hold things other than files, we will only do */
13377       /* the conversion in in ODS-2 mode */
13378
13379       Newx(utarget, VMS_MAXRSS + 1, char);
13380       if (do_tounixspec(contents, utarget, 0, NULL) == NULL) {
13381
13382           /* This should not fail, as an untranslatable filename */
13383           /* should be passed through */
13384           utarget = (char *)contents;
13385       }
13386       sts = symlink(utarget, link_name);
13387       Safefree(utarget);
13388       return sts;
13389   }
13390
13391 }
13392 /*}}}*/
13393
13394 #endif /* HAS_SYMLINK */
13395
13396 int do_vms_case_tolerant(void);
13397
13398 void
13399 case_tolerant_process_fromperl(pTHX_ CV *cv)
13400 {
13401   dXSARGS;
13402   ST(0) = boolSV(do_vms_case_tolerant());
13403   XSRETURN(1);
13404 }
13405
13406 #ifdef USE_ITHREADS
13407
13408 void
13409 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13410                           struct interp_intern *dst)
13411 {
13412     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13413
13414     memcpy(dst,src,sizeof(struct interp_intern));
13415 }
13416
13417 #endif
13418
13419 void
13420 Perl_sys_intern_clear(pTHX)
13421 {
13422 }
13423
13424 void
13425 Perl_sys_intern_init(pTHX)
13426 {
13427     unsigned int ix = RAND_MAX;
13428     double x;
13429
13430     VMSISH_HUSHED = 0;
13431
13432     MY_POSIX_EXIT = vms_posix_exit;
13433
13434     x = (float)ix;
13435     MY_INV_RAND_MAX = 1./x;
13436 }
13437
13438 void
13439 init_os_extras(void)
13440 {
13441   dTHX;
13442   char* file = __FILE__;
13443   if (decc_disable_to_vms_logname_translation) {
13444     no_translate_barewords = TRUE;
13445   } else {
13446     no_translate_barewords = FALSE;
13447   }
13448
13449   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13450   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13451   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13452   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13453   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13454   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13455   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13456   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13457   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13458   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13459   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13460   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13461   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13462   newXSproto("VMS::Filespec::case_tolerant_process",
13463       case_tolerant_process_fromperl,file,"");
13464
13465   store_pipelocs(aTHX);         /* will redo any earlier attempts */
13466
13467   return;
13468 }
13469
13470 #if __CRTL_VER == 80200000
13471 /* This missed getting in to the DECC SDK for 8.2 */
13472 char *realpath(const char *file_name, char * resolved_name, ...);
13473 #endif
13474
13475 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13476 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13477  * The perl fallback routine to provide realpath() is not as efficient
13478  * on OpenVMS.
13479  */
13480
13481 /* Hack, use old stat() as fastest way of getting ino_t and device */
13482 int decc$stat(const char *name, void * statbuf);
13483
13484
13485 /* Realpath is fragile.  In 8.3 it does not work if the feature
13486  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13487  * links are implemented in RMS, not the CRTL. It also can fail if the
13488  * user does not have read/execute access to some of the directories.
13489  * So in order for Do What I Mean mode to work, if realpath() fails,
13490  * fall back to looking up the filename by the device name and FID.
13491  */
13492
13493 int vms_fid_to_name(char * outname, int outlen, const char * name)
13494 {
13495 struct statbuf_t {
13496     char           * st_dev;
13497     unsigned short st_ino[3];
13498     unsigned short padw;
13499     unsigned long  padl[30];  /* plenty of room */
13500 } statbuf;
13501 int sts;
13502 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13503 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13504
13505     sts = decc$stat(name, &statbuf);
13506     if (sts == 0) {
13507
13508         dvidsc.dsc$a_pointer=statbuf.st_dev;
13509        dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13510
13511         specdsc.dsc$a_pointer = outname;
13512         specdsc.dsc$w_length = outlen-1;
13513
13514        sts = lib$fid_to_name
13515             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13516        if ($VMS_STATUS_SUCCESS(sts)) {
13517             outname[specdsc.dsc$w_length] = 0;
13518             return 0;
13519         }
13520     }
13521     return sts;
13522 }
13523
13524
13525
13526 static char *
13527 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13528                    int *utf8_fl)
13529 {
13530     char * rslt = NULL;
13531
13532 #ifdef HAS_SYMLINK
13533     if (decc_posix_compliant_pathnames > 0 ) {
13534         /* realpath currently only works if posix compliant pathnames are
13535          * enabled.  It may start working when they are not, but in that
13536          * case we still want the fallback behavior for backwards compatibility
13537          */
13538         rslt = realpath(filespec, outbuf);
13539     }
13540 #endif
13541
13542     if (rslt == NULL) {
13543         char * vms_spec;
13544         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13545         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13546         int file_len;
13547
13548         /* Fall back to fid_to_name */
13549
13550         Newx(vms_spec, VMS_MAXRSS + 1, char);
13551
13552         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec);
13553         if (sts == 0) {
13554
13555
13556             /* Now need to trim the version off */
13557             sts = vms_split_path
13558                   (vms_spec,
13559                    &v_spec,
13560                    &v_len,
13561                    &r_spec,
13562                    &r_len,
13563                    &d_spec,
13564                    &d_len,
13565                    &n_spec,
13566                    &n_len,
13567                    &e_spec,
13568                    &e_len,
13569                    &vs_spec,
13570                    &vs_len);
13571
13572
13573                 if (sts == 0) {
13574                     int haslower = 0;
13575                     const char *cp;
13576
13577                     /* Trim off the version */
13578                     int file_len = v_len + r_len + d_len + n_len + e_len;
13579                     vms_spec[file_len] = 0;
13580
13581                     /* The result is expected to be in UNIX format */
13582                     rslt = do_tounixspec(vms_spec, outbuf, 0, utf8_fl);
13583
13584                     /* Downcase if input had any lower case letters and
13585                      * case preservation is not in effect.
13586                      */
13587                     if (!decc_efs_case_preserve) {
13588                         for (cp = filespec; *cp; cp++)
13589                             if (islower(*cp)) { haslower = 1; break; }
13590
13591                         if (haslower) __mystrtolower(rslt);
13592                     }
13593                 }
13594         } else {
13595
13596             /* Now for some hacks to deal with backwards and forward */
13597             /* compatibilty */
13598             if (!decc_efs_charset) {
13599
13600                 /* 1. ODS-2 mode wants to do a syntax only translation */
13601                 rslt = do_rmsexpand(filespec, outbuf,
13602                                     0, NULL, 0, NULL, utf8_fl);
13603
13604             } else {
13605                 if (decc_filename_unix_report) {
13606                     char * dir_name;
13607                     char * vms_dir_name;
13608                     char * file_name;
13609
13610                     /* 2. ODS-5 / UNIX report mode should return a failure */
13611                     /*    if the parent directory also does not exist */
13612                     /*    Otherwise, get the real path for the parent */
13613                     /*    and add the child to it.
13614
13615                     /* basename / dirname only available for VMS 7.0+ */
13616                     /* So we may need to implement them as common routines */
13617
13618                     Newx(dir_name, VMS_MAXRSS + 1, char);
13619                     Newx(vms_dir_name, VMS_MAXRSS + 1, char);
13620                     dir_name[0] = '\0';
13621                     file_name = NULL;
13622
13623                     /* First try a VMS parse */
13624                     sts = vms_split_path
13625                           (filespec,
13626                            &v_spec,
13627                            &v_len,
13628                            &r_spec,
13629                            &r_len,
13630                            &d_spec,
13631                            &d_len,
13632                            &n_spec,
13633                            &n_len,
13634                            &e_spec,
13635                            &e_len,
13636                            &vs_spec,
13637                            &vs_len);
13638
13639                     if (sts == 0) {
13640                         /* This is VMS */
13641
13642                         int dir_len = v_len + r_len + d_len + n_len;
13643                         if (dir_len > 0) {
13644                            strncpy(dir_name, filespec, dir_len);
13645                            dir_name[dir_len] = '\0';
13646                            file_name = (char *)&filespec[dir_len + 1];
13647                         }
13648                     } else {
13649                         /* This must be UNIX */
13650                         char * tchar;
13651
13652                         tchar = strrchr(filespec, '/');
13653
13654                         if (tchar != NULL) {
13655                             int dir_len = tchar - filespec;
13656                             strncpy(dir_name, filespec, dir_len);
13657                             dir_name[dir_len] = '\0';
13658                             file_name = (char *) &filespec[dir_len + 1];
13659                         }
13660                     }
13661
13662                     /* Dir name is defaulted */
13663                     if (dir_name[0] == 0) {
13664                         dir_name[0] = '.';
13665                         dir_name[1] = '\0';
13666                     }
13667
13668                     /* Need realpath for the directory */
13669                     sts = vms_fid_to_name(vms_dir_name,
13670                                           VMS_MAXRSS + 1,
13671                                           dir_name);
13672
13673                     if (sts == 0) {
13674                         /* Now need to pathify it.
13675                         char *tdir = do_pathify_dirspec(vms_dir_name,
13676                                                         outbuf, utf8_fl);
13677
13678                         /* And now add the original filespec to it */
13679                         if (file_name != NULL) {
13680                             strcat(outbuf, file_name);
13681                         }
13682                         return outbuf;
13683                     }
13684                     Safefree(vms_dir_name);
13685                     Safefree(dir_name);
13686                 }
13687             }
13688         }
13689         Safefree(vms_spec);
13690     }
13691     return rslt;
13692 }
13693
13694 static char *
13695 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13696                    int *utf8_fl)
13697 {
13698     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13699     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13700     int file_len;
13701
13702     /* Fall back to fid_to_name */
13703
13704     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec);
13705     if (sts != 0) {
13706         return NULL;
13707     }
13708     else {
13709
13710
13711         /* Now need to trim the version off */
13712         sts = vms_split_path
13713                   (outbuf,
13714                    &v_spec,
13715                    &v_len,
13716                    &r_spec,
13717                    &r_len,
13718                    &d_spec,
13719                    &d_len,
13720                    &n_spec,
13721                    &n_len,
13722                    &e_spec,
13723                    &e_len,
13724                    &vs_spec,
13725                    &vs_len);
13726
13727
13728         if (sts == 0) {
13729             int haslower = 0;
13730             const char *cp;
13731
13732             /* Trim off the version */
13733             int file_len = v_len + r_len + d_len + n_len + e_len;
13734             outbuf[file_len] = 0;
13735
13736             /* Downcase if input had any lower case letters and
13737              * case preservation is not in effect.
13738              */
13739             if (!decc_efs_case_preserve) {
13740                 for (cp = filespec; *cp; cp++)
13741                     if (islower(*cp)) { haslower = 1; break; }
13742
13743                 if (haslower) __mystrtolower(outbuf);
13744             }
13745         }
13746     }
13747     return outbuf;
13748 }
13749
13750
13751 /*}}}*/
13752 /* External entry points */
13753 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13754 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
13755
13756 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13757 { return do_vms_realname(filespec, outbuf, utf8_fl); }
13758
13759 /* case_tolerant */
13760
13761 /*{{{int do_vms_case_tolerant(void)*/
13762 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13763  * controlled by a process setting.
13764  */
13765 int do_vms_case_tolerant(void)
13766 {
13767     return vms_process_case_tolerant;
13768 }
13769 /*}}}*/
13770 /* External entry points */
13771 #if __CRTL_VER >= 70301000 && !defined(__VAX)
13772 int Perl_vms_case_tolerant(void)
13773 { return do_vms_case_tolerant(); }
13774 #else
13775 int Perl_vms_case_tolerant(void)
13776 { return vms_process_case_tolerant; }
13777 #endif
13778
13779
13780  /* Start of DECC RTL Feature handling */
13781
13782 static int sys_trnlnm
13783    (const char * logname,
13784     char * value,
13785     int value_len)
13786 {
13787     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
13788     const unsigned long attr = LNM$M_CASE_BLIND;
13789     struct dsc$descriptor_s name_dsc;
13790     int status;
13791     unsigned short result;
13792     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
13793                                 {0, 0, 0, 0}};
13794
13795     name_dsc.dsc$w_length = strlen(logname);
13796     name_dsc.dsc$a_pointer = (char *)logname;
13797     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13798     name_dsc.dsc$b_class = DSC$K_CLASS_S;
13799
13800     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
13801
13802     if ($VMS_STATUS_SUCCESS(status)) {
13803
13804          /* Null terminate and return the string */
13805         /*--------------------------------------*/
13806         value[result] = 0;
13807     }
13808
13809     return status;
13810 }
13811
13812 static int sys_crelnm
13813    (const char * logname,
13814     const char * value)
13815 {
13816     int ret_val;
13817     const char * proc_table = "LNM$PROCESS_TABLE";
13818     struct dsc$descriptor_s proc_table_dsc;
13819     struct dsc$descriptor_s logname_dsc;
13820     struct itmlst_3 item_list[2];
13821
13822     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
13823     proc_table_dsc.dsc$w_length = strlen(proc_table);
13824     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13825     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
13826
13827     logname_dsc.dsc$a_pointer = (char *) logname;
13828     logname_dsc.dsc$w_length = strlen(logname);
13829     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13830     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
13831
13832     item_list[0].buflen = strlen(value);
13833     item_list[0].itmcode = LNM$_STRING;
13834     item_list[0].bufadr = (char *)value;
13835     item_list[0].retlen = NULL;
13836
13837     item_list[1].buflen = 0;
13838     item_list[1].itmcode = 0;
13839
13840     ret_val = sys$crelnm
13841                        (NULL,
13842                         (const struct dsc$descriptor_s *)&proc_table_dsc,
13843                         (const struct dsc$descriptor_s *)&logname_dsc,
13844                         NULL,
13845                         (const struct item_list_3 *) item_list);
13846
13847     return ret_val;
13848 }
13849
13850 /* C RTL Feature settings */
13851
13852 static int set_features
13853    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
13854     int (* cli_routine)(void),  /* Not documented */
13855     void *image_info)           /* Not documented */
13856 {
13857     int status;
13858     int s;
13859     char* str;
13860     char val_str[10];
13861 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13862     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13863     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13864     unsigned long case_perm;
13865     unsigned long case_image;
13866 #endif
13867
13868     /* Allow an exception to bring Perl into the VMS debugger */
13869     vms_debug_on_exception = 0;
13870     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
13871     if ($VMS_STATUS_SUCCESS(status)) {
13872        val_str[0] = _toupper(val_str[0]);
13873        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13874          vms_debug_on_exception = 1;
13875        else
13876          vms_debug_on_exception = 0;
13877     }
13878
13879     /* Debug unix/vms file translation routines */
13880     vms_debug_fileify = 0;
13881     status = sys_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
13882     if ($VMS_STATUS_SUCCESS(status)) {
13883         val_str[0] = _toupper(val_str[0]);
13884         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13885             vms_debug_fileify = 1;
13886         else
13887             vms_debug_fileify = 0;
13888     }
13889
13890
13891     /* Historically PERL has been doing vmsify / stat differently than */
13892     /* the CRTL.  In particular, under some conditions the CRTL will   */
13893     /* remove some illegal characters like spaces from filenames       */
13894     /* resulting in some differences.  The stat()/lstat() wrapper has  */
13895     /* been reporting such file names as invalid and fails to stat them */
13896     /* fixing this bug so that stat()/lstat() accept these like the     */
13897     /* CRTL does will result in several tests failing.                  */
13898     /* This should really be fixed, but for now, set up a feature to    */
13899     /* enable it so that the impact can be studied.                     */
13900     vms_bug_stat_filename = 0;
13901     status = sys_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
13902     if ($VMS_STATUS_SUCCESS(status)) {
13903         val_str[0] = _toupper(val_str[0]);
13904         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13905             vms_bug_stat_filename = 1;
13906         else
13907             vms_bug_stat_filename = 0;
13908     }
13909
13910
13911     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
13912     vms_vtf7_filenames = 0;
13913     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
13914     if ($VMS_STATUS_SUCCESS(status)) {
13915        val_str[0] = _toupper(val_str[0]);
13916        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13917          vms_vtf7_filenames = 1;
13918        else
13919          vms_vtf7_filenames = 0;
13920     }
13921
13922     /* unlink all versions on unlink() or rename() */
13923     vms_unlink_all_versions = 0;
13924     status = sys_trnlnm
13925         ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13926     if ($VMS_STATUS_SUCCESS(status)) {
13927        val_str[0] = _toupper(val_str[0]);
13928        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13929          vms_unlink_all_versions = 1;
13930        else
13931          vms_unlink_all_versions = 0;
13932     }
13933
13934     /* Dectect running under GNV Bash or other UNIX like shell */
13935 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13936     gnv_unix_shell = 0;
13937     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
13938     if ($VMS_STATUS_SUCCESS(status)) {
13939          gnv_unix_shell = 1;
13940          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
13941          set_feature_default("DECC$EFS_CHARSET", 1);
13942          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
13943          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
13944          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
13945          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
13946          vms_unlink_all_versions = 1;
13947          vms_posix_exit = 1;
13948     }
13949 #endif
13950
13951     /* hacks to see if known bugs are still present for testing */
13952
13953     /* PCP mode requires creating /dev/null special device file */
13954     decc_bug_devnull = 0;
13955     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
13956     if ($VMS_STATUS_SUCCESS(status)) {
13957        val_str[0] = _toupper(val_str[0]);
13958        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13959           decc_bug_devnull = 1;
13960        else
13961           decc_bug_devnull = 0;
13962     }
13963
13964     /* UNIX directory names with no paths are broken in a lot of places */
13965     decc_dir_barename = 1;
13966     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
13967     if ($VMS_STATUS_SUCCESS(status)) {
13968       val_str[0] = _toupper(val_str[0]);
13969       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13970         decc_dir_barename = 1;
13971       else
13972         decc_dir_barename = 0;
13973     }
13974
13975 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13976     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
13977     if (s >= 0) {
13978         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
13979         if (decc_disable_to_vms_logname_translation < 0)
13980             decc_disable_to_vms_logname_translation = 0;
13981     }
13982
13983     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
13984     if (s >= 0) {
13985         decc_efs_case_preserve = decc$feature_get_value(s, 1);
13986         if (decc_efs_case_preserve < 0)
13987             decc_efs_case_preserve = 0;
13988     }
13989
13990     s = decc$feature_get_index("DECC$EFS_CHARSET");
13991     decc_efs_charset_index = s;
13992     if (s >= 0) {
13993         decc_efs_charset = decc$feature_get_value(s, 1);
13994         if (decc_efs_charset < 0)
13995             decc_efs_charset = 0;
13996     }
13997
13998     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
13999     if (s >= 0) {
14000         decc_filename_unix_report = decc$feature_get_value(s, 1);
14001         if (decc_filename_unix_report > 0) {
14002             decc_filename_unix_report = 1;
14003             vms_posix_exit = 1;
14004         }
14005         else
14006             decc_filename_unix_report = 0;
14007     }
14008
14009     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14010     if (s >= 0) {
14011         decc_filename_unix_only = decc$feature_get_value(s, 1);
14012         if (decc_filename_unix_only > 0) {
14013             decc_filename_unix_only = 1;
14014         }
14015         else {
14016             decc_filename_unix_only = 0;
14017         }
14018     }
14019
14020     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14021     if (s >= 0) {
14022         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14023         if (decc_filename_unix_no_version < 0)
14024             decc_filename_unix_no_version = 0;
14025     }
14026
14027     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14028     if (s >= 0) {
14029         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14030         if (decc_readdir_dropdotnotype < 0)
14031             decc_readdir_dropdotnotype = 0;
14032     }
14033
14034 #if __CRTL_VER >= 80200000
14035     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14036     if (s >= 0) {
14037         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14038         if (decc_posix_compliant_pathnames < 0)
14039             decc_posix_compliant_pathnames = 0;
14040         if (decc_posix_compliant_pathnames > 4)
14041             decc_posix_compliant_pathnames = 0;
14042     }
14043
14044 #endif
14045 #else
14046     status = sys_trnlnm
14047         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
14048     if ($VMS_STATUS_SUCCESS(status)) {
14049         val_str[0] = _toupper(val_str[0]);
14050         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14051            decc_disable_to_vms_logname_translation = 1;
14052         }
14053     }
14054
14055 #ifndef __VAX
14056     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
14057     if ($VMS_STATUS_SUCCESS(status)) {
14058         val_str[0] = _toupper(val_str[0]);
14059         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14060            decc_efs_case_preserve = 1;
14061         }
14062     }
14063 #endif
14064
14065     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14066     if ($VMS_STATUS_SUCCESS(status)) {
14067         val_str[0] = _toupper(val_str[0]);
14068         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14069            decc_filename_unix_report = 1;
14070         }
14071     }
14072     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14073     if ($VMS_STATUS_SUCCESS(status)) {
14074         val_str[0] = _toupper(val_str[0]);
14075         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14076            decc_filename_unix_only = 1;
14077            decc_filename_unix_report = 1;
14078         }
14079     }
14080     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14081     if ($VMS_STATUS_SUCCESS(status)) {
14082         val_str[0] = _toupper(val_str[0]);
14083         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14084            decc_filename_unix_no_version = 1;
14085         }
14086     }
14087     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", 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            decc_readdir_dropdotnotype = 1;
14092         }
14093     }
14094 #endif
14095
14096 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
14097
14098      /* Report true case tolerance */
14099     /*----------------------------*/
14100     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14101     if (!$VMS_STATUS_SUCCESS(status))
14102         case_perm = PPROP$K_CASE_BLIND;
14103     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14104     if (!$VMS_STATUS_SUCCESS(status))
14105         case_image = PPROP$K_CASE_BLIND;
14106     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14107         (case_image == PPROP$K_CASE_SENSITIVE))
14108         vms_process_case_tolerant = 0;
14109
14110 #endif
14111
14112     /* USE POSIX/DCL Exit codes - Recommended, but needs to default to  */
14113     /* for strict backward compatibilty */
14114     status = sys_trnlnm
14115         ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14116     if ($VMS_STATUS_SUCCESS(status)) {
14117        val_str[0] = _toupper(val_str[0]);
14118        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14119          vms_posix_exit = 1;
14120        else
14121          vms_posix_exit = 0;
14122     }
14123
14124
14125     /* CRTL can be initialized past this point, but not before. */
14126 /*    DECC$CRTL_INIT(); */
14127
14128     return SS$_NORMAL;
14129 }
14130
14131 #ifdef __DECC
14132 #pragma nostandard
14133 #pragma extern_model save
14134 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
14135         const __align (LONGWORD) int spare[8] = {0};
14136
14137 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
14138 #if __DECC_VER >= 60560002
14139 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
14140 #else
14141 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
14142 #endif
14143 #endif /* __DECC */
14144
14145 const long vms_cc_features = (const long)set_features;
14146
14147 /*
14148 ** Force a reference to LIB$INITIALIZE to ensure it
14149 ** exists in the image.
14150 */
14151 int lib$initialize(void);
14152 #ifdef __DECC
14153 #pragma extern_model strict_refdef
14154 #endif
14155     int lib_init_ref = (int) lib$initialize;
14156
14157 #ifdef __DECC
14158 #pragma extern_model restore
14159 #pragma standard
14160 #endif
14161
14162 /*  End of vms.c */