vms/vms.c

   1 /*    vms.c
   2  *
   3  *    VMS-specific routines for perl5
   4  *
   5  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
   6  *    2002, 2003, 2004, 2005, 2006, 2007 by Charles Bailey and others.
   7  *
   8  *    You may distribute under the terms of either the GNU General Public
   9  *    License or the Artistic License, as specified in the README file.
  10  *
  11  *    Please see Changes*.* or the Perl Repository Browser for revision history.
  12  */
  13
  14 /*
  15  *   Yet small as was their hunted band
  16  *   still fell and fearless was each hand,
  17  *   and strong deeds they wrought yet oft,
  18  *   and loved the woods, whose ways more soft
  19  *   them seemed than thralls of that black throne
  20  *   to live and languish in halls of stone.
  21  *        "The Lay of Leithian", Canto II, lines 135-40
  22  *
  23  *     [p.162 of _The Lays of Beleriand_]
  24  */
  25
  26 #include <acedef.h>
  27 #include <acldef.h>
  28 #include <armdef.h>
  29 #include <atrdef.h>
  30 #include <chpdef.h>
  31 #include <clidef.h>
  32 #include <climsgdef.h>
  33 #include <dcdef.h>
  34 #include <descrip.h>
  35 #include <devdef.h>
  36 #include <dvidef.h>
  37 #include <fibdef.h>
  38 #include <float.h>
  39 #include <fscndef.h>
  40 #include <iodef.h>
  41 #include <jpidef.h>
  42 #include <kgbdef.h>
  43 #include <libclidef.h>
  44 #include <libdef.h>
  45 #include <lib$routines.h>
  46 #include <lnmdef.h>
  47 #include <msgdef.h>
  48 #include <ossdef.h>
  49 #if __CRTL_VER >= 70301000 && !defined(__VAX)
  50 #include <ppropdef.h>
  51 #endif
  52 #include <prvdef.h>
  53 #include <psldef.h>
  54 #include <rms.h>
  55 #include <shrdef.h>
  56 #include <ssdef.h>
  57 #include <starlet.h>
  58 #include <strdef.h>
  59 #include <str$routines.h>
  60 #include <syidef.h>
  61 #include <uaidef.h>
  62 #include <uicdef.h>
  63 #include <stsdef.h>
  64 #include <rmsdef.h>
  65 #include <smgdef.h>
  66 #if __CRTL_VER >= 70000000 /* FIXME to earliest version */
  67 #include <efndef.h>
  68 #define NO_EFN EFN$C_ENF
  69 #else
  70 #define NO_EFN 0;
  71 #endif
  72
  73 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  74 int   decc$feature_get_index(const char *name);
  75 char* decc$feature_get_name(int index);
  76 int   decc$feature_get_value(int index, int mode);
  77 int   decc$feature_set_value(int index, int mode, int value);
  78 #else
  79 #include <unixlib.h>
  80 #endif
  81
  82 #pragma member_alignment save
  83 #pragma nomember_alignment longword
  84 struct item_list_3 {
  85         unsigned short len;
  86         unsigned short code;
  87         void * bufadr;
  88         unsigned short * retadr;
  89 };
  90 #pragma member_alignment restore
  91
  92 /* More specific prototype than in starlet_c.h makes programming errors
  93    more visible.
  94  */
  95 #ifdef sys$getdviw
  96 #undef sys$getdviw
  97 int sys$getdviw
  98        (unsigned long efn,
  99         unsigned short chan,
 100         const struct dsc$descriptor_s * devnam,
 101         const struct item_list_3 * itmlst,
 102         void * iosb,
 103         void * (astadr)(unsigned long),
 104         void * astprm,
 105         void * nullarg);
 106 #endif
 107
 108 #ifdef sys$get_security
 109 #undef sys$get_security
 110 int sys$get_security
 111        (const struct dsc$descriptor_s * clsnam,
 112         const struct dsc$descriptor_s * objnam,
 113         const unsigned int *objhan,
 114         unsigned int flags,
 115         const struct item_list_3 * itmlst,
 116         unsigned int * contxt,
 117         const unsigned int * acmode);
 118 #endif
 119
 120 #ifdef sys$set_security
 121 #undef sys$set_security
 122 int sys$set_security
 123        (const struct dsc$descriptor_s * clsnam,
 124         const struct dsc$descriptor_s * objnam,
 125         const unsigned int *objhan,
 126         unsigned int flags,
 127         const struct item_list_3 * itmlst,
 128         unsigned int * contxt,
 129         const unsigned int * acmode);
 130 #endif
 131
 132 #ifdef lib$find_image_symbol
 133 #undef lib$find_image_symbol
 134 int lib$find_image_symbol
 135        (const struct dsc$descriptor_s * imgname,
 136         const struct dsc$descriptor_s * symname,
 137         void * symval,
 138         const struct dsc$descriptor_s * defspec,
 139         unsigned long flag);
 140 #endif
 141
 142 #ifdef lib$rename_file
 143 #undef lib$rename_file
 144 int lib$rename_file
 145        (const struct dsc$descriptor_s * old_file_dsc,
 146         const struct dsc$descriptor_s * new_file_dsc,
 147         const struct dsc$descriptor_s * default_file_dsc,
 148         const struct dsc$descriptor_s * related_file_dsc,
 149         const unsigned long * flags,
 150         void * (success)(const struct dsc$descriptor_s * old_dsc,
 151                          const struct dsc$descriptor_s * new_dsc,
 152                          const void *),
 153         void * (error)(const struct dsc$descriptor_s * old_dsc,
 154                        const struct dsc$descriptor_s * new_dsc,
 155                        const int * rms_sts,
 156                        const int * rms_stv,
 157                        const int * error_src,
 158                        const void * usr_arg),
 159         int (confirm)(const struct dsc$descriptor_s * old_dsc,
 160                       const struct dsc$descriptor_s * new_dsc,
 161                       const void * old_fab,
 162                       const void * usr_arg),
 163         void * user_arg,
 164         struct dsc$descriptor_s * old_result_name_dsc,
 165         struct dsc$descriptor_s * new_result_name_dsc,
 166         unsigned long * file_scan_context);
 167 #endif
 168
 169 #if __CRTL_VER >= 70300000 && !defined(__VAX)
 170
 171 static int set_feature_default(const char *name, int value)
 172 {
 173     int status;
 174     int index;
 175
 176     index = decc$feature_get_index(name);
 177
 178     status = decc$feature_set_value(index, 1, value);
 179     if (index == -1 || (status == -1)) {
 180       return -1;
 181     }
 182
 183     status = decc$feature_get_value(index, 1);
 184     if (status != value) {
 185       return -1;
 186     }
 187
 188 return 0;
 189 }
 190 #endif
 191
 192 /* Older versions of ssdef.h don't have these */
 193 #ifndef SS$_INVFILFOROP
 194 #  define SS$_INVFILFOROP 3930
 195 #endif
 196 #ifndef SS$_NOSUCHOBJECT
 197 #  define SS$_NOSUCHOBJECT 2696
 198 #endif
 199
 200 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
 201 #define PERLIO_NOT_STDIO 0
 202
 203 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
 204  * code below needs to get to the underlying CRTL routines. */
 205 #define DONT_MASK_RTL_CALLS
 206 #include "EXTERN.h"
 207 #include "perl.h"
 208 #include "XSUB.h"
 209 /* Anticipating future expansion in lexical warnings . . . */
 210 #ifndef WARN_INTERNAL
 211 #  define WARN_INTERNAL WARN_MISC
 212 #endif
 213
 214 #ifdef VMS_LONGNAME_SUPPORT
 215 #include <libfildef.h>
 216 #endif
 217
 218 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
 219 #  define RTL_USES_UTC 1
 220 #endif
 221
 222 #if !defined(__VAX) && __CRTL_VER >= 80200000
 223 #ifdef lstat
 224 #undef lstat
 225 #endif
 226 #else
 227 #ifdef lstat
 228 #undef lstat
 229 #endif
 230 #define lstat(_x, _y) stat(_x, _y)
 231 #endif
 232
 233 /* Routine to create a decterm for use with the Perl debugger */
 234 /* No headers, this information was found in the Programming Concepts Manual */
 235
 236 static int (*decw_term_port)
 237    (const struct dsc$descriptor_s * display,
 238     const struct dsc$descriptor_s * setup_file,
 239     const struct dsc$descriptor_s * customization,
 240     struct dsc$descriptor_s * result_device_name,
 241     unsigned short * result_device_name_length,
 242     void * controller,
 243     void * char_buffer,
 244     void * char_change_buffer) = 0;
 245
 246 /* gcc's header files don't #define direct access macros
 247  * corresponding to VAXC's variant structs */
 248 #ifdef __GNUC__
 249 #  define uic$v_format uic$r_uic_form.uic$v_format
 250 #  define uic$v_group uic$r_uic_form.uic$v_group
 251 #  define uic$v_member uic$r_uic_form.uic$v_member
 252 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 253 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 254 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 255 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 256 #endif
 257
 258 #if defined(NEED_AN_H_ERRNO)
 259 dEXT int h_errno;
 260 #endif
 261
 262 #ifdef __DECC
 263 #pragma message disable pragma
 264 #pragma member_alignment save
 265 #pragma nomember_alignment longword
 266 #pragma message save
 267 #pragma message disable misalgndmem
 268 #endif
 269 struct itmlst_3 {
 270   unsigned short int buflen;
 271   unsigned short int itmcode;
 272   void *bufadr;
 273   unsigned short int *retlen;
 274 };
 275
 276 struct filescan_itmlst_2 {
 277     unsigned short length;
 278     unsigned short itmcode;
 279     char * component;
 280 };
 281
 282 struct vs_str_st {
 283     unsigned short length;
 284     char str[65536];
 285 };
 286
 287 #ifdef __DECC
 288 #pragma message restore
 289 #pragma member_alignment restore
 290 #endif
 291
 292 #define do_fileify_dirspec(a,b,c,d)     mp_do_fileify_dirspec(aTHX_ a,b,c,d)
 293 #define do_pathify_dirspec(a,b,c,d)     mp_do_pathify_dirspec(aTHX_ a,b,c,d)
 294 #define do_tovmsspec(a,b,c,d)           mp_do_tovmsspec(aTHX_ a,b,c,0,d)
 295 #define do_tovmspath(a,b,c,d)           mp_do_tovmspath(aTHX_ a,b,c,d)
 296 #define do_rmsexpand(a,b,c,d,e,f,g)     mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
 297 #define do_vms_realpath(a,b,c)          mp_do_vms_realpath(aTHX_ a,b,c)
 298 #define do_vms_realname(a,b,c)          mp_do_vms_realname(aTHX_ a,b,c)
 299 #define do_tounixspec(a,b,c,d)          mp_do_tounixspec(aTHX_ a,b,c,d)
 300 #define do_tounixpath(a,b,c,d)          mp_do_tounixpath(aTHX_ a,b,c,d)
 301 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 302 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 303 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 304
 305 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
 306 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
 307 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
 308 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
 309
 310 static char *  int_rmsexpand_vms(
 311     const char * filespec, char * outbuf, unsigned opts);
 312 static char * int_rmsexpand_tovms(
 313     const char * filespec, char * outbuf, unsigned opts);
 314 static char *int_tovmsspec
 315    (const char *path, char *buf, int dir_flag, int * utf8_flag);
 316 static char * int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl);
 317 static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl);
 318 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl);
 319
 320 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 321 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 322
 323 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 324  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 325  * the Perl facility.
 326  */
 327 #define PERL_LNM_MAX_ITER 10
 328
 329   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 330 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 331 #define MAX_DCL_SYMBOL          (8192)
 332 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 333 #else
 334 #define MAX_DCL_SYMBOL          (1024)
 335 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 336 #endif
 337
 338 static char *__mystrtolower(char *str)
 339 {
 340   if (str) for (; *str; ++str) *str= tolower(*str);
 341   return str;
 342 }
 343
 344 static struct dsc$descriptor_s fildevdsc =
 345   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 346 static struct dsc$descriptor_s crtlenvdsc =
 347   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 348 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 349 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 350 static struct dsc$descriptor_s **env_tables = defenv;
 351 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 352
 353 /* True if we shouldn't treat barewords as logicals during directory */
 354 /* munching */
 355 static int no_translate_barewords;
 356
 357 #ifndef RTL_USES_UTC
 358 static int tz_updated = 1;
 359 #endif
 360
 361 /* DECC Features that may need to affect how Perl interprets
 362  * displays filename information
 363  */
 364 static int decc_disable_to_vms_logname_translation = 1;
 365 static int decc_disable_posix_root = 1;
 366 int decc_efs_case_preserve = 0;
 367 static int decc_efs_charset = 0;
 368 static int decc_efs_charset_index = -1;
 369 static int decc_filename_unix_no_version = 0;
 370 static int decc_filename_unix_only = 0;
 371 int decc_filename_unix_report = 0;
 372 int decc_posix_compliant_pathnames = 0;
 373 int decc_readdir_dropdotnotype = 0;
 374 static int vms_process_case_tolerant = 1;
 375 int vms_vtf7_filenames = 0;
 376 int gnv_unix_shell = 0;
 377 static int vms_unlink_all_versions = 0;
 378 static int vms_posix_exit = 0;
 379
 380 /* bug workarounds if needed */
 381 int decc_bug_devnull = 1;
 382 int decc_dir_barename = 0;
 383 int vms_bug_stat_filename = 0;
 384
 385 static int vms_debug_on_exception = 0;
 386 static int vms_debug_fileify = 0;
 387
 388 /* Simple logical name translation */
 389 static int simple_trnlnm
 390    (const char * logname,
 391     char * value,
 392     int value_len)
 393 {
 394     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
 395     const unsigned long attr = LNM$M_CASE_BLIND;
 396     struct dsc$descriptor_s name_dsc;
 397     int status;
 398     unsigned short result;
 399     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
 400                                 {0, 0, 0, 0}};
 401
 402     name_dsc.dsc$w_length = strlen(logname);
 403     name_dsc.dsc$a_pointer = (char *)logname;
 404     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
 405     name_dsc.dsc$b_class = DSC$K_CLASS_S;
 406
 407     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
 408
 409     if ($VMS_STATUS_SUCCESS(status)) {
 410
 411          /* Null terminate and return the string */
 412         /*--------------------------------------*/
 413         value[result] = 0;
 414         return result;
 415     }
 416
 417     return 0;
 418 }
 419
 420
 421 /* Is this a UNIX file specification?
 422  *   No longer a simple check with EFS file specs
 423  *   For now, not a full check, but need to
 424  *   handle POSIX ^UP^ specifications
 425  *   Fixing to handle ^/ cases would require
 426  *   changes to many other conversion routines.
 427  */
 428
 429 static int is_unix_filespec(const char *path)
 430 {
 431 int ret_val;
 432 const char * pch1;
 433
 434     ret_val = 0;
 435     if (strncmp(path,"\"^UP^",5) != 0) {
 436         pch1 = strchr(path, '/');
 437         if (pch1 != NULL)
 438             ret_val = 1;
 439         else {
 440
 441             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 442             if (decc_filename_unix_report || decc_filename_unix_only) {
 443             if (strcmp(path,".") == 0)
 444                 ret_val = 1;
 445             }
 446         }
 447     }
 448     return ret_val;
 449 }
 450
 451 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 452  */
 453
 454 static void ucs2_to_vtf7
 455    (char *outspec,
 456     unsigned long ucs2_char,
 457     int * output_cnt)
 458 {
 459 unsigned char * ucs_ptr;
 460 int hex;
 461
 462     ucs_ptr = (unsigned char *)&ucs2_char;
 463
 464     outspec[0] = '^';
 465     outspec[1] = 'U';
 466     hex = (ucs_ptr[1] >> 4) & 0xf;
 467     if (hex < 0xA)
 468         outspec[2] = hex + '0';
 469     else
 470         outspec[2] = (hex - 9) + 'A';
 471     hex = ucs_ptr[1] & 0xF;
 472     if (hex < 0xA)
 473         outspec[3] = hex + '0';
 474     else {
 475         outspec[3] = (hex - 9) + 'A';
 476     }
 477     hex = (ucs_ptr[0] >> 4) & 0xf;
 478     if (hex < 0xA)
 479         outspec[4] = hex + '0';
 480     else
 481         outspec[4] = (hex - 9) + 'A';
 482     hex = ucs_ptr[1] & 0xF;
 483     if (hex < 0xA)
 484         outspec[5] = hex + '0';
 485     else {
 486         outspec[5] = (hex - 9) + 'A';
 487     }
 488     *output_cnt = 6;
 489 }
 490
 491
 492 /* This handles the conversion of a UNIX extended character set to a ^
 493  * escaped VMS character.
 494  * in a UNIX file specification.
 495  *
 496  * The output count variable contains the number of characters added
 497  * to the output string.
 498  *
 499  * The return value is the number of characters read from the input string
 500  */
 501 static int copy_expand_unix_filename_escape
 502   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 503 {
 504 int count;
 505 int scnt;
 506 int utf8_flag;
 507
 508     utf8_flag = 0;
 509     if (utf8_fl)
 510       utf8_flag = *utf8_fl;
 511
 512     count = 0;
 513     *output_cnt = 0;
 514     if (*inspec >= 0x80) {
 515         if (utf8_fl && vms_vtf7_filenames) {
 516         unsigned long ucs_char;
 517
 518             ucs_char = 0;
 519
 520             if ((*inspec & 0xE0) == 0xC0) {
 521                 /* 2 byte Unicode */
 522                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 523                 if (ucs_char >= 0x80) {
 524                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 525                     return 2;
 526                 }
 527             } else if ((*inspec & 0xF0) == 0xE0) {
 528                 /* 3 byte Unicode */
 529                 ucs_char = ((inspec[0] & 0xF) << 12) +
 530                    ((inspec[1] & 0x3f) << 6) +
 531                    (inspec[2] & 0x3f);
 532                 if (ucs_char >= 0x800) {
 533                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 534                     return 3;
 535                 }
 536
 537 #if 0 /* I do not see longer sequences supported by OpenVMS */
 538       /* Maybe some one can fix this later */
 539             } else if ((*inspec & 0xF8) == 0xF0) {
 540                 /* 4 byte Unicode */
 541                 /* UCS-4 to UCS-2 */
 542             } else if ((*inspec & 0xFC) == 0xF8) {
 543                 /* 5 byte Unicode */
 544                 /* UCS-4 to UCS-2 */
 545             } else if ((*inspec & 0xFE) == 0xFC) {
 546                 /* 6 byte Unicode */
 547                 /* UCS-4 to UCS-2 */
 548 #endif
 549             }
 550         }
 551
 552         /* High bit set, but not a Unicode character! */
 553
 554         /* Non printing DECMCS or ISO Latin-1 character? */
 555         if (*inspec <= 0x9F) {
 556         int hex;
 557             outspec[0] = '^';
 558             outspec++;
 559             hex = (*inspec >> 4) & 0xF;
 560             if (hex < 0xA)
 561                 outspec[1] = hex + '0';
 562             else {
 563                 outspec[1] = (hex - 9) + 'A';
 564             }
 565             hex = *inspec & 0xF;
 566             if (hex < 0xA)
 567                 outspec[2] = hex + '0';
 568             else {
 569                 outspec[2] = (hex - 9) + 'A';
 570             }
 571             *output_cnt = 3;
 572             return 1;
 573         } else if (*inspec == 0xA0) {
 574             outspec[0] = '^';
 575             outspec[1] = 'A';
 576             outspec[2] = '0';
 577             *output_cnt = 3;
 578             return 1;
 579         } else if (*inspec == 0xFF) {
 580             outspec[0] = '^';
 581             outspec[1] = 'F';
 582             outspec[2] = 'F';
 583             *output_cnt = 3;
 584             return 1;
 585         }
 586         *outspec = *inspec;
 587         *output_cnt = 1;
 588         return 1;
 589     }
 590
 591     /* Is this a macro that needs to be passed through?
 592      * Macros start with $( and an alpha character, followed
 593      * by a string of alpha numeric characters ending with a )
 594      * If this does not match, then encode it as ODS-5.
 595      */
 596     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 597     int tcnt;
 598
 599         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 600             tcnt = 3;
 601             outspec[0] = inspec[0];
 602             outspec[1] = inspec[1];
 603             outspec[2] = inspec[2];
 604
 605             while(isalnum(inspec[tcnt]) ||
 606                   (inspec[2] == '.') || (inspec[2] == '_')) {
 607                 outspec[tcnt] = inspec[tcnt];
 608                 tcnt++;
 609             }
 610             if (inspec[tcnt] == ')') {
 611                 outspec[tcnt] = inspec[tcnt];
 612                 tcnt++;
 613                 *output_cnt = tcnt;
 614                 return tcnt;
 615             }
 616         }
 617     }
 618
 619     switch (*inspec) {
 620     case 0x7f:
 621         outspec[0] = '^';
 622         outspec[1] = '7';
 623         outspec[2] = 'F';
 624         *output_cnt = 3;
 625         return 1;
 626         break;
 627     case '?':
 628         if (decc_efs_charset == 0)
 629           outspec[0] = '%';
 630         else
 631           outspec[0] = '?';
 632         *output_cnt = 1;
 633         return 1;
 634         break;
 635     case '.':
 636     case '~':
 637     case '!':
 638     case '#':
 639     case '&':
 640     case '\'':
 641     case '`':
 642     case '(':
 643     case ')':
 644     case '+':
 645     case '@':
 646     case '{':
 647     case '}':
 648     case ',':
 649     case ';':
 650     case '[':
 651     case ']':
 652     case '%':
 653     case '^':
 654     case '\\':
 655         /* Don't escape again if following character is
 656          * already something we escape.
 657          */
 658         if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
 659             *outspec = *inspec;
 660             *output_cnt = 1;
 661             return 1;
 662             break;
 663         }
 664         /* But otherwise fall through and escape it. */
 665     case '=':
 666         /* Assume that this is to be escaped */
 667         outspec[0] = '^';
 668         outspec[1] = *inspec;
 669         *output_cnt = 2;
 670         return 1;
 671         break;
 672     case ' ': /* space */
 673         /* Assume that this is to be escaped */
 674         outspec[0] = '^';
 675         outspec[1] = '_';
 676         *output_cnt = 2;
 677         return 1;
 678         break;
 679     default:
 680         *outspec = *inspec;
 681         *output_cnt = 1;
 682         return 1;
 683         break;
 684     }
 685 }
 686
 687
 688 /* This handles the expansion of a '^' prefix to the proper character
 689  * in a UNIX file specification.
 690  *
 691  * The output count variable contains the number of characters added
 692  * to the output string.
 693  *
 694  * The return value is the number of characters read from the input
 695  * string
 696  */
 697 static int copy_expand_vms_filename_escape
 698   (char *outspec, const char *inspec, int *output_cnt)
 699 {
 700 int count;
 701 int scnt;
 702
 703     count = 0;
 704     *output_cnt = 0;
 705     if (*inspec == '^') {
 706         inspec++;
 707         switch (*inspec) {
 708         /* Spaces and non-trailing dots should just be passed through,
 709          * but eat the escape character.
 710          */
 711         case '.':
 712             *outspec = *inspec;
 713             count += 2;
 714             (*output_cnt)++;
 715             break;
 716         case '_': /* space */
 717             *outspec = ' ';
 718             count += 2;
 719             (*output_cnt)++;
 720             break;
 721         case '^':
 722             /* Hmm.  Better leave the escape escaped. */
 723             outspec[0] = '^';
 724             outspec[1] = '^';
 725             count += 2;
 726             (*output_cnt) += 2;
 727             break;
 728         case 'U': /* Unicode - FIX-ME this is wrong. */
 729             inspec++;
 730             count++;
 731             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 732             if (scnt == 4) {
 733                 unsigned int c1, c2;
 734                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 735                 outspec[0] == c1 & 0xff;
 736                 outspec[1] == c2 & 0xff;
 737                 if (scnt > 1) {
 738                     (*output_cnt) += 2;
 739                     count += 4;
 740                 }
 741             }
 742             else {
 743                 /* Error - do best we can to continue */
 744                 *outspec = 'U';
 745                 outspec++;
 746                 (*output_cnt++);
 747                 *outspec = *inspec;
 748                 count++;
 749                 (*output_cnt++);
 750             }
 751             break;
 752         default:
 753             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 754             if (scnt == 2) {
 755                 /* Hex encoded */
 756                 unsigned int c1;
 757                 scnt = sscanf(inspec, "%2x", &c1);
 758                 outspec[0] = c1 & 0xff;
 759                 if (scnt > 0) {
 760                     (*output_cnt++);
 761                     count += 2;
 762                 }
 763             }
 764             else {
 765                 *outspec = *inspec;
 766                 count++;
 767                 (*output_cnt++);
 768             }
 769         }
 770     }
 771     else {
 772         *outspec = *inspec;
 773         count++;
 774         (*output_cnt)++;
 775     }
 776     return count;
 777 }
 778
 779 #ifdef sys$filescan
 780 #undef sys$filescan
 781 int sys$filescan
 782    (const struct dsc$descriptor_s * srcstr,
 783     struct filescan_itmlst_2 * valuelist,
 784     unsigned long * fldflags,
 785     struct dsc$descriptor_s *auxout,
 786     unsigned short * retlen);
 787 #endif
 788
 789 /* vms_split_path - Verify that the input file specification is a
 790  * VMS format file specification, and provide pointers to the components of
 791  * it.  With EFS format filenames, this is virtually the only way to
 792  * parse a VMS path specification into components.
 793  *
 794  * If the sum of the components do not add up to the length of the
 795  * string, then the passed file specification is probably a UNIX style
 796  * path.
 797  */
 798 static int vms_split_path
 799    (const char * path,
 800     char * * volume,
 801     int * vol_len,
 802     char * * root,
 803     int * root_len,
 804     char * * dir,
 805     int * dir_len,
 806     char * * name,
 807     int * name_len,
 808     char * * ext,
 809     int * ext_len,
 810     char * * version,
 811     int * ver_len)
 812 {
 813 struct dsc$descriptor path_desc;
 814 int status;
 815 unsigned long flags;
 816 int ret_stat;
 817 struct filescan_itmlst_2 item_list[9];
 818 const int filespec = 0;
 819 const int nodespec = 1;
 820 const int devspec = 2;
 821 const int rootspec = 3;
 822 const int dirspec = 4;
 823 const int namespec = 5;
 824 const int typespec = 6;
 825 const int verspec = 7;
 826
 827     /* Assume the worst for an easy exit */
 828     ret_stat = -1;
 829     *volume = NULL;
 830     *vol_len = 0;
 831     *root = NULL;
 832     *root_len = 0;
 833     *dir = NULL;
 834     *dir_len;
 835     *name = NULL;
 836     *name_len = 0;
 837     *ext = NULL;
 838     *ext_len = 0;
 839     *version = NULL;
 840     *ver_len = 0;
 841
 842     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 843     path_desc.dsc$w_length = strlen(path);
 844     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 845     path_desc.dsc$b_class = DSC$K_CLASS_S;
 846
 847     /* Get the total length, if it is shorter than the string passed
 848      * then this was probably not a VMS formatted file specification
 849      */
 850     item_list[filespec].itmcode = FSCN$_FILESPEC;
 851     item_list[filespec].length = 0;
 852     item_list[filespec].component = NULL;
 853
 854     /* If the node is present, then it gets considered as part of the
 855      * volume name to hopefully make things simple.
 856      */
 857     item_list[nodespec].itmcode = FSCN$_NODE;
 858     item_list[nodespec].length = 0;
 859     item_list[nodespec].component = NULL;
 860
 861     item_list[devspec].itmcode = FSCN$_DEVICE;
 862     item_list[devspec].length = 0;
 863     item_list[devspec].component = NULL;
 864
 865     /* root is a special case,  adding it to either the directory or
 866      * the device components will probalby complicate things for the
 867      * callers of this routine, so leave it separate.
 868      */
 869     item_list[rootspec].itmcode = FSCN$_ROOT;
 870     item_list[rootspec].length = 0;
 871     item_list[rootspec].component = NULL;
 872
 873     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 874     item_list[dirspec].length = 0;
 875     item_list[dirspec].component = NULL;
 876
 877     item_list[namespec].itmcode = FSCN$_NAME;
 878     item_list[namespec].length = 0;
 879     item_list[namespec].component = NULL;
 880
 881     item_list[typespec].itmcode = FSCN$_TYPE;
 882     item_list[typespec].length = 0;
 883     item_list[typespec].component = NULL;
 884
 885     item_list[verspec].itmcode = FSCN$_VERSION;
 886     item_list[verspec].length = 0;
 887     item_list[verspec].component = NULL;
 888
 889     item_list[8].itmcode = 0;
 890     item_list[8].length = 0;
 891     item_list[8].component = NULL;
 892
 893     status = sys$filescan
 894        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 895         &flags, NULL, NULL);
 896     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 897
 898     /* If we parsed it successfully these two lengths should be the same */
 899     if (path_desc.dsc$w_length != item_list[filespec].length)
 900         return ret_stat;
 901
 902     /* If we got here, then it is a VMS file specification */
 903     ret_stat = 0;
 904
 905     /* set the volume name */
 906     if (item_list[nodespec].length > 0) {
 907         *volume = item_list[nodespec].component;
 908         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 909     }
 910     else {
 911         *volume = item_list[devspec].component;
 912         *vol_len = item_list[devspec].length;
 913     }
 914
 915     *root = item_list[rootspec].component;
 916     *root_len = item_list[rootspec].length;
 917
 918     *dir = item_list[dirspec].component;
 919     *dir_len = item_list[dirspec].length;
 920
 921     /* Now fun with versions and EFS file specifications
 922      * The parser can not tell the difference when a "." is a version
 923      * delimiter or a part of the file specification.
 924      */
 925     if ((decc_efs_charset) &&
 926         (item_list[verspec].length > 0) &&
 927         (item_list[verspec].component[0] == '.')) {
 928         *name = item_list[namespec].component;
 929         *name_len = item_list[namespec].length + item_list[typespec].length;
 930         *ext = item_list[verspec].component;
 931         *ext_len = item_list[verspec].length;
 932         *version = NULL;
 933         *ver_len = 0;
 934     }
 935     else {
 936         *name = item_list[namespec].component;
 937         *name_len = item_list[namespec].length;
 938         *ext = item_list[typespec].component;
 939         *ext_len = item_list[typespec].length;
 940         *version = item_list[verspec].component;
 941         *ver_len = item_list[verspec].length;
 942     }
 943     return ret_stat;
 944 }
 945
 946 /* Routine to determine if the file specification ends with .dir */
 947 static int is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len) {
 948
 949     /* e_len must be 4, and version must be <= 2 characters */
 950     if (e_len != 4 || vs_len > 2)
 951         return 0;
 952
 953     /* If a version number is present, it needs to be one */
 954     if ((vs_len == 2) && (vs_spec[1] != '1'))
 955         return 0;
 956
 957     /* Look for the DIR on the extension */
 958     if (vms_process_case_tolerant) {
 959         if ((toupper(e_spec[1]) == 'D') &&
 960             (toupper(e_spec[2]) == 'I') &&
 961             (toupper(e_spec[3]) == 'R')) {
 962             return 1;
 963         }
 964     } else {
 965         /* Directory extensions are supposed to be in upper case only */
 966         /* I would not be surprised if this rule can not be enforced */
 967         /* if and when someone fully debugs the case sensitive mode */
 968         if ((e_spec[1] == 'D') &&
 969             (e_spec[2] == 'I') &&
 970             (e_spec[3] == 'R')) {
 971             return 1;
 972         }
 973     }
 974     return 0;
 975 }
 976
 977
 978 /* my_maxidx
 979  * Routine to retrieve the maximum equivalence index for an input
 980  * logical name.  Some calls to this routine have no knowledge if
 981  * the variable is a logical or not.  So on error we return a max
 982  * index of zero.
 983  */
 984 /*{{{int my_maxidx(const char *lnm) */
 985 static int
 986 my_maxidx(const char *lnm)
 987 {
 988     int status;
 989     int midx;
 990     int attr = LNM$M_CASE_BLIND;
 991     struct dsc$descriptor lnmdsc;
 992     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 993                                 {0, 0, 0, 0}};
 994
 995     lnmdsc.dsc$w_length = strlen(lnm);
 996     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 997     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 998     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 999
1000     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
1001     if ((status & 1) == 0)
1002        midx = 0;
1003
1004     return (midx);
1005 }
1006 /*}}}*/
1007
1008 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
1009 int
1010 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
1011   struct dsc$descriptor_s **tabvec, unsigned long int flags)
1012 {
1013     const char *cp1;
1014     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
1015     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
1016     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
1017     int midx;
1018     unsigned char acmode;
1019     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1020                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1021     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
1022                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
1023                                  {0, 0, 0, 0}};
1024     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1025 #if defined(PERL_IMPLICIT_CONTEXT)
1026     pTHX = NULL;
1027     if (PL_curinterp) {
1028       aTHX = PERL_GET_INTERP;
1029     } else {
1030       aTHX = NULL;
1031     }
1032 #endif
1033
1034     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
1035       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
1036     }
1037     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1038       *cp2 = _toupper(*cp1);
1039       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1040         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1041         return 0;
1042       }
1043     }
1044     lnmdsc.dsc$w_length = cp1 - lnm;
1045     lnmdsc.dsc$a_pointer = uplnm;
1046     uplnm[lnmdsc.dsc$w_length] = '\0';
1047     secure = flags & PERL__TRNENV_SECURE;
1048     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
1049     if (!tabvec || !*tabvec) tabvec = env_tables;
1050
1051     for (curtab = 0; tabvec[curtab]; curtab++) {
1052       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1053         if (!ivenv && !secure) {
1054           char *eq, *end;
1055           int i;
1056           if (!environ) {
1057             ivenv = 1;
1058 #if defined(PERL_IMPLICIT_CONTEXT)
1059             if (aTHX == NULL) {
1060                 fprintf(stderr,
1061                     "Can't read CRTL environ\n");
1062             } else
1063 #endif
1064                 Perl_warn(aTHX_ "Can't read CRTL environ\n");
1065             continue;
1066           }
1067           retsts = SS$_NOLOGNAM;
1068           for (i = 0; environ[i]; i++) {
1069             if ((eq = strchr(environ[i],'=')) &&
1070                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
1071                 !strncmp(environ[i],uplnm,eq - environ[i])) {
1072               eq++;
1073               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
1074               if (!eqvlen) continue;
1075               retsts = SS$_NORMAL;
1076               break;
1077             }
1078           }
1079           if (retsts != SS$_NOLOGNAM) break;
1080         }
1081       }
1082       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1083                !str$case_blind_compare(&tmpdsc,&clisym)) {
1084         if (!ivsym && !secure) {
1085           unsigned short int deflen = LNM$C_NAMLENGTH;
1086           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1087           /* dynamic dsc to accomodate possible long value */
1088           _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
1089           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
1090           if (retsts & 1) {
1091             if (eqvlen > MAX_DCL_SYMBOL) {
1092               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
1093               eqvlen = MAX_DCL_SYMBOL;
1094               /* Special hack--we might be called before the interpreter's */
1095               /* fully initialized, in which case either thr or PL_curcop */
1096               /* might be bogus. We have to check, since ckWARN needs them */
1097               /* both to be valid if running threaded */
1098 #if defined(PERL_IMPLICIT_CONTEXT)
1099               if (aTHX == NULL) {
1100                   fprintf(stderr,
1101                      "Value of CLI symbol \"%s\" too long",lnm);
1102               } else
1103 #endif
1104                 if (ckWARN(WARN_MISC)) {
1105                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
1106                 }
1107             }
1108             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
1109           }
1110           _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
1111           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1112           if (retsts == LIB$_NOSUCHSYM) continue;
1113           break;
1114         }
1115       }
1116       else if (!ivlnm) {
1117         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
1118           midx = my_maxidx(lnm);
1119           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1120             lnmlst[1].bufadr = cp2;
1121             eqvlen = 0;
1122             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1123             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1124             if (retsts == SS$_NOLOGNAM) break;
1125             /* PPFs have a prefix */
1126             if (
1127 #if INTSIZE == 4
1128                  *((int *)uplnm) == *((int *)"SYS$")                    &&
1129 #endif
1130                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
1131                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
1132                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
1133                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
1134                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
1135               memmove(eqv,eqv+4,eqvlen-4);
1136               eqvlen -= 4;
1137             }
1138             cp2 += eqvlen;
1139             *cp2 = '\0';
1140           }
1141           if ((retsts == SS$_IVLOGNAM) ||
1142               (retsts == SS$_NOLOGNAM)) { continue; }
1143         }
1144         else {
1145           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1146           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1147           if (retsts == SS$_NOLOGNAM) continue;
1148           eqv[eqvlen] = '\0';
1149         }
1150         eqvlen = strlen(eqv);
1151         break;
1152       }
1153     }
1154     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1155     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1156              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
1157              retsts == SS$_NOLOGNAM) {
1158       set_errno(EINVAL);  set_vaxc_errno(retsts);
1159     }
1160     else _ckvmssts_noperl(retsts);
1161     return 0;
1162 }  /* end of vmstrnenv */
1163 /*}}}*/
1164
1165 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1166 /* Define as a function so we can access statics. */
1167 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1168 {
1169     int flags = 0;
1170
1171 #if defined(PERL_IMPLICIT_CONTEXT)
1172     if (aTHX != NULL)
1173 #endif
1174 #ifdef SECURE_INTERNAL_GETENV
1175         flags = (PL_curinterp ? PL_tainting : will_taint) ?
1176                  PERL__TRNENV_SECURE : 0;
1177 #endif
1178
1179     return vmstrnenv(lnm, eqv, idx, fildev, flags);
1180 }
1181 /*}}}*/
1182
1183 /* my_getenv
1184  * Note: Uses Perl temp to store result so char * can be returned to
1185  * caller; this pointer will be invalidated at next Perl statement
1186  * transition.
1187  * We define this as a function rather than a macro in terms of my_getenv_len()
1188  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1189  * allocate SVs).
1190  */
1191 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1192 char *
1193 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1194 {
1195     const char *cp1;
1196     static char *__my_getenv_eqv = NULL;
1197     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1198     unsigned long int idx = 0;
1199     int trnsuccess, success, secure, saverr, savvmserr;
1200     int midx, flags;
1201     SV *tmpsv;
1202
1203     midx = my_maxidx(lnm) + 1;
1204
1205     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1206       /* Set up a temporary buffer for the return value; Perl will
1207        * clean it up at the next statement transition */
1208       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1209       if (!tmpsv) return NULL;
1210       eqv = SvPVX(tmpsv);
1211     }
1212     else {
1213       /* Assume no interpreter ==> single thread */
1214       if (__my_getenv_eqv != NULL) {
1215         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1216       }
1217       else {
1218         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1219       }
1220       eqv = __my_getenv_eqv;
1221     }
1222
1223     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1224     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1225       int len;
1226       getcwd(eqv,LNM$C_NAMLENGTH);
1227
1228       len = strlen(eqv);
1229
1230       /* Get rid of "000000/ in rooted filespecs */
1231       if (len > 7) {
1232         char * zeros;
1233         zeros = strstr(eqv, "/000000/");
1234         if (zeros != NULL) {
1235           int mlen;
1236           mlen = len - (zeros - eqv) - 7;
1237           memmove(zeros, &zeros[7], mlen);
1238           len = len - 7;
1239           eqv[len] = '\0';
1240         }
1241       }
1242       return eqv;
1243     }
1244     else {
1245       /* Impose security constraints only if tainting */
1246       if (sys) {
1247         /* Impose security constraints only if tainting */
1248         secure = PL_curinterp ? PL_tainting : will_taint;
1249         saverr = errno;  savvmserr = vaxc$errno;
1250       }
1251       else {
1252         secure = 0;
1253       }
1254
1255       flags =
1256 #ifdef SECURE_INTERNAL_GETENV
1257               secure ? PERL__TRNENV_SECURE : 0
1258 #else
1259               0
1260 #endif
1261       ;
1262
1263       /* For the getenv interface we combine all the equivalence names
1264        * of a search list logical into one value to acquire a maximum
1265        * value length of 255*128 (assuming %ENV is using logicals).
1266        */
1267       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1268
1269       /* If the name contains a semicolon-delimited index, parse it
1270        * off and make sure we only retrieve the equivalence name for
1271        * that index.  */
1272       if ((cp2 = strchr(lnm,';')) != NULL) {
1273         strcpy(uplnm,lnm);
1274         uplnm[cp2-lnm] = '\0';
1275         idx = strtoul(cp2+1,NULL,0);
1276         lnm = uplnm;
1277         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1278       }
1279
1280       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1281
1282       /* Discard NOLOGNAM on internal calls since we're often looking
1283        * for an optional name, and this "error" often shows up as the
1284        * (bogus) exit status for a die() call later on.  */
1285       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1286       return success ? eqv : NULL;
1287     }
1288
1289 }  /* end of my_getenv() */
1290 /*}}}*/
1291
1292
1293 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1294 char *
1295 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1296 {
1297     const char *cp1;
1298     char *buf, *cp2;
1299     unsigned long idx = 0;
1300     int midx, flags;
1301     static char *__my_getenv_len_eqv = NULL;
1302     int secure, saverr, savvmserr;
1303     SV *tmpsv;
1304
1305     midx = my_maxidx(lnm) + 1;
1306
1307     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1308       /* Set up a temporary buffer for the return value; Perl will
1309        * clean it up at the next statement transition */
1310       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1311       if (!tmpsv) return NULL;
1312       buf = SvPVX(tmpsv);
1313     }
1314     else {
1315       /* Assume no interpreter ==> single thread */
1316       if (__my_getenv_len_eqv != NULL) {
1317         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1318       }
1319       else {
1320         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1321       }
1322       buf = __my_getenv_len_eqv;
1323     }
1324
1325     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1326     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1327     char * zeros;
1328
1329       getcwd(buf,LNM$C_NAMLENGTH);
1330       *len = strlen(buf);
1331
1332       /* Get rid of "000000/ in rooted filespecs */
1333       if (*len > 7) {
1334       zeros = strstr(buf, "/000000/");
1335       if (zeros != NULL) {
1336         int mlen;
1337         mlen = *len - (zeros - buf) - 7;
1338         memmove(zeros, &zeros[7], mlen);
1339         *len = *len - 7;
1340         buf[*len] = '\0';
1341         }
1342       }
1343       return buf;
1344     }
1345     else {
1346       if (sys) {
1347         /* Impose security constraints only if tainting */
1348         secure = PL_curinterp ? PL_tainting : will_taint;
1349         saverr = errno;  savvmserr = vaxc$errno;
1350       }
1351       else {
1352         secure = 0;
1353       }
1354
1355       flags =
1356 #ifdef SECURE_INTERNAL_GETENV
1357               secure ? PERL__TRNENV_SECURE : 0
1358 #else
1359               0
1360 #endif
1361       ;
1362
1363       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1364
1365       if ((cp2 = strchr(lnm,';')) != NULL) {
1366         strcpy(buf,lnm);
1367         buf[cp2-lnm] = '\0';
1368         idx = strtoul(cp2+1,NULL,0);
1369         lnm = buf;
1370         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1371       }
1372
1373       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1374
1375       /* Get rid of "000000/ in rooted filespecs */
1376       if (*len > 7) {
1377       char * zeros;
1378         zeros = strstr(buf, "/000000/");
1379         if (zeros != NULL) {
1380           int mlen;
1381           mlen = *len - (zeros - buf) - 7;
1382           memmove(zeros, &zeros[7], mlen);
1383           *len = *len - 7;
1384           buf[*len] = '\0';
1385         }
1386       }
1387
1388       /* Discard NOLOGNAM on internal calls since we're often looking
1389        * for an optional name, and this "error" often shows up as the
1390        * (bogus) exit status for a die() call later on.  */
1391       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1392       return *len ? buf : NULL;
1393     }
1394
1395 }  /* end of my_getenv_len() */
1396 /*}}}*/
1397
1398 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
1399
1400 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1401
1402 /*{{{ void prime_env_iter() */
1403 void
1404 prime_env_iter(void)
1405 /* Fill the %ENV associative array with all logical names we can
1406  * find, in preparation for iterating over it.
1407  */
1408 {
1409   static int primed = 0;
1410   HV *seenhv = NULL, *envhv;
1411   SV *sv = NULL;
1412   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1413   unsigned short int chan;
1414 #ifndef CLI$M_TRUSTED
1415 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1416 #endif
1417   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1418   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1419   long int i;
1420   bool have_sym = FALSE, have_lnm = FALSE;
1421   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1422   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1423   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1424   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1425   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1426 #if defined(PERL_IMPLICIT_CONTEXT)
1427   pTHX;
1428 #endif
1429 #if defined(USE_ITHREADS)
1430   static perl_mutex primenv_mutex;
1431   MUTEX_INIT(&primenv_mutex);
1432 #endif
1433
1434 #if defined(PERL_IMPLICIT_CONTEXT)
1435     /* We jump through these hoops because we can be called at */
1436     /* platform-specific initialization time, which is before anything is */
1437     /* set up--we can't even do a plain dTHX since that relies on the */
1438     /* interpreter structure to be initialized */
1439     if (PL_curinterp) {
1440       aTHX = PERL_GET_INTERP;
1441     } else {
1442       /* we never get here because the NULL pointer will cause the */
1443       /* several of the routines called by this routine to access violate */
1444
1445       /* This routine is only called by hv.c/hv_iterinit which has a */
1446       /* context, so the real fix may be to pass it through instead of */
1447       /* the hoops above */
1448       aTHX = NULL;
1449     }
1450 #endif
1451
1452   if (primed || !PL_envgv) return;
1453   MUTEX_LOCK(&primenv_mutex);
1454   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1455   envhv = GvHVn(PL_envgv);
1456   /* Perform a dummy fetch as an lval to insure that the hash table is
1457    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1458   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1459
1460   for (i = 0; env_tables[i]; i++) {
1461      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1462          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1463      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1464   }
1465   if (have_sym || have_lnm) {
1466     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1467     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1468     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1469     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1470   }
1471
1472   for (i--; i >= 0; i--) {
1473     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1474       char *start;
1475       int j;
1476       for (j = 0; environ[j]; j++) {
1477         if (!(start = strchr(environ[j],'='))) {
1478           if (ckWARN(WARN_INTERNAL))
1479             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1480         }
1481         else {
1482           start++;
1483           sv = newSVpv(start,0);
1484           SvTAINTED_on(sv);
1485           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1486         }
1487       }
1488       continue;
1489     }
1490     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1491              !str$case_blind_compare(&tmpdsc,&clisym)) {
1492       strcpy(cmd,"Show Symbol/Global *");
1493       cmddsc.dsc$w_length = 20;
1494       if (env_tables[i]->dsc$w_length == 12 &&
1495           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1496           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1497       flags = defflags | CLI$M_NOLOGNAM;
1498     }
1499     else {
1500       strcpy(cmd,"Show Logical *");
1501       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1502         strcat(cmd," /Table=");
1503         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1504         cmddsc.dsc$w_length = strlen(cmd);
1505       }
1506       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1507       flags = defflags | CLI$M_NOCLISYM;
1508     }
1509
1510     /* Create a new subprocess to execute each command, to exclude the
1511      * remote possibility that someone could subvert a mbx or file used
1512      * to write multiple commands to a single subprocess.
1513      */
1514     do {
1515       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1516                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1517       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1518       defflags &= ~CLI$M_TRUSTED;
1519     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1520     _ckvmssts(retsts);
1521     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1522     if (seenhv) SvREFCNT_dec(seenhv);
1523     seenhv = newHV();
1524     while (1) {
1525       char *cp1, *cp2, *key;
1526       unsigned long int sts, iosb[2], retlen, keylen;
1527       register U32 hash;
1528
1529       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1530       if (sts & 1) sts = iosb[0] & 0xffff;
1531       if (sts == SS$_ENDOFFILE) {
1532         int wakect = 0;
1533         while (substs == 0) { sys$hiber(); wakect++;}
1534         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1535         _ckvmssts(substs);
1536         break;
1537       }
1538       _ckvmssts(sts);
1539       retlen = iosb[0] >> 16;
1540       if (!retlen) continue;  /* blank line */
1541       buf[retlen] = '\0';
1542       if (iosb[1] != subpid) {
1543         if (iosb[1]) {
1544           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1545         }
1546         continue;
1547       }
1548       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1549         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1550
1551       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1552       if (*cp1 == '(' || /* Logical name table name */
1553           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1554       if (*cp1 == '"') cp1++;
1555       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1556       key = cp1;  keylen = cp2 - cp1;
1557       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1558       while (*cp2 && *cp2 != '=') cp2++;
1559       while (*cp2 && *cp2 == '=') cp2++;
1560       while (*cp2 && *cp2 == ' ') cp2++;
1561       if (*cp2 == '"') {  /* String translation; may embed "" */
1562         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1563         cp2++;  cp1--; /* Skip "" surrounding translation */
1564       }
1565       else {  /* Numeric translation */
1566         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1567         cp1--;  /* stop on last non-space char */
1568       }
1569       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1570         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1571         continue;
1572       }
1573       PERL_HASH(hash,key,keylen);
1574
1575       if (cp1 == cp2 && *cp2 == '.') {
1576         /* A single dot usually means an unprintable character, such as a null
1577          * to indicate a zero-length value.  Get the actual value to make sure.
1578          */
1579         char lnm[LNM$C_NAMLENGTH+1];
1580         char eqv[MAX_DCL_SYMBOL+1];
1581         int trnlen;
1582         strncpy(lnm, key, keylen);
1583         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1584         sv = newSVpvn(eqv, strlen(eqv));
1585       }
1586       else {
1587         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1588       }
1589
1590       SvTAINTED_on(sv);
1591       hv_store(envhv,key,keylen,sv,hash);
1592       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1593     }
1594     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1595       /* get the PPFs for this process, not the subprocess */
1596       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1597       char eqv[LNM$C_NAMLENGTH+1];
1598       int trnlen, i;
1599       for (i = 0; ppfs[i]; i++) {
1600         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1601         sv = newSVpv(eqv,trnlen);
1602         SvTAINTED_on(sv);
1603         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1604       }
1605     }
1606   }
1607   primed = 1;
1608   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1609   if (buf) Safefree(buf);
1610   if (seenhv) SvREFCNT_dec(seenhv);
1611   MUTEX_UNLOCK(&primenv_mutex);
1612   return;
1613
1614 }  /* end of prime_env_iter */
1615 /*}}}*/
1616
1617
1618 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1619 /* Define or delete an element in the same "environment" as
1620  * vmstrnenv().  If an element is to be deleted, it's removed from
1621  * the first place it's found.  If it's to be set, it's set in the
1622  * place designated by the first element of the table vector.
1623  * Like setenv() returns 0 for success, non-zero on error.
1624  */
1625 int
1626 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1627 {
1628     const char *cp1;
1629     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1630     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1631     int nseg = 0, j;
1632     unsigned long int retsts, usermode = PSL$C_USER;
1633     struct itmlst_3 *ile, *ilist;
1634     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1635                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1636                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1637     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1638     $DESCRIPTOR(local,"_LOCAL");
1639
1640     if (!lnm) {
1641         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1642         return SS$_IVLOGNAM;
1643     }
1644
1645     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1646       *cp2 = _toupper(*cp1);
1647       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1648         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1649         return SS$_IVLOGNAM;
1650       }
1651     }
1652     lnmdsc.dsc$w_length = cp1 - lnm;
1653     if (!tabvec || !*tabvec) tabvec = env_tables;
1654
1655     if (!eqv) {  /* we're deleting n element */
1656       for (curtab = 0; tabvec[curtab]; curtab++) {
1657         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1658         int i;
1659           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1660             if ((cp1 = strchr(environ[i],'=')) &&
1661                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1662                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1663 #ifdef HAS_SETENV
1664               return setenv(lnm,"",1) ? vaxc$errno : 0;
1665             }
1666           }
1667           ivenv = 1; retsts = SS$_NOLOGNAM;
1668 #else
1669               if (ckWARN(WARN_INTERNAL))
1670                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1671               ivenv = 1; retsts = SS$_NOSUCHPGM;
1672               break;
1673             }
1674           }
1675 #endif
1676         }
1677         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1678                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1679           unsigned int symtype;
1680           if (tabvec[curtab]->dsc$w_length == 12 &&
1681               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1682               !str$case_blind_compare(&tmpdsc,&local))
1683             symtype = LIB$K_CLI_LOCAL_SYM;
1684           else symtype = LIB$K_CLI_GLOBAL_SYM;
1685           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1686           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1687           if (retsts == LIB$_NOSUCHSYM) continue;
1688           break;
1689         }
1690         else if (!ivlnm) {
1691           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1692           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1693           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1694           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1695           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1696         }
1697       }
1698     }
1699     else {  /* we're defining a value */
1700       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1701 #ifdef HAS_SETENV
1702         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1703 #else
1704         if (ckWARN(WARN_INTERNAL))
1705           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1706         retsts = SS$_NOSUCHPGM;
1707 #endif
1708       }
1709       else {
1710         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1711         eqvdsc.dsc$w_length  = strlen(eqv);
1712         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1713             !str$case_blind_compare(&tmpdsc,&clisym)) {
1714           unsigned int symtype;
1715           if (tabvec[0]->dsc$w_length == 12 &&
1716               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1717                !str$case_blind_compare(&tmpdsc,&local))
1718             symtype = LIB$K_CLI_LOCAL_SYM;
1719           else symtype = LIB$K_CLI_GLOBAL_SYM;
1720           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1721         }
1722         else {
1723           if (!*eqv) eqvdsc.dsc$w_length = 1;
1724           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1725
1726             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1727             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1728               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1729                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1730               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1731               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1732             }
1733
1734             Newx(ilist,nseg+1,struct itmlst_3);
1735             ile = ilist;
1736             if (!ile) {
1737               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1738               return SS$_INSFMEM;
1739             }
1740             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1741
1742             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1743               ile->itmcode = LNM$_STRING;
1744               ile->bufadr = c;
1745               if ((j+1) == nseg) {
1746                 ile->buflen = strlen(c);
1747                 /* in case we are truncating one that's too long */
1748                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1749               }
1750               else {
1751                 ile->buflen = LNM$C_NAMLENGTH;
1752               }
1753             }
1754
1755             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1756             Safefree (ilist);
1757           }
1758           else {
1759             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1760           }
1761         }
1762       }
1763     }
1764     if (!(retsts & 1)) {
1765       switch (retsts) {
1766         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1767         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1768           set_errno(EVMSERR); break;
1769         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1770         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1771           set_errno(EINVAL); break;
1772         case SS$_NOPRIV:
1773           set_errno(EACCES); break;
1774         default:
1775           _ckvmssts(retsts);
1776           set_errno(EVMSERR);
1777        }
1778        set_vaxc_errno(retsts);
1779        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1780     }
1781     else {
1782       /* We reset error values on success because Perl does an hv_fetch()
1783        * before each hv_store(), and if the thing we're setting didn't
1784        * previously exist, we've got a leftover error message.  (Of course,
1785        * this fails in the face of
1786        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1787        * in that the error reported in $! isn't spurious,
1788        * but it's right more often than not.)
1789        */
1790       set_errno(0); set_vaxc_errno(retsts);
1791       return 0;
1792     }
1793
1794 }  /* end of vmssetenv() */
1795 /*}}}*/
1796
1797 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1798 /* This has to be a function since there's a prototype for it in proto.h */
1799 void
1800 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1801 {
1802     if (lnm && *lnm) {
1803       int len = strlen(lnm);
1804       if  (len == 7) {
1805         char uplnm[8];
1806         int i;
1807         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1808         if (!strcmp(uplnm,"DEFAULT")) {
1809           if (eqv && *eqv) my_chdir(eqv);
1810           return;
1811         }
1812     }
1813 #ifndef RTL_USES_UTC
1814     if (len == 6 || len == 2) {
1815       char uplnm[7];
1816       int i;
1817       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1818       uplnm[len] = '\0';
1819       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1820       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1821     }
1822 #endif
1823   }
1824   (void) vmssetenv(lnm,eqv,NULL);
1825 }
1826 /*}}}*/
1827
1828 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1829 /*  vmssetuserlnm
1830  *  sets a user-mode logical in the process logical name table
1831  *  used for redirection of sys$error
1832  *
1833  *  Fix-me: The pTHX is not needed for this routine, however doio.c
1834  *          is calling it with one instead of using a macro.
1835  *          A macro needs to be added to vmsish.h and doio.c updated to use it.
1836  *
1837  */
1838 void
1839 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1840 {
1841     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1842     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1843     unsigned long int iss, attr = LNM$M_CONFINE;
1844     unsigned char acmode = PSL$C_USER;
1845     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1846                                  {0, 0, 0, 0}};
1847     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1848     d_name.dsc$w_length = strlen(name);
1849
1850     lnmlst[0].buflen = strlen(eqv);
1851     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1852
1853     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1854     if (!(iss&1)) lib$signal(iss);
1855 }
1856 /*}}}*/
1857
1858
1859 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1860 /* my_crypt - VMS password hashing
1861  * my_crypt() provides an interface compatible with the Unix crypt()
1862  * C library function, and uses sys$hash_password() to perform VMS
1863  * password hashing.  The quadword hashed password value is returned
1864  * as a NUL-terminated 8 character string.  my_crypt() does not change
1865  * the case of its string arguments; in order to match the behavior
1866  * of LOGINOUT et al., alphabetic characters in both arguments must
1867  *  be upcased by the caller.
1868  *
1869  * - fix me to call ACM services when available
1870  */
1871 char *
1872 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1873 {
1874 #   ifndef UAI$C_PREFERRED_ALGORITHM
1875 #     define UAI$C_PREFERRED_ALGORITHM 127
1876 #   endif
1877     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1878     unsigned short int salt = 0;
1879     unsigned long int sts;
1880     struct const_dsc {
1881         unsigned short int dsc$w_length;
1882         unsigned char      dsc$b_type;
1883         unsigned char      dsc$b_class;
1884         const char *       dsc$a_pointer;
1885     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1886        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1887     struct itmlst_3 uailst[3] = {
1888         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1889         { sizeof salt, UAI$_SALT,    &salt, 0},
1890         { 0,           0,            NULL,  NULL}};
1891     static char hash[9];
1892
1893     usrdsc.dsc$w_length = strlen(usrname);
1894     usrdsc.dsc$a_pointer = usrname;
1895     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1896       switch (sts) {
1897         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1898           set_errno(EACCES);
1899           break;
1900         case RMS$_RNF:
1901           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1902           break;
1903         default:
1904           set_errno(EVMSERR);
1905       }
1906       set_vaxc_errno(sts);
1907       if (sts != RMS$_RNF) return NULL;
1908     }
1909
1910     txtdsc.dsc$w_length = strlen(textpasswd);
1911     txtdsc.dsc$a_pointer = textpasswd;
1912     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1913       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1914     }
1915
1916     return (char *) hash;
1917
1918 }  /* end of my_crypt() */
1919 /*}}}*/
1920
1921
1922 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1923 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1924 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1925
1926 /* fixup barenames that are directories for internal use.
1927  * There have been problems with the consistent handling of UNIX
1928  * style directory names when routines are presented with a name that
1929  * has no directory delimitors at all.  So this routine will eventually
1930  * fix the issue.
1931  */
1932 static char * fixup_bare_dirnames(const char * name)
1933 {
1934   if (decc_disable_to_vms_logname_translation) {
1935 /* fix me */
1936   }
1937   return NULL;
1938 }
1939
1940 /* 8.3, remove() is now broken on symbolic links */
1941 static int rms_erase(const char * vmsname);
1942
1943
1944 /* mp_do_kill_file
1945  * A little hack to get around a bug in some implemenation of remove()
1946  * that do not know how to delete a directory
1947  *
1948  * Delete any file to which user has control access, regardless of whether
1949  * delete access is explicitly allowed.
1950  * Limitations: User must have write access to parent directory.
1951  *              Does not block signals or ASTs; if interrupted in midstream
1952  *              may leave file with an altered ACL.
1953  * HANDLE WITH CARE!
1954  */
1955 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1956 static int
1957 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1958 {
1959     char *vmsname;
1960     char *rslt;
1961     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1962     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1963     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1964     struct myacedef {
1965       unsigned char myace$b_length;
1966       unsigned char myace$b_type;
1967       unsigned short int myace$w_flags;
1968       unsigned long int myace$l_access;
1969       unsigned long int myace$l_ident;
1970     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1971                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1972       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1973      struct itmlst_3
1974        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1975                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1976        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1977        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1978        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1979        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1980
1981     /* Expand the input spec using RMS, since the CRTL remove() and
1982      * system services won't do this by themselves, so we may miss
1983      * a file "hiding" behind a logical name or search list. */
1984     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1985     if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1986
1987     rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
1988     if (rslt == NULL) {
1989         PerlMem_free(vmsname);
1990         return -1;
1991       }
1992
1993     /* Erase the file */
1994     rmsts = rms_erase(vmsname);
1995
1996     /* Did it succeed */
1997     if ($VMS_STATUS_SUCCESS(rmsts)) {
1998         PerlMem_free(vmsname);
1999         return 0;
2000       }
2001
2002     /* If not, can changing protections help? */
2003     if (rmsts != RMS$_PRV) {
2004       set_vaxc_errno(rmsts);
2005       PerlMem_free(vmsname);
2006       return -1;
2007     }
2008
2009     /* No, so we get our own UIC to use as a rights identifier,
2010      * and the insert an ACE at the head of the ACL which allows us
2011      * to delete the file.
2012      */
2013     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
2014     fildsc.dsc$w_length = strlen(vmsname);
2015     fildsc.dsc$a_pointer = vmsname;
2016     cxt = 0;
2017     newace.myace$l_ident = oldace.myace$l_ident;
2018     rmsts = -1;
2019     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
2020       switch (aclsts) {
2021         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
2022           set_errno(ENOENT); break;
2023         case RMS$_DIR:
2024           set_errno(ENOTDIR); break;
2025         case RMS$_DEV:
2026           set_errno(ENODEV); break;
2027         case RMS$_SYN: case SS$_INVFILFOROP:
2028           set_errno(EINVAL); break;
2029         case RMS$_PRV:
2030           set_errno(EACCES); break;
2031         default:
2032           _ckvmssts_noperl(aclsts);
2033       }
2034       set_vaxc_errno(aclsts);
2035       PerlMem_free(vmsname);
2036       return -1;
2037     }
2038     /* Grab any existing ACEs with this identifier in case we fail */
2039     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
2040     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
2041                     || fndsts == SS$_NOMOREACE ) {
2042       /* Add the new ACE . . . */
2043       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
2044         goto yourroom;
2045
2046       rmsts = rms_erase(vmsname);
2047       if ($VMS_STATUS_SUCCESS(rmsts)) {
2048         rmsts = 0;
2049         }
2050         else {
2051         rmsts = -1;
2052         /* We blew it - dir with files in it, no write priv for
2053          * parent directory, etc.  Put things back the way they were. */
2054         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
2055           goto yourroom;
2056         if (fndsts & 1) {
2057           addlst[0].bufadr = &oldace;
2058           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2059             goto yourroom;
2060         }
2061       }
2062     }
2063
2064     yourroom:
2065     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2066     /* We just deleted it, so of course it's not there.  Some versions of
2067      * VMS seem to return success on the unlock operation anyhow (after all
2068      * the unlock is successful), but others don't.
2069      */
2070     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2071     if (aclsts & 1) aclsts = fndsts;
2072     if (!(aclsts & 1)) {
2073       set_errno(EVMSERR);
2074       set_vaxc_errno(aclsts);
2075     }
2076
2077     PerlMem_free(vmsname);
2078     return rmsts;
2079
2080 }  /* end of kill_file() */
2081 /*}}}*/
2082
2083
2084 /*{{{int do_rmdir(char *name)*/
2085 int
2086 Perl_do_rmdir(pTHX_ const char *name)
2087 {
2088     char * dirfile;
2089     int retval;
2090     Stat_t st;
2091
2092     /* lstat returns a VMS fileified specification of the name */
2093     /* that is looked up, and also lets verifies that this is a directory */
2094
2095     retval = flex_lstat(name, &st);
2096     if (retval != 0) {
2097         char * ret_spec;
2098
2099         /* Due to a historical feature, flex_stat/lstat can not see some */
2100         /* Unix format file names that the rest of the CRTL can see */
2101         /* Fixing that feature will cause some perl tests to fail */
2102         /* So try this one more time. */
2103
2104         retval = lstat(name, &st.crtl_stat);
2105         if (retval != 0)
2106             return -1;
2107
2108         /* force it to a file spec for the kill file to work. */
2109         ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
2110         if (ret_spec == NULL) {
2111             errno = EIO;
2112             return -1;
2113         }
2114     }
2115
2116     if (!S_ISDIR(st.st_mode)) {
2117         errno = ENOTDIR;
2118         retval = -1;
2119     }
2120     else {
2121         dirfile = st.st_devnam;
2122
2123         /* It may be possible for flex_stat to find a file and vmsify() to */
2124         /* fail with ODS-2 specifications.  mp_do_kill_file can not deal */
2125         /* with that case, so fail it */
2126         if (dirfile[0] == 0) {
2127             errno = EIO;
2128             return -1;
2129         }
2130
2131         retval = mp_do_kill_file(aTHX_ dirfile, 1);
2132     }
2133
2134     return retval;
2135
2136 }  /* end of do_rmdir */
2137 /*}}}*/
2138
2139 /* kill_file
2140  * Delete any file to which user has control access, regardless of whether
2141  * delete access is explicitly allowed.
2142  * Limitations: User must have write access to parent directory.
2143  *              Does not block signals or ASTs; if interrupted in midstream
2144  *              may leave file with an altered ACL.
2145  * HANDLE WITH CARE!
2146  */
2147 /*{{{int kill_file(char *name)*/
2148 int
2149 Perl_kill_file(pTHX_ const char *name)
2150 {
2151     char * vmsfile;
2152     Stat_t st;
2153     int rmsts;
2154
2155     /* Convert the filename to VMS format and see if it is a directory */
2156     /* flex_lstat returns a vmsified file specification */
2157     rmsts = flex_lstat(name, &st);
2158     if (rmsts != 0) {
2159
2160         /* Due to a historical feature, flex_stat/lstat can not see some */
2161         /* Unix format file names that the rest of the CRTL can see when */
2162         /* ODS-2 file specifications are in use. */
2163         /* Fixing that feature will cause some perl tests to fail */
2164         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2165         st.st_mode = 0;
2166         vmsfile = (char *) name; /* cast ok */
2167
2168     } else {
2169         vmsfile = st.st_devnam;
2170         if (vmsfile[0] == 0) {
2171             /* It may be possible for flex_stat to find a file and vmsify() */
2172             /* to fail with ODS-2 specifications.  mp_do_kill_file can not */
2173             /* deal with that case, so fail it */
2174             errno = EIO;
2175             return -1;
2176         }
2177     }
2178
2179     /* Remove() is allowed to delete directories, according to the X/Open
2180      * specifications.
2181      * This may need special handling to work with the ACL hacks.
2182      */
2183     if (S_ISDIR(st.st_mode)) {
2184         rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
2185         return rmsts;
2186     }
2187
2188     rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2189
2190     /* Need to delete all versions ? */
2191     if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
2192         int i = 0;
2193
2194         /* Just use lstat() here as do not need st_dev */
2195         /* and we know that the file is in VMS format or that */
2196         /* because of a historical bug, flex_stat can not see the file */
2197         while (lstat(vmsfile, (stat_t *)&st) == 0) {
2198             rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2199             if (rmsts != 0)
2200                 break;
2201             i++;
2202
2203             /* Make sure that we do not loop forever */
2204             if (i > 32767) {
2205                 errno = EIO;
2206                 rmsts = -1;
2207                 break;
2208             }
2209         }
2210     }
2211
2212     return rmsts;
2213
2214 }  /* end of kill_file() */
2215 /*}}}*/
2216
2217
2218 /*{{{int my_mkdir(char *,Mode_t)*/
2219 int
2220 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2221 {
2222   STRLEN dirlen = strlen(dir);
2223
2224   /* zero length string sometimes gives ACCVIO */
2225   if (dirlen == 0) return -1;
2226
2227   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2228    * null file name/type.  However, it's commonplace under Unix,
2229    * so we'll allow it for a gain in portability.
2230    */
2231   if (dir[dirlen-1] == '/') {
2232     char *newdir = savepvn(dir,dirlen-1);
2233     int ret = mkdir(newdir,mode);
2234     Safefree(newdir);
2235     return ret;
2236   }
2237   else return mkdir(dir,mode);
2238 }  /* end of my_mkdir */
2239 /*}}}*/
2240
2241 /*{{{int my_chdir(char *)*/
2242 int
2243 Perl_my_chdir(pTHX_ const char *dir)
2244 {
2245   STRLEN dirlen = strlen(dir);
2246
2247   /* zero length string sometimes gives ACCVIO */
2248   if (dirlen == 0) return -1;
2249   const char *dir1;
2250
2251   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2252    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2253    * so that existing scripts do not need to be changed.
2254    */
2255   dir1 = dir;
2256   while ((dirlen > 0) && (*dir1 == ' ')) {
2257     dir1++;
2258     dirlen--;
2259   }
2260
2261   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2262    * that implies
2263    * null file name/type.  However, it's commonplace under Unix,
2264    * so we'll allow it for a gain in portability.
2265    *
2266    *  '/' is valid when SYS$POSIX_ROOT or POSIX compliant pathnames are active.
2267    */
2268   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2269       char *newdir;
2270       int ret;
2271       newdir = PerlMem_malloc(dirlen);
2272       if (newdir ==NULL)
2273           _ckvmssts_noperl(SS$_INSFMEM);
2274       strncpy(newdir, dir1, dirlen-1);
2275       newdir[dirlen-1] = '\0';
2276       ret = chdir(newdir);
2277       PerlMem_free(newdir);
2278       return ret;
2279   }
2280   else return chdir(dir1);
2281 }  /* end of my_chdir */
2282 /*}}}*/
2283
2284
2285 /*{{{int my_chmod(char *, mode_t)*/
2286 int
2287 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2288 {
2289   Stat_t st;
2290   int ret = -1;
2291   char * changefile;
2292   STRLEN speclen = strlen(file_spec);
2293
2294   /* zero length string sometimes gives ACCVIO */
2295   if (speclen == 0) return -1;
2296
2297   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2298    * that implies null file name/type.  However, it's commonplace under Unix,
2299    * so we'll allow it for a gain in portability.
2300    *
2301    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2302    * in VMS file.dir notation.
2303    */
2304   changefile = (char *) file_spec; /* cast ok */
2305   ret = flex_lstat(file_spec, &st);
2306   if (ret != 0) {
2307
2308         /* Due to a historical feature, flex_stat/lstat can not see some */
2309         /* Unix format file names that the rest of the CRTL can see when */
2310         /* ODS-2 file specifications are in use. */
2311         /* Fixing that feature will cause some perl tests to fail */
2312         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2313         st.st_mode = 0;
2314
2315   } else {
2316       /* It may be possible to get here with nothing in st_devname */
2317       /* chmod still may work though */
2318       if (st.st_devnam[0] != 0) {
2319           changefile = st.st_devnam;
2320       }
2321   }
2322   ret = chmod(changefile, mode);
2323   return ret;
2324 }  /* end of my_chmod */
2325 /*}}}*/
2326
2327
2328 /*{{{FILE *my_tmpfile()*/
2329 FILE *
2330 my_tmpfile(void)
2331 {
2332   FILE *fp;
2333   char *cp;
2334
2335   if ((fp = tmpfile())) return fp;
2336
2337   cp = PerlMem_malloc(L_tmpnam+24);
2338   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2339
2340   if (decc_filename_unix_only == 0)
2341     strcpy(cp,"Sys$Scratch:");
2342   else
2343     strcpy(cp,"/tmp/");
2344   tmpnam(cp+strlen(cp));
2345   strcat(cp,".Perltmp");
2346   fp = fopen(cp,"w+","fop=dlt");
2347   PerlMem_free(cp);
2348   return fp;
2349 }
2350 /*}}}*/
2351
2352
2353 #ifndef HOMEGROWN_POSIX_SIGNALS
2354 /*
2355  * The C RTL's sigaction fails to check for invalid signal numbers so we
2356  * help it out a bit.  The docs are correct, but the actual routine doesn't
2357  * do what the docs say it will.
2358  */
2359 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2360 int
2361 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2362                    struct sigaction* oact)
2363 {
2364   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2365         SETERRNO(EINVAL, SS$_INVARG);
2366         return -1;
2367   }
2368   return sigaction(sig, act, oact);
2369 }
2370 /*}}}*/
2371 #endif
2372
2373 #ifdef KILL_BY_SIGPRC
2374 #include <errnodef.h>
2375
2376 /* We implement our own kill() using the undocumented system service
2377    sys$sigprc for one of two reasons:
2378
2379    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2380    target process to do a sys$exit, which usually can't be handled
2381    gracefully...certainly not by Perl and the %SIG{} mechanism.
2382
2383    2.) If the kill() in the CRTL can't be called from a signal
2384    handler without disappearing into the ether, i.e., the signal
2385    it purportedly sends is never trapped. Still true as of VMS 7.3.
2386
2387    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2388    in the target process rather than calling sys$exit.
2389
2390    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2391    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2392    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2393    with condition codes C$_SIG0+nsig*8, catching the exception on the
2394    target process and resignaling with appropriate arguments.
2395
2396    But we don't have that VMS 7.0+ exception handler, so if you
2397    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2398
2399    Also note that SIGTERM is listed in the docs as being "unimplemented",
2400    yet always seems to be signaled with a VMS condition code of 4 (and
2401    correctly handled for that code).  So we hardwire it in.
2402
2403    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2404    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2405    than signalling with an unrecognized (and unhandled by CRTL) code.
2406 */
2407
2408 #define _MY_SIG_MAX 28
2409
2410 static unsigned int
2411 Perl_sig_to_vmscondition_int(int sig)
2412 {
2413     static unsigned int sig_code[_MY_SIG_MAX+1] =
2414     {
2415         0,                  /*  0 ZERO     */
2416         SS$_HANGUP,         /*  1 SIGHUP   */
2417         SS$_CONTROLC,       /*  2 SIGINT   */
2418         SS$_CONTROLY,       /*  3 SIGQUIT  */
2419         SS$_RADRMOD,        /*  4 SIGILL   */
2420         SS$_BREAK,          /*  5 SIGTRAP  */
2421         SS$_OPCCUS,         /*  6 SIGABRT  */
2422         SS$_COMPAT,         /*  7 SIGEMT   */
2423 #ifdef __VAX
2424         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2425 #else
2426         SS$_HPARITH,        /*  8 SIGFPE AXP */
2427 #endif
2428         SS$_ABORT,          /*  9 SIGKILL  */
2429         SS$_ACCVIO,         /* 10 SIGBUS   */
2430         SS$_ACCVIO,         /* 11 SIGSEGV  */
2431         SS$_BADPARAM,       /* 12 SIGSYS   */
2432         SS$_NOMBX,          /* 13 SIGPIPE  */
2433         SS$_ASTFLT,         /* 14 SIGALRM  */
2434         4,                  /* 15 SIGTERM  */
2435         0,                  /* 16 SIGUSR1  */
2436         0,                  /* 17 SIGUSR2  */
2437         0,                  /* 18 */
2438         0,                  /* 19 */
2439         0,                  /* 20 SIGCHLD  */
2440         0,                  /* 21 SIGCONT  */
2441         0,                  /* 22 SIGSTOP  */
2442         0,                  /* 23 SIGTSTP  */
2443         0,                  /* 24 SIGTTIN  */
2444         0,                  /* 25 SIGTTOU  */
2445         0,                  /* 26 */
2446         0,                  /* 27 */
2447         0                   /* 28 SIGWINCH  */
2448     };
2449
2450 #if __VMS_VER >= 60200000
2451     static int initted = 0;
2452     if (!initted) {
2453         initted = 1;
2454         sig_code[16] = C$_SIGUSR1;
2455         sig_code[17] = C$_SIGUSR2;
2456 #if __CRTL_VER >= 70000000
2457         sig_code[20] = C$_SIGCHLD;
2458 #endif
2459 #if __CRTL_VER >= 70300000
2460         sig_code[28] = C$_SIGWINCH;
2461 #endif
2462     }
2463 #endif
2464
2465     if (sig < _SIG_MIN) return 0;
2466     if (sig > _MY_SIG_MAX) return 0;
2467     return sig_code[sig];
2468 }
2469
2470 unsigned int
2471 Perl_sig_to_vmscondition(int sig)
2472 {
2473 #ifdef SS$_DEBUG
2474     if (vms_debug_on_exception != 0)
2475         lib$signal(SS$_DEBUG);
2476 #endif
2477     return Perl_sig_to_vmscondition_int(sig);
2478 }
2479
2480
2481 int
2482 Perl_my_kill(int pid, int sig)
2483 {
2484     dTHX;
2485     int iss;
2486     unsigned int code;
2487     int sys$sigprc(unsigned int *pidadr,
2488                      struct dsc$descriptor_s *prcname,
2489                      unsigned int code);
2490
2491      /* sig 0 means validate the PID */
2492     /*------------------------------*/
2493     if (sig == 0) {
2494         const unsigned long int jpicode = JPI$_PID;
2495         pid_t ret_pid;
2496         int status;
2497         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2498         if ($VMS_STATUS_SUCCESS(status))
2499            return 0;
2500         switch (status) {
2501         case SS$_NOSUCHNODE:
2502         case SS$_UNREACHABLE:
2503         case SS$_NONEXPR:
2504            errno = ESRCH;
2505            break;
2506         case SS$_NOPRIV:
2507            errno = EPERM;
2508            break;
2509         default:
2510            errno = EVMSERR;
2511         }
2512         vaxc$errno=status;
2513         return -1;
2514     }
2515
2516     code = Perl_sig_to_vmscondition_int(sig);
2517
2518     if (!code) {
2519         SETERRNO(EINVAL, SS$_BADPARAM);
2520         return -1;
2521     }
2522
2523     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2524      * signals are to be sent to multiple processes.
2525      *  pid = 0 - all processes in group except ones that the system exempts
2526      *  pid = -1 - all processes except ones that the system exempts
2527      *  pid = -n - all processes in group (abs(n)) except ...
2528      * For now, just report as not supported.
2529      */
2530
2531     if (pid <= 0) {
2532         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2533         return -1;
2534     }
2535
2536     iss = sys$sigprc((unsigned int *)&pid,0,code);
2537     if (iss&1) return 0;
2538
2539     switch (iss) {
2540       case SS$_NOPRIV:
2541         set_errno(EPERM);  break;
2542       case SS$_NONEXPR:
2543       case SS$_NOSUCHNODE:
2544       case SS$_UNREACHABLE:
2545         set_errno(ESRCH);  break;
2546       case SS$_INSFMEM:
2547         set_errno(ENOMEM); break;
2548       default:
2549         _ckvmssts_noperl(iss);
2550         set_errno(EVMSERR);
2551     }
2552     set_vaxc_errno(iss);
2553
2554     return -1;
2555 }
2556 #endif
2557
2558 /* Routine to convert a VMS status code to a UNIX status code.
2559 ** More tricky than it appears because of conflicting conventions with
2560 ** existing code.
2561 **
2562 ** VMS status codes are a bit mask, with the least significant bit set for
2563 ** success.
2564 **
2565 ** Special UNIX status of EVMSERR indicates that no translation is currently
2566 ** available, and programs should check the VMS status code.
2567 **
2568 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2569 ** decoding.
2570 */
2571
2572 #ifndef C_FACILITY_NO
2573 #define C_FACILITY_NO 0x350000
2574 #endif
2575 #ifndef DCL_IVVERB
2576 #define DCL_IVVERB 0x38090
2577 #endif
2578
2579 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2580 {
2581 int facility;
2582 int fac_sp;
2583 int msg_no;
2584 int msg_status;
2585 int unix_status;
2586
2587   /* Assume the best or the worst */
2588   if (vms_status & STS$M_SUCCESS)
2589     unix_status = 0;
2590   else
2591     unix_status = EVMSERR;
2592
2593   msg_status = vms_status & ~STS$M_CONTROL;
2594
2595   facility = vms_status & STS$M_FAC_NO;
2596   fac_sp = vms_status & STS$M_FAC_SP;
2597   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2598
2599   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2600     switch(msg_no) {
2601     case SS$_NORMAL:
2602         unix_status = 0;
2603         break;
2604     case SS$_ACCVIO:
2605         unix_status = EFAULT;
2606         break;
2607     case SS$_DEVOFFLINE:
2608         unix_status = EBUSY;
2609         break;
2610     case SS$_CLEARED:
2611         unix_status = ENOTCONN;
2612         break;
2613     case SS$_IVCHAN:
2614     case SS$_IVLOGNAM:
2615     case SS$_BADPARAM:
2616     case SS$_IVLOGTAB:
2617     case SS$_NOLOGNAM:
2618     case SS$_NOLOGTAB:
2619     case SS$_INVFILFOROP:
2620     case SS$_INVARG:
2621     case SS$_NOSUCHID:
2622     case SS$_IVIDENT:
2623         unix_status = EINVAL;
2624         break;
2625     case SS$_UNSUPPORTED:
2626         unix_status = ENOTSUP;
2627         break;
2628     case SS$_FILACCERR:
2629     case SS$_NOGRPPRV:
2630     case SS$_NOSYSPRV:
2631         unix_status = EACCES;
2632         break;
2633     case SS$_DEVICEFULL:
2634         unix_status = ENOSPC;
2635         break;
2636     case SS$_NOSUCHDEV:
2637         unix_status = ENODEV;
2638         break;
2639     case SS$_NOSUCHFILE:
2640     case SS$_NOSUCHOBJECT:
2641         unix_status = ENOENT;
2642         break;
2643     case SS$_ABORT:                                 /* Fatal case */
2644     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2645     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2646         unix_status = EINTR;
2647         break;
2648     case SS$_BUFFEROVF:
2649         unix_status = E2BIG;
2650         break;
2651     case SS$_INSFMEM:
2652         unix_status = ENOMEM;
2653         break;
2654     case SS$_NOPRIV:
2655         unix_status = EPERM;
2656         break;
2657     case SS$_NOSUCHNODE:
2658     case SS$_UNREACHABLE:
2659         unix_status = ESRCH;
2660         break;
2661     case SS$_NONEXPR:
2662         unix_status = ECHILD;
2663         break;
2664     default:
2665         if ((facility == 0) && (msg_no < 8)) {
2666           /* These are not real VMS status codes so assume that they are
2667           ** already UNIX status codes
2668           */
2669           unix_status = msg_no;
2670           break;
2671         }
2672     }
2673   }
2674   else {
2675     /* Translate a POSIX exit code to a UNIX exit code */
2676     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2677         unix_status = (msg_no & 0x07F8) >> 3;
2678     }
2679     else {
2680
2681          /* Documented traditional behavior for handling VMS child exits */
2682         /*--------------------------------------------------------------*/
2683         if (child_flag != 0) {
2684
2685              /* Success / Informational return 0 */
2686             /*----------------------------------*/
2687             if (msg_no & STS$K_SUCCESS)
2688                 return 0;
2689
2690              /* Warning returns 1 */
2691             /*-------------------*/
2692             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2693                 return 1;
2694
2695              /* Everything else pass through the severity bits */
2696             /*------------------------------------------------*/
2697             return (msg_no & STS$M_SEVERITY);
2698         }
2699
2700          /* Normal VMS status to ERRNO mapping attempt */
2701         /*--------------------------------------------*/
2702         switch(msg_status) {
2703         /* case RMS$_EOF: */ /* End of File */
2704         case RMS$_FNF:  /* File Not Found */
2705         case RMS$_DNF:  /* Dir Not Found */
2706                 unix_status = ENOENT;
2707                 break;
2708         case RMS$_RNF:  /* Record Not Found */
2709                 unix_status = ESRCH;
2710                 break;
2711         case RMS$_DIR:
2712                 unix_status = ENOTDIR;
2713                 break;
2714         case RMS$_DEV:
2715                 unix_status = ENODEV;
2716                 break;
2717         case RMS$_IFI:
2718         case RMS$_FAC:
2719         case RMS$_ISI:
2720                 unix_status = EBADF;
2721                 break;
2722         case RMS$_FEX:
2723                 unix_status = EEXIST;
2724                 break;
2725         case RMS$_SYN:
2726         case RMS$_FNM:
2727         case LIB$_INVSTRDES:
2728         case LIB$_INVARG:
2729         case LIB$_NOSUCHSYM:
2730         case LIB$_INVSYMNAM:
2731         case DCL_IVVERB:
2732                 unix_status = EINVAL;
2733                 break;
2734         case CLI$_BUFOVF:
2735         case RMS$_RTB:
2736         case CLI$_TKNOVF:
2737         case CLI$_RSLOVF:
2738                 unix_status = E2BIG;
2739                 break;
2740         case RMS$_PRV:  /* No privilege */
2741         case RMS$_ACC:  /* ACP file access failed */
2742         case RMS$_WLK:  /* Device write locked */
2743                 unix_status = EACCES;
2744                 break;
2745         case RMS$_MKD:  /* Failed to mark for delete */
2746                 unix_status = EPERM;
2747                 break;
2748         /* case RMS$_NMF: */  /* No more files */
2749         }
2750     }
2751   }
2752
2753   return unix_status;
2754 }
2755
2756 /* Try to guess at what VMS error status should go with a UNIX errno
2757  * value.  This is hard to do as there could be many possible VMS
2758  * error statuses that caused the errno value to be set.
2759  */
2760
2761 int Perl_unix_status_to_vms(int unix_status)
2762 {
2763 int test_unix_status;
2764
2765      /* Trivial cases first */
2766     /*---------------------*/
2767     if (unix_status == EVMSERR)
2768         return vaxc$errno;
2769
2770      /* Is vaxc$errno sane? */
2771     /*---------------------*/
2772     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2773     if (test_unix_status == unix_status)
2774         return vaxc$errno;
2775
2776      /* If way out of range, must be VMS code already */
2777     /*-----------------------------------------------*/
2778     if (unix_status > EVMSERR)
2779         return unix_status;
2780
2781      /* If out of range, punt */
2782     /*-----------------------*/
2783     if (unix_status > __ERRNO_MAX)
2784         return SS$_ABORT;
2785
2786
2787      /* Ok, now we have to do it the hard way. */
2788     /*----------------------------------------*/
2789     switch(unix_status) {
2790     case 0:     return SS$_NORMAL;
2791     case EPERM: return SS$_NOPRIV;
2792     case ENOENT: return SS$_NOSUCHOBJECT;
2793     case ESRCH: return SS$_UNREACHABLE;
2794     case EINTR: return SS$_ABORT;
2795     /* case EIO: */
2796     /* case ENXIO:  */
2797     case E2BIG: return SS$_BUFFEROVF;
2798     /* case ENOEXEC */
2799     case EBADF: return RMS$_IFI;
2800     case ECHILD: return SS$_NONEXPR;
2801     /* case EAGAIN */
2802     case ENOMEM: return SS$_INSFMEM;
2803     case EACCES: return SS$_FILACCERR;
2804     case EFAULT: return SS$_ACCVIO;
2805     /* case ENOTBLK */
2806     case EBUSY: return SS$_DEVOFFLINE;
2807     case EEXIST: return RMS$_FEX;
2808     /* case EXDEV */
2809     case ENODEV: return SS$_NOSUCHDEV;
2810     case ENOTDIR: return RMS$_DIR;
2811     /* case EISDIR */
2812     case EINVAL: return SS$_INVARG;
2813     /* case ENFILE */
2814     /* case EMFILE */
2815     /* case ENOTTY */
2816     /* case ETXTBSY */
2817     /* case EFBIG */
2818     case ENOSPC: return SS$_DEVICEFULL;
2819     case ESPIPE: return LIB$_INVARG;
2820     /* case EROFS: */
2821     /* case EMLINK: */
2822     /* case EPIPE: */
2823     /* case EDOM */
2824     case ERANGE: return LIB$_INVARG;
2825     /* case EWOULDBLOCK */
2826     /* case EINPROGRESS */
2827     /* case EALREADY */
2828     /* case ENOTSOCK */
2829     /* case EDESTADDRREQ */
2830     /* case EMSGSIZE */
2831     /* case EPROTOTYPE */
2832     /* case ENOPROTOOPT */
2833     /* case EPROTONOSUPPORT */
2834     /* case ESOCKTNOSUPPORT */
2835     /* case EOPNOTSUPP */
2836     /* case EPFNOSUPPORT */
2837     /* case EAFNOSUPPORT */
2838     /* case EADDRINUSE */
2839     /* case EADDRNOTAVAIL */
2840     /* case ENETDOWN */
2841     /* case ENETUNREACH */
2842     /* case ENETRESET */
2843     /* case ECONNABORTED */
2844     /* case ECONNRESET */
2845     /* case ENOBUFS */
2846     /* case EISCONN */
2847     case ENOTCONN: return SS$_CLEARED;
2848     /* case ESHUTDOWN */
2849     /* case ETOOMANYREFS */
2850     /* case ETIMEDOUT */
2851     /* case ECONNREFUSED */
2852     /* case ELOOP */
2853     /* case ENAMETOOLONG */
2854     /* case EHOSTDOWN */
2855     /* case EHOSTUNREACH */
2856     /* case ENOTEMPTY */
2857     /* case EPROCLIM */
2858     /* case EUSERS  */
2859     /* case EDQUOT  */
2860     /* case ENOMSG  */
2861     /* case EIDRM */
2862     /* case EALIGN */
2863     /* case ESTALE */
2864     /* case EREMOTE */
2865     /* case ENOLCK */
2866     /* case ENOSYS */
2867     /* case EFTYPE */
2868     /* case ECANCELED */
2869     /* case EFAIL */
2870     /* case EINPROG */
2871     case ENOTSUP:
2872         return SS$_UNSUPPORTED;
2873     /* case EDEADLK */
2874     /* case ENWAIT */
2875     /* case EILSEQ */
2876     /* case EBADCAT */
2877     /* case EBADMSG */
2878     /* case EABANDONED */
2879     default:
2880         return SS$_ABORT; /* punt */
2881     }
2882
2883   return SS$_ABORT; /* Should not get here */
2884 }
2885
2886
2887 /* default piping mailbox size */
2888 #ifdef __VAX
2889 #  define PERL_BUFSIZ        512
2890 #else
2891 #  define PERL_BUFSIZ        8192
2892 #endif
2893
2894
2895 static void
2896 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2897 {
2898   unsigned long int mbxbufsiz;
2899   static unsigned long int syssize = 0;
2900   unsigned long int dviitm = DVI$_DEVNAM;
2901   char csize[LNM$C_NAMLENGTH+1];
2902   int sts;
2903
2904   if (!syssize) {
2905     unsigned long syiitm = SYI$_MAXBUF;
2906     /*
2907      * Get the SYSGEN parameter MAXBUF
2908      *
2909      * If the logical 'PERL_MBX_SIZE' is defined
2910      * use the value of the logical instead of PERL_BUFSIZ, but
2911      * keep the size between 128 and MAXBUF.
2912      *
2913      */
2914     _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2915   }
2916
2917   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2918       mbxbufsiz = atoi(csize);
2919   } else {
2920       mbxbufsiz = PERL_BUFSIZ;
2921   }
2922   if (mbxbufsiz < 128) mbxbufsiz = 128;
2923   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2924
2925   _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2926
2927   sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2928   _ckvmssts_noperl(sts);
2929   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2930
2931 }  /* end of create_mbx() */
2932
2933
2934 /*{{{  my_popen and my_pclose*/
2935
2936 typedef struct _iosb           IOSB;
2937 typedef struct _iosb*         pIOSB;
2938 typedef struct _pipe           Pipe;
2939 typedef struct _pipe*         pPipe;
2940 typedef struct pipe_details    Info;
2941 typedef struct pipe_details*  pInfo;
2942 typedef struct _srqp            RQE;
2943 typedef struct _srqp*          pRQE;
2944 typedef struct _tochildbuf      CBuf;
2945 typedef struct _tochildbuf*    pCBuf;
2946
2947 struct _iosb {
2948     unsigned short status;
2949     unsigned short count;
2950     unsigned long  dvispec;
2951 };
2952
2953 #pragma member_alignment save
2954 #pragma nomember_alignment quadword
2955 struct _srqp {          /* VMS self-relative queue entry */
2956     unsigned long qptr[2];
2957 };
2958 #pragma member_alignment restore
2959 static RQE  RQE_ZERO = {0,0};
2960
2961 struct _tochildbuf {
2962     RQE             q;
2963     int             eof;
2964     unsigned short  size;
2965     char            *buf;
2966 };
2967
2968 struct _pipe {
2969     RQE            free;
2970     RQE            wait;
2971     int            fd_out;
2972     unsigned short chan_in;
2973     unsigned short chan_out;
2974     char          *buf;
2975     unsigned int   bufsize;
2976     IOSB           iosb;
2977     IOSB           iosb2;
2978     int           *pipe_done;
2979     int            retry;
2980     int            type;
2981     int            shut_on_empty;
2982     int            need_wake;
2983     pPipe         *home;
2984     pInfo          info;
2985     pCBuf          curr;
2986     pCBuf          curr2;
2987 #if defined(PERL_IMPLICIT_CONTEXT)
2988     void            *thx;           /* Either a thread or an interpreter */
2989                                     /* pointer, depending on how we're built */
2990 #endif
2991 };
2992
2993
2994 struct pipe_details
2995 {
2996     pInfo           next;
2997     PerlIO *fp;  /* file pointer to pipe mailbox */
2998     int useFILE; /* using stdio, not perlio */
2999     int pid;   /* PID of subprocess */
3000     int mode;  /* == 'r' if pipe open for reading */
3001     int done;  /* subprocess has completed */
3002     int waiting; /* waiting for completion/closure */
3003     int             closing;        /* my_pclose is closing this pipe */
3004     unsigned long   completion;     /* termination status of subprocess */
3005     pPipe           in;             /* pipe in to sub */
3006     pPipe           out;            /* pipe out of sub */
3007     pPipe           err;            /* pipe of sub's sys$error */
3008     int             in_done;        /* true when in pipe finished */
3009     int             out_done;
3010     int             err_done;
3011     unsigned short  xchan;          /* channel to debug xterm */
3012     unsigned short  xchan_valid;    /* channel is assigned */
3013 };
3014
3015 struct exit_control_block
3016 {
3017     struct exit_control_block *flink;
3018     unsigned long int   (*exit_routine)();
3019     unsigned long int arg_count;
3020     unsigned long int *status_address;
3021     unsigned long int exit_status;
3022 };
3023
3024 typedef struct _closed_pipes    Xpipe;
3025 typedef struct _closed_pipes*  pXpipe;
3026
3027 struct _closed_pipes {
3028     int             pid;            /* PID of subprocess */
3029     unsigned long   completion;     /* termination status of subprocess */
3030 };
3031 #define NKEEPCLOSED 50
3032 static Xpipe closed_list[NKEEPCLOSED];
3033 static int   closed_index = 0;
3034 static int   closed_num = 0;
3035
3036 #define RETRY_DELAY     "0 ::0.20"
3037 #define MAX_RETRY              50
3038
3039 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
3040 static unsigned long mypid;
3041 static unsigned long delaytime[2];
3042
3043 static pInfo open_pipes = NULL;
3044 static $DESCRIPTOR(nl_desc, "NL:");
3045
3046 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
3047
3048
3049
3050 static unsigned long int
3051 pipe_exit_routine()
3052 {
3053     pInfo info;
3054     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
3055     int sts, did_stuff, need_eof, j;
3056
3057    /*
3058     * Flush any pending i/o, but since we are in process run-down, be
3059     * careful about referencing PerlIO structures that may already have
3060     * been deallocated.  We may not even have an interpreter anymore.
3061     */
3062     info = open_pipes;
3063     while (info) {
3064         if (info->fp) {
3065 #if defined(PERL_IMPLICIT_CONTEXT)
3066            /* We need to use the Perl context of the thread that created */
3067            /* the pipe. */
3068            pTHX;
3069            if (info->err)
3070                aTHX = info->err->thx;
3071            else if (info->out)
3072                aTHX = info->out->thx;
3073            else if (info->in)
3074                aTHX = info->in->thx;
3075 #endif
3076            if (!info->useFILE
3077 #if defined(USE_ITHREADS)
3078              && my_perl
3079 #endif
3080 #ifdef USE_PERLIO
3081              && PL_perlio_fd_refcnt
3082 #endif
3083               )
3084                PerlIO_flush(info->fp);
3085            else
3086                fflush((FILE *)info->fp);
3087         }
3088         info = info->next;
3089     }
3090
3091     /*
3092      next we try sending an EOF...ignore if doesn't work, make sure we
3093      don't hang
3094     */
3095     did_stuff = 0;
3096     info = open_pipes;
3097
3098     while (info) {
3099       int need_eof;
3100       _ckvmssts_noperl(sys$setast(0));
3101       if (info->in && !info->in->shut_on_empty) {
3102         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3103                                  0, 0, 0, 0, 0, 0));
3104         info->waiting = 1;
3105         did_stuff = 1;
3106       }
3107       _ckvmssts_noperl(sys$setast(1));
3108       info = info->next;
3109     }
3110
3111     /* wait for EOF to have effect, up to ~ 30 sec [default] */
3112
3113     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3114         int nwait = 0;
3115
3116         info = open_pipes;
3117         while (info) {
3118           _ckvmssts_noperl(sys$setast(0));
3119           if (info->waiting && info->done)
3120                 info->waiting = 0;
3121           nwait += info->waiting;
3122           _ckvmssts_noperl(sys$setast(1));
3123           info = info->next;
3124         }
3125         if (!nwait) break;
3126         sleep(1);
3127     }
3128
3129     did_stuff = 0;
3130     info = open_pipes;
3131     while (info) {
3132       _ckvmssts_noperl(sys$setast(0));
3133       if (!info->done) { /* Tap them gently on the shoulder . . .*/
3134         sts = sys$forcex(&info->pid,0,&abort);
3135         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3136         did_stuff = 1;
3137       }
3138       _ckvmssts_noperl(sys$setast(1));
3139       info = info->next;
3140     }
3141
3142     /* again, wait for effect */
3143
3144     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3145         int nwait = 0;
3146
3147         info = open_pipes;
3148         while (info) {
3149           _ckvmssts_noperl(sys$setast(0));
3150           if (info->waiting && info->done)
3151                 info->waiting = 0;
3152           nwait += info->waiting;
3153           _ckvmssts_noperl(sys$setast(1));
3154           info = info->next;
3155         }
3156         if (!nwait) break;
3157         sleep(1);
3158     }
3159
3160     info = open_pipes;
3161     while (info) {
3162       _ckvmssts_noperl(sys$setast(0));
3163       if (!info->done) {  /* We tried to be nice . . . */
3164         sts = sys$delprc(&info->pid,0);
3165         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3166         info->done = 1;  /* sys$delprc is as done as we're going to get. */
3167       }
3168       _ckvmssts_noperl(sys$setast(1));
3169       info = info->next;
3170     }
3171
3172     while(open_pipes) {
3173
3174 #if defined(PERL_IMPLICIT_CONTEXT)
3175       /* We need to use the Perl context of the thread that created */
3176       /* the pipe. */
3177       pTHX;
3178       if (open_pipes->err)
3179           aTHX = open_pipes->err->thx;
3180       else if (open_pipes->out)
3181           aTHX = open_pipes->out->thx;
3182       else if (open_pipes->in)
3183           aTHX = open_pipes->in->thx;
3184 #endif
3185       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3186       else if (!(sts & 1)) retsts = sts;
3187     }
3188     return retsts;
3189 }
3190
3191 static struct exit_control_block pipe_exitblock =
3192        {(struct exit_control_block *) 0,
3193         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3194
3195 static void pipe_mbxtofd_ast(pPipe p);
3196 static void pipe_tochild1_ast(pPipe p);
3197 static void pipe_tochild2_ast(pPipe p);
3198
3199 static void
3200 popen_completion_ast(pInfo info)
3201 {
3202   pInfo i = open_pipes;
3203   int iss;
3204   int sts;
3205   pXpipe x;
3206
3207   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3208   closed_list[closed_index].pid = info->pid;
3209   closed_list[closed_index].completion = info->completion;
3210   closed_index++;
3211   if (closed_index == NKEEPCLOSED)
3212     closed_index = 0;
3213   closed_num++;
3214
3215   while (i) {
3216     if (i == info) break;
3217     i = i->next;
3218   }
3219   if (!i) return;       /* unlinked, probably freed too */
3220
3221   info->done = TRUE;
3222
3223 /*
3224     Writing to subprocess ...
3225             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3226
3227             chan_out may be waiting for "done" flag, or hung waiting
3228             for i/o completion to child...cancel the i/o.  This will
3229             put it into "snarf mode" (done but no EOF yet) that discards
3230             input.
3231
3232     Output from subprocess (stdout, stderr) needs to be flushed and
3233     shut down.   We try sending an EOF, but if the mbx is full the pipe
3234     routine should still catch the "shut_on_empty" flag, telling it to
3235     use immediate-style reads so that "mbx empty" -> EOF.
3236
3237
3238 */
3239   if (info->in && !info->in_done) {               /* only for mode=w */
3240         if (info->in->shut_on_empty && info->in->need_wake) {
3241             info->in->need_wake = FALSE;
3242             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3243         } else {
3244             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3245         }
3246   }
3247
3248   if (info->out && !info->out_done) {             /* were we also piping output? */
3249       info->out->shut_on_empty = TRUE;
3250       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3251       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3252       _ckvmssts_noperl(iss);
3253   }
3254
3255   if (info->err && !info->err_done) {        /* we were piping stderr */
3256         info->err->shut_on_empty = TRUE;
3257         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3258         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3259         _ckvmssts_noperl(iss);
3260   }
3261   _ckvmssts_noperl(sys$setef(pipe_ef));
3262
3263 }
3264
3265 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3266 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3267
3268 /*
3269     we actually differ from vmstrnenv since we use this to
3270     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3271     are pointing to the same thing
3272 */
3273
3274 static unsigned short
3275 popen_translate(pTHX_ char *logical, char *result)
3276 {
3277     int iss;
3278     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3279     $DESCRIPTOR(d_log,"");
3280     struct _il3 {
3281         unsigned short length;
3282         unsigned short code;
3283         char *         buffer_addr;
3284         unsigned short *retlenaddr;
3285     } itmlst[2];
3286     unsigned short l, ifi;
3287
3288     d_log.dsc$a_pointer = logical;
3289     d_log.dsc$w_length  = strlen(logical);
3290
3291     itmlst[0].code = LNM$_STRING;
3292     itmlst[0].length = 255;
3293     itmlst[0].buffer_addr = result;
3294     itmlst[0].retlenaddr = &l;
3295
3296     itmlst[1].code = 0;
3297     itmlst[1].length = 0;
3298     itmlst[1].buffer_addr = 0;
3299     itmlst[1].retlenaddr = 0;
3300
3301     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3302     if (iss == SS$_NOLOGNAM) {
3303         iss = SS$_NORMAL;
3304         l = 0;
3305     }
3306     if (!(iss&1)) lib$signal(iss);
3307     result[l] = '\0';
3308 /*
3309     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
3310     strip it off and return the ifi, if any
3311 */
3312     ifi  = 0;
3313     if (result[0] == 0x1b && result[1] == 0x00) {
3314         memmove(&ifi,result+2,2);
3315         strcpy(result,result+4);
3316     }
3317     return ifi;     /* this is the RMS internal file id */
3318 }
3319
3320 static void pipe_infromchild_ast(pPipe p);
3321
3322 /*
3323     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3324     inside an AST routine without worrying about reentrancy and which Perl
3325     memory allocator is being used.
3326
3327     We read data and queue up the buffers, then spit them out one at a
3328     time to the output mailbox when the output mailbox is ready for one.
3329
3330 */
3331 #define INITIAL_TOCHILDQUEUE  2
3332
3333 static pPipe
3334 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3335 {
3336     pPipe p;
3337     pCBuf b;
3338     char mbx1[64], mbx2[64];
3339     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3340                                       DSC$K_CLASS_S, mbx1},
3341                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3342                                       DSC$K_CLASS_S, mbx2};
3343     unsigned int dviitm = DVI$_DEVBUFSIZ;
3344     int j, n;
3345
3346     n = sizeof(Pipe);
3347     _ckvmssts_noperl(lib$get_vm(&n, &p));
3348
3349     create_mbx(&p->chan_in , &d_mbx1);
3350     create_mbx(&p->chan_out, &d_mbx2);
3351     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3352
3353     p->buf           = 0;
3354     p->shut_on_empty = FALSE;
3355     p->need_wake     = FALSE;
3356     p->type          = 0;
3357     p->retry         = 0;
3358     p->iosb.status   = SS$_NORMAL;
3359     p->iosb2.status  = SS$_NORMAL;
3360     p->free          = RQE_ZERO;
3361     p->wait          = RQE_ZERO;
3362     p->curr          = 0;
3363     p->curr2         = 0;
3364     p->info          = 0;
3365 #ifdef PERL_IMPLICIT_CONTEXT
3366     p->thx           = aTHX;
3367 #endif
3368
3369     n = sizeof(CBuf) + p->bufsize;
3370
3371     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3372         _ckvmssts_noperl(lib$get_vm(&n, &b));
3373         b->buf = (char *) b + sizeof(CBuf);
3374         _ckvmssts_noperl(lib$insqhi(b, &p->free));
3375     }
3376
3377     pipe_tochild2_ast(p);
3378     pipe_tochild1_ast(p);
3379     strcpy(wmbx, mbx1);
3380     strcpy(rmbx, mbx2);
3381     return p;
3382 }
3383
3384 /*  reads the MBX Perl is writing, and queues */
3385
3386 static void
3387 pipe_tochild1_ast(pPipe p)
3388 {
3389     pCBuf b = p->curr;
3390     int iss = p->iosb.status;
3391     int eof = (iss == SS$_ENDOFFILE);
3392     int sts;
3393 #ifdef PERL_IMPLICIT_CONTEXT
3394     pTHX = p->thx;
3395 #endif
3396
3397     if (p->retry) {
3398         if (eof) {
3399             p->shut_on_empty = TRUE;
3400             b->eof     = TRUE;
3401             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3402         } else  {
3403             _ckvmssts_noperl(iss);
3404         }
3405
3406         b->eof  = eof;
3407         b->size = p->iosb.count;
3408         _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3409         if (p->need_wake) {
3410             p->need_wake = FALSE;
3411             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3412         }
3413     } else {
3414         p->retry = 1;   /* initial call */
3415     }
3416
3417     if (eof) {                  /* flush the free queue, return when done */
3418         int n = sizeof(CBuf) + p->bufsize;
3419         while (1) {
3420             iss = lib$remqti(&p->free, &b);
3421             if (iss == LIB$_QUEWASEMP) return;
3422             _ckvmssts_noperl(iss);
3423             _ckvmssts_noperl(lib$free_vm(&n, &b));
3424         }
3425     }
3426
3427     iss = lib$remqti(&p->free, &b);
3428     if (iss == LIB$_QUEWASEMP) {
3429         int n = sizeof(CBuf) + p->bufsize;
3430         _ckvmssts_noperl(lib$get_vm(&n, &b));
3431         b->buf = (char *) b + sizeof(CBuf);
3432     } else {
3433        _ckvmssts_noperl(iss);
3434     }
3435
3436     p->curr = b;
3437     iss = sys$qio(0,p->chan_in,
3438              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3439              &p->iosb,
3440              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3441     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3442     _ckvmssts_noperl(iss);
3443 }
3444
3445
3446 /* writes queued buffers to output, waits for each to complete before
3447    doing the next */
3448
3449 static void
3450 pipe_tochild2_ast(pPipe p)
3451 {
3452     pCBuf b = p->curr2;
3453     int iss = p->iosb2.status;
3454     int n = sizeof(CBuf) + p->bufsize;
3455     int done = (p->info && p->info->done) ||
3456               iss == SS$_CANCEL || iss == SS$_ABORT;
3457 #if defined(PERL_IMPLICIT_CONTEXT)
3458     pTHX = p->thx;
3459 #endif
3460
3461     do {
3462         if (p->type) {         /* type=1 has old buffer, dispose */
3463             if (p->shut_on_empty) {
3464                 _ckvmssts_noperl(lib$free_vm(&n, &b));
3465             } else {
3466                 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3467             }
3468             p->type = 0;
3469         }
3470
3471         iss = lib$remqti(&p->wait, &b);
3472         if (iss == LIB$_QUEWASEMP) {
3473             if (p->shut_on_empty) {
3474                 if (done) {
3475                     _ckvmssts_noperl(sys$dassgn(p->chan_out));
3476                     *p->pipe_done = TRUE;
3477                     _ckvmssts_noperl(sys$setef(pipe_ef));
3478                 } else {
3479                     _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3480                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3481                 }
3482                 return;
3483             }
3484             p->need_wake = TRUE;
3485             return;
3486         }
3487         _ckvmssts_noperl(iss);
3488         p->type = 1;
3489     } while (done);
3490
3491
3492     p->curr2 = b;
3493     if (b->eof) {
3494         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3495             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3496     } else {
3497         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3498             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3499     }
3500
3501     return;
3502
3503 }
3504
3505
3506 static pPipe
3507 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3508 {
3509     pPipe p;
3510     char mbx1[64], mbx2[64];
3511     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3512                                       DSC$K_CLASS_S, mbx1},
3513                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3514                                       DSC$K_CLASS_S, mbx2};
3515     unsigned int dviitm = DVI$_DEVBUFSIZ;
3516
3517     int n = sizeof(Pipe);
3518     _ckvmssts_noperl(lib$get_vm(&n, &p));
3519     create_mbx(&p->chan_in , &d_mbx1);
3520     create_mbx(&p->chan_out, &d_mbx2);
3521
3522     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3523     n = p->bufsize * sizeof(char);
3524     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3525     p->shut_on_empty = FALSE;
3526     p->info   = 0;
3527     p->type   = 0;
3528     p->iosb.status = SS$_NORMAL;
3529 #if defined(PERL_IMPLICIT_CONTEXT)
3530     p->thx = aTHX;
3531 #endif
3532     pipe_infromchild_ast(p);
3533
3534     strcpy(wmbx, mbx1);
3535     strcpy(rmbx, mbx2);
3536     return p;
3537 }
3538
3539 static void
3540 pipe_infromchild_ast(pPipe p)
3541 {
3542     int iss = p->iosb.status;
3543     int eof = (iss == SS$_ENDOFFILE);
3544     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3545     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3546 #if defined(PERL_IMPLICIT_CONTEXT)
3547     pTHX = p->thx;
3548 #endif
3549
3550     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3551         _ckvmssts_noperl(sys$dassgn(p->chan_out));
3552         p->chan_out = 0;
3553     }
3554
3555     /* read completed:
3556             input shutdown if EOF from self (done or shut_on_empty)
3557             output shutdown if closing flag set (my_pclose)
3558             send data/eof from child or eof from self
3559             otherwise, re-read (snarf of data from child)
3560     */
3561
3562     if (p->type == 1) {
3563         p->type = 0;
3564         if (myeof && p->chan_in) {                  /* input shutdown */
3565             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3566             p->chan_in = 0;
3567         }
3568
3569         if (p->chan_out) {
3570             if (myeof || kideof) {      /* pass EOF to parent */
3571                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3572                                          pipe_infromchild_ast, p,
3573                                          0, 0, 0, 0, 0, 0));
3574                 return;
3575             } else if (eof) {       /* eat EOF --- fall through to read*/
3576
3577             } else {                /* transmit data */
3578                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3579                                          pipe_infromchild_ast,p,
3580                                          p->buf, p->iosb.count, 0, 0, 0, 0));
3581                 return;
3582             }
3583         }
3584     }
3585
3586     /*  everything shut? flag as done */
3587
3588     if (!p->chan_in && !p->chan_out) {
3589         *p->pipe_done = TRUE;
3590         _ckvmssts_noperl(sys$setef(pipe_ef));
3591         return;
3592     }
3593
3594     /* write completed (or read, if snarfing from child)
3595             if still have input active,
3596                queue read...immediate mode if shut_on_empty so we get EOF if empty
3597             otherwise,
3598                check if Perl reading, generate EOFs as needed
3599     */
3600
3601     if (p->type == 0) {
3602         p->type = 1;
3603         if (p->chan_in) {
3604             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3605                           pipe_infromchild_ast,p,
3606                           p->buf, p->bufsize, 0, 0, 0, 0);
3607             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3608             _ckvmssts_noperl(iss);
3609         } else {           /* send EOFs for extra reads */
3610             p->iosb.status = SS$_ENDOFFILE;
3611             p->iosb.dvispec = 0;
3612             _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3613                                      0, 0, 0,
3614                                      pipe_infromchild_ast, p, 0, 0, 0, 0));
3615         }
3616     }
3617 }
3618
3619 static pPipe
3620 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3621 {
3622     pPipe p;
3623     char mbx[64];
3624     unsigned long dviitm = DVI$_DEVBUFSIZ;
3625     struct stat s;
3626     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3627                                       DSC$K_CLASS_S, mbx};
3628     int n = sizeof(Pipe);
3629
3630     /* things like terminals and mbx's don't need this filter */
3631     if (fd && fstat(fd,&s) == 0) {
3632         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3633         char device[65];
3634         unsigned short dev_len;
3635         struct dsc$descriptor_s d_dev;
3636         char * cptr;
3637         struct item_list_3 items[3];
3638         int status;
3639         unsigned short dvi_iosb[4];
3640
3641         cptr = getname(fd, out, 1);
3642         if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3643         d_dev.dsc$a_pointer = out;
3644         d_dev.dsc$w_length = strlen(out);
3645         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3646         d_dev.dsc$b_class = DSC$K_CLASS_S;
3647
3648         items[0].len = 4;
3649         items[0].code = DVI$_DEVCHAR;
3650         items[0].bufadr = &devchar;
3651         items[0].retadr = NULL;
3652         items[1].len = 64;
3653         items[1].code = DVI$_FULLDEVNAM;
3654         items[1].bufadr = device;
3655         items[1].retadr = &dev_len;
3656         items[2].len = 0;
3657         items[2].code = 0;
3658
3659         status = sys$getdviw
3660                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3661         _ckvmssts_noperl(status);
3662         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3663             device[dev_len] = 0;
3664
3665             if (!(devchar & DEV$M_DIR)) {
3666                 strcpy(out, device);
3667                 return 0;
3668             }
3669         }
3670     }
3671
3672     _ckvmssts_noperl(lib$get_vm(&n, &p));
3673     p->fd_out = dup(fd);
3674     create_mbx(&p->chan_in, &d_mbx);
3675     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3676     n = (p->bufsize+1) * sizeof(char);
3677     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3678     p->shut_on_empty = FALSE;
3679     p->retry = 0;
3680     p->info  = 0;
3681     strcpy(out, mbx);
3682
3683     _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3684                              pipe_mbxtofd_ast, p,
3685                              p->buf, p->bufsize, 0, 0, 0, 0));
3686
3687     return p;
3688 }
3689
3690 static void
3691 pipe_mbxtofd_ast(pPipe p)
3692 {
3693     int iss = p->iosb.status;
3694     int done = p->info->done;
3695     int iss2;
3696     int eof = (iss == SS$_ENDOFFILE);
3697     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3698     int err = !(iss&1) && !eof;
3699 #if defined(PERL_IMPLICIT_CONTEXT)
3700     pTHX = p->thx;
3701 #endif
3702
3703     if (done && myeof) {               /* end piping */
3704         close(p->fd_out);
3705         sys$dassgn(p->chan_in);
3706         *p->pipe_done = TRUE;
3707         _ckvmssts_noperl(sys$setef(pipe_ef));
3708         return;
3709     }
3710
3711     if (!err && !eof) {             /* good data to send to file */
3712         p->buf[p->iosb.count] = '\n';
3713         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3714         if (iss2 < 0) {
3715             p->retry++;
3716             if (p->retry < MAX_RETRY) {
3717                 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3718                 return;
3719             }
3720         }
3721         p->retry = 0;
3722     } else if (err) {
3723         _ckvmssts_noperl(iss);
3724     }
3725
3726
3727     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3728           pipe_mbxtofd_ast, p,
3729           p->buf, p->bufsize, 0, 0, 0, 0);
3730     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3731     _ckvmssts_noperl(iss);
3732 }
3733
3734
3735 typedef struct _pipeloc     PLOC;
3736 typedef struct _pipeloc*   pPLOC;
3737
3738 struct _pipeloc {
3739     pPLOC   next;
3740     char    dir[NAM$C_MAXRSS+1];
3741 };
3742 static pPLOC  head_PLOC = 0;
3743
3744 void
3745 free_pipelocs(pTHX_ void *head)
3746 {
3747     pPLOC p, pnext;
3748     pPLOC *pHead = (pPLOC *)head;
3749
3750     p = *pHead;
3751     while (p) {
3752         pnext = p->next;
3753         PerlMem_free(p);
3754         p = pnext;
3755     }
3756     *pHead = 0;
3757 }
3758
3759 static void
3760 store_pipelocs(pTHX)
3761 {
3762     int    i;
3763     pPLOC  p;
3764     AV    *av = 0;
3765     SV    *dirsv;
3766     GV    *gv;
3767     char  *dir, *x;
3768     char  *unixdir;
3769     char  temp[NAM$C_MAXRSS+1];
3770     STRLEN n_a;
3771
3772     if (head_PLOC)
3773         free_pipelocs(aTHX_ &head_PLOC);
3774
3775 /*  the . directory from @INC comes last */
3776
3777     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3778     if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3779     p->next = head_PLOC;
3780     head_PLOC = p;
3781     strcpy(p->dir,"./");
3782
3783 /*  get the directory from $^X */
3784
3785     unixdir = PerlMem_malloc(VMS_MAXRSS);
3786     if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3787
3788 #ifdef PERL_IMPLICIT_CONTEXT
3789     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3790 #else
3791     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3792 #endif
3793         strcpy(temp, PL_origargv[0]);
3794         x = strrchr(temp,']');
3795         if (x == NULL) {
3796         x = strrchr(temp,'>');
3797           if (x == NULL) {
3798             /* It could be a UNIX path */
3799             x = strrchr(temp,'/');
3800           }
3801         }
3802         if (x)
3803           x[1] = '\0';
3804         else {
3805           /* Got a bare name, so use default directory */
3806           temp[0] = '.';
3807           temp[1] = '\0';
3808         }
3809
3810         if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3811             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3812             if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3813             p->next = head_PLOC;
3814             head_PLOC = p;
3815             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3816             p->dir[NAM$C_MAXRSS] = '\0';
3817         }
3818     }
3819
3820 /*  reverse order of @INC entries, skip "." since entered above */
3821
3822 #ifdef PERL_IMPLICIT_CONTEXT
3823     if (aTHX)
3824 #endif
3825     if (PL_incgv) av = GvAVn(PL_incgv);
3826
3827     for (i = 0; av && i <= AvFILL(av); i++) {
3828         dirsv = *av_fetch(av,i,TRUE);
3829
3830         if (SvROK(dirsv)) continue;
3831         dir = SvPVx(dirsv,n_a);
3832         if (strcmp(dir,".") == 0) continue;
3833         if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3834             continue;
3835
3836         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3837         p->next = head_PLOC;
3838         head_PLOC = p;
3839         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3840         p->dir[NAM$C_MAXRSS] = '\0';
3841     }
3842
3843 /* most likely spot (ARCHLIB) put first in the list */
3844
3845 #ifdef ARCHLIB_EXP
3846     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3847         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3848         if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3849         p->next = head_PLOC;
3850         head_PLOC = p;
3851         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3852         p->dir[NAM$C_MAXRSS] = '\0';
3853     }
3854 #endif
3855     PerlMem_free(unixdir);
3856 }
3857
3858 static I32
3859 Perl_cando_by_name_int
3860    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3861 #if !defined(PERL_IMPLICIT_CONTEXT)
3862 #define cando_by_name_int               Perl_cando_by_name_int
3863 #else
3864 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3865 #endif
3866
3867 static char *
3868 find_vmspipe(pTHX)
3869 {
3870     static int   vmspipe_file_status = 0;
3871     static char  vmspipe_file[NAM$C_MAXRSS+1];
3872
3873     /* already found? Check and use ... need read+execute permission */
3874
3875     if (vmspipe_file_status == 1) {
3876         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3877          && cando_by_name_int
3878            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3879             return vmspipe_file;
3880         }
3881         vmspipe_file_status = 0;
3882     }
3883
3884     /* scan through stored @INC, $^X */
3885
3886     if (vmspipe_file_status == 0) {
3887         char file[NAM$C_MAXRSS+1];
3888         pPLOC  p = head_PLOC;
3889
3890         while (p) {
3891             char * exp_res;
3892             int dirlen;
3893             strcpy(file, p->dir);
3894             dirlen = strlen(file);
3895             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3896             file[NAM$C_MAXRSS] = '\0';
3897             p = p->next;
3898
3899             exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3900             if (!exp_res) continue;
3901
3902             if (cando_by_name_int
3903                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3904              && cando_by_name_int
3905                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3906                 vmspipe_file_status = 1;
3907                 return vmspipe_file;
3908             }
3909         }
3910         vmspipe_file_status = -1;   /* failed, use tempfiles */
3911     }
3912
3913     return 0;
3914 }
3915
3916 static FILE *
3917 vmspipe_tempfile(pTHX)
3918 {
3919     char file[NAM$C_MAXRSS+1];
3920     FILE *fp;
3921     static int index = 0;
3922     Stat_t s0, s1;
3923     int cmp_result;
3924
3925     /* create a tempfile */
3926
3927     /* we can't go from   W, shr=get to  R, shr=get without
3928        an intermediate vulnerable state, so don't bother trying...
3929
3930        and lib$spawn doesn't shr=put, so have to close the write
3931
3932        So... match up the creation date/time and the FID to
3933        make sure we're dealing with the same file
3934
3935     */
3936
3937     index++;
3938     if (!decc_filename_unix_only) {
3939       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3940       fp = fopen(file,"w");
3941       if (!fp) {
3942         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3943         fp = fopen(file,"w");
3944         if (!fp) {
3945             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3946             fp = fopen(file,"w");
3947         }
3948       }
3949      }
3950      else {
3951       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3952       fp = fopen(file,"w");
3953       if (!fp) {
3954         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3955         fp = fopen(file,"w");
3956         if (!fp) {
3957           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3958           fp = fopen(file,"w");
3959         }
3960       }
3961     }
3962     if (!fp) return 0;  /* we're hosed */
3963
3964     fprintf(fp,"$! 'f$verify(0)'\n");
3965     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3966     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3967     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3968     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3969     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3970     fprintf(fp,"$ perl_del    = \"delete\"\n");
3971     fprintf(fp,"$ pif         = \"if\"\n");
3972     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3973     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3974     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3975     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3976     fprintf(fp,"$!  --- build command line to get max possible length\n");
3977     fprintf(fp,"$c=perl_popen_cmd0\n");
3978     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3979     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3980     fprintf(fp,"$x=perl_popen_cmd3\n");
3981     fprintf(fp,"$c=c+x\n");
3982     fprintf(fp,"$ perl_on\n");
3983     fprintf(fp,"$ 'c'\n");
3984     fprintf(fp,"$ perl_status = $STATUS\n");
3985     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3986     fprintf(fp,"$ perl_exit 'perl_status'\n");
3987     fsync(fileno(fp));
3988
3989     fgetname(fp, file, 1);
3990     fstat(fileno(fp), &s0.crtl_stat);
3991     fclose(fp);
3992
3993     if (decc_filename_unix_only)
3994         int_tounixspec(file, file, NULL);
3995     fp = fopen(file,"r","shr=get");
3996     if (!fp) return 0;
3997     fstat(fileno(fp), &s1.crtl_stat);
3998
3999     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
4000     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
4001         fclose(fp);
4002         return 0;
4003     }
4004
4005     return fp;
4006 }
4007
4008
4009 static int vms_is_syscommand_xterm(void)
4010 {
4011     const static struct dsc$descriptor_s syscommand_dsc =
4012       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
4013
4014     const static struct dsc$descriptor_s decwdisplay_dsc =
4015       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
4016
4017     struct item_list_3 items[2];
4018     unsigned short dvi_iosb[4];
4019     unsigned long devchar;
4020     unsigned long devclass;
4021     int status;
4022
4023     /* Very simple check to guess if sys$command is a decterm? */
4024     /* First see if the DECW$DISPLAY: device exists */
4025     items[0].len = 4;
4026     items[0].code = DVI$_DEVCHAR;
4027     items[0].bufadr = &devchar;
4028     items[0].retadr = NULL;
4029     items[1].len = 0;
4030     items[1].code = 0;
4031
4032     status = sys$getdviw
4033         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
4034
4035     if ($VMS_STATUS_SUCCESS(status)) {
4036         status = dvi_iosb[0];
4037     }
4038
4039     if (!$VMS_STATUS_SUCCESS(status)) {
4040         SETERRNO(EVMSERR, status);
4041         return -1;
4042     }
4043
4044     /* If it does, then for now assume that we are on a workstation */
4045     /* Now verify that SYS$COMMAND is a terminal */
4046     /* for creating the debugger DECTerm */
4047
4048     items[0].len = 4;
4049     items[0].code = DVI$_DEVCLASS;
4050     items[0].bufadr = &devclass;
4051     items[0].retadr = NULL;
4052     items[1].len = 0;
4053     items[1].code = 0;
4054
4055     status = sys$getdviw
4056         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
4057
4058     if ($VMS_STATUS_SUCCESS(status)) {
4059         status = dvi_iosb[0];
4060     }
4061
4062     if (!$VMS_STATUS_SUCCESS(status)) {
4063         SETERRNO(EVMSERR, status);
4064         return -1;
4065     }
4066     else {
4067         if (devclass == DC$_TERM) {
4068             return 0;
4069         }
4070     }
4071     return -1;
4072 }
4073
4074 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
4075 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
4076 {
4077     int status;
4078     int ret_stat;
4079     char * ret_char;
4080     char device_name[65];
4081     unsigned short device_name_len;
4082     struct dsc$descriptor_s customization_dsc;
4083     struct dsc$descriptor_s device_name_dsc;
4084     const char * cptr;
4085     char * tptr;
4086     char customization[200];
4087     char title[40];
4088     pInfo info = NULL;
4089     char mbx1[64];
4090     unsigned short p_chan;
4091     int n;
4092     unsigned short iosb[4];
4093     struct item_list_3 items[2];
4094     const char * cust_str =
4095         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
4096     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
4097                                           DSC$K_CLASS_S, mbx1};
4098
4099      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
4100     /*---------------------------------------*/
4101     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
4102
4103
4104     /* Make sure that this is from the Perl debugger */
4105     ret_char = strstr(cmd," xterm ");
4106     if (ret_char == NULL)
4107         return NULL;
4108     cptr = ret_char + 7;
4109     ret_char = strstr(cmd,"tty");
4110     if (ret_char == NULL)
4111         return NULL;
4112     ret_char = strstr(cmd,"sleep");
4113     if (ret_char == NULL)
4114         return NULL;
4115
4116     if (decw_term_port == 0) {
4117         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
4118         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
4119         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
4120
4121        status = lib$find_image_symbol
4122                                (&filename1_dsc,
4123                                 &decw_term_port_dsc,
4124                                 (void *)&decw_term_port,
4125                                 NULL,
4126                                 0);
4127
4128         /* Try again with the other image name */
4129         if (!$VMS_STATUS_SUCCESS(status)) {
4130
4131            status = lib$find_image_symbol
4132                                (&filename2_dsc,
4133                                 &decw_term_port_dsc,
4134                                 (void *)&decw_term_port,
4135                                 NULL,
4136                                 0);
4137
4138         }
4139
4140     }
4141
4142
4143     /* No decw$term_port, give it up */
4144     if (!$VMS_STATUS_SUCCESS(status))
4145         return NULL;
4146
4147     /* Are we on a workstation? */
4148     /* to do: capture the rows / columns and pass their properties */
4149     ret_stat = vms_is_syscommand_xterm();
4150     if (ret_stat < 0)
4151         return NULL;
4152
4153     /* Make the title: */
4154     ret_char = strstr(cptr,"-title");
4155     if (ret_char != NULL) {
4156         while ((*cptr != 0) && (*cptr != '\"')) {
4157             cptr++;
4158         }
4159         if (*cptr == '\"')
4160             cptr++;
4161         n = 0;
4162         while ((*cptr != 0) && (*cptr != '\"')) {
4163             title[n] = *cptr;
4164             n++;
4165             if (n == 39) {
4166                 title[39] == 0;
4167                 break;
4168             }
4169             cptr++;
4170         }
4171         title[n] = 0;
4172     }
4173     else {
4174             /* Default title */
4175             strcpy(title,"Perl Debug DECTerm");
4176     }
4177     sprintf(customization, cust_str, title);
4178
4179     customization_dsc.dsc$a_pointer = customization;
4180     customization_dsc.dsc$w_length = strlen(customization);
4181     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4182     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
4183
4184     device_name_dsc.dsc$a_pointer = device_name;
4185     device_name_dsc.dsc$w_length = sizeof device_name -1;
4186     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4187     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
4188
4189     device_name_len = 0;
4190
4191     /* Try to create the window */
4192      status = (*decw_term_port)
4193        (NULL,
4194         NULL,
4195         &customization_dsc,
4196         &device_name_dsc,
4197         &device_name_len,
4198         NULL,
4199         NULL,
4200         NULL);
4201     if (!$VMS_STATUS_SUCCESS(status)) {
4202         SETERRNO(EVMSERR, status);
4203         return NULL;
4204     }
4205
4206     device_name[device_name_len] = '\0';
4207
4208     /* Need to set this up to look like a pipe for cleanup */
4209     n = sizeof(Info);
4210     status = lib$get_vm(&n, &info);
4211     if (!$VMS_STATUS_SUCCESS(status)) {
4212         SETERRNO(ENOMEM, status);
4213         return NULL;
4214     }
4215
4216     info->mode = *mode;
4217     info->done = FALSE;
4218     info->completion = 0;
4219     info->closing    = FALSE;
4220     info->in         = 0;
4221     info->out        = 0;
4222     info->err        = 0;
4223     info->fp         = NULL;
4224     info->useFILE    = 0;
4225     info->waiting    = 0;
4226     info->in_done    = TRUE;
4227     info->out_done   = TRUE;
4228     info->err_done   = TRUE;
4229
4230     /* Assign a channel on this so that it will persist, and not login */
4231     /* We stash this channel in the info structure for reference. */
4232     /* The created xterm self destructs when the last channel is removed */
4233     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4234     /* So leave this assigned. */
4235     device_name_dsc.dsc$w_length = device_name_len;
4236     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4237     if (!$VMS_STATUS_SUCCESS(status)) {
4238         SETERRNO(EVMSERR, status);
4239         return NULL;
4240     }
4241     info->xchan_valid = 1;
4242
4243     /* Now create a mailbox to be read by the application */
4244
4245     create_mbx(&p_chan, &d_mbx1);
4246
4247     /* write the name of the created terminal to the mailbox */
4248     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4249             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4250
4251     if (!$VMS_STATUS_SUCCESS(status)) {
4252         SETERRNO(EVMSERR, status);
4253         return NULL;
4254     }
4255
4256     info->fp  = PerlIO_open(mbx1, mode);
4257
4258     /* Done with this channel */
4259     sys$dassgn(p_chan);
4260
4261     /* If any errors, then clean up */
4262     if (!info->fp) {
4263         n = sizeof(Info);
4264         _ckvmssts_noperl(lib$free_vm(&n, &info));
4265         return NULL;
4266         }
4267
4268     /* All done */
4269     return info->fp;
4270 }
4271
4272 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4273
4274 static PerlIO *
4275 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4276 {
4277     static int handler_set_up = FALSE;
4278     PerlIO * ret_fp;
4279     unsigned long int sts, flags = CLI$M_NOWAIT;
4280     /* The use of a GLOBAL table (as was done previously) rendered
4281      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4282      * environment.  Hence we've switched to LOCAL symbol table.
4283      */
4284     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4285     int j, wait = 0, n;
4286     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4287     char *in, *out, *err, mbx[512];
4288     FILE *tpipe = 0;
4289     char tfilebuf[NAM$C_MAXRSS+1];
4290     pInfo info = NULL;
4291     char cmd_sym_name[20];
4292     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4293                                       DSC$K_CLASS_S, symbol};
4294     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4295                                       DSC$K_CLASS_S, 0};
4296     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4297                                       DSC$K_CLASS_S, cmd_sym_name};
4298     struct dsc$descriptor_s *vmscmd;
4299     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4300     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4301     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4302
4303     /* Check here for Xterm create request.  This means looking for
4304      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4305      *  is possible to create an xterm.
4306      */
4307     if (*in_mode == 'r') {
4308         PerlIO * xterm_fd;
4309
4310 #if defined(PERL_IMPLICIT_CONTEXT)
4311         /* Can not fork an xterm with a NULL context */
4312         /* This probably could never happen */
4313         xterm_fd = NULL;
4314         if (aTHX != NULL)
4315 #endif
4316         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4317         if (xterm_fd != NULL)
4318             return xterm_fd;
4319     }
4320
4321     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4322
4323     /* once-per-program initialization...
4324        note that the SETAST calls and the dual test of pipe_ef
4325        makes sure that only the FIRST thread through here does
4326        the initialization...all other threads wait until it's
4327        done.
4328
4329        Yeah, uglier than a pthread call, it's got all the stuff inline
4330        rather than in a separate routine.
4331     */
4332
4333     if (!pipe_ef) {
4334         _ckvmssts_noperl(sys$setast(0));
4335         if (!pipe_ef) {
4336             unsigned long int pidcode = JPI$_PID;
4337             $DESCRIPTOR(d_delay, RETRY_DELAY);
4338             _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4339             _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4340             _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4341         }
4342         if (!handler_set_up) {
4343           _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4344           handler_set_up = TRUE;
4345         }
4346         _ckvmssts_noperl(sys$setast(1));
4347     }
4348
4349     /* see if we can find a VMSPIPE.COM */
4350
4351     tfilebuf[0] = '@';
4352     vmspipe = find_vmspipe(aTHX);
4353     if (vmspipe) {
4354         strcpy(tfilebuf+1,vmspipe);
4355     } else {        /* uh, oh...we're in tempfile hell */
4356         tpipe = vmspipe_tempfile(aTHX);
4357         if (!tpipe) {       /* a fish popular in Boston */
4358             if (ckWARN(WARN_PIPE)) {
4359                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4360             }
4361         return NULL;
4362         }
4363         fgetname(tpipe,tfilebuf+1,1);
4364     }
4365     vmspipedsc.dsc$a_pointer = tfilebuf;
4366     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4367
4368     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4369     if (!(sts & 1)) {
4370       switch (sts) {
4371         case RMS$_FNF:  case RMS$_DNF:
4372           set_errno(ENOENT); break;
4373         case RMS$_DIR:
4374           set_errno(ENOTDIR); break;
4375         case RMS$_DEV:
4376           set_errno(ENODEV); break;
4377         case RMS$_PRV:
4378           set_errno(EACCES); break;
4379         case RMS$_SYN:
4380           set_errno(EINVAL); break;
4381         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4382           set_errno(E2BIG); break;
4383         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4384           _ckvmssts_noperl(sts); /* fall through */
4385         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4386           set_errno(EVMSERR);
4387       }
4388       set_vaxc_errno(sts);
4389       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4390         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4391       }
4392       *psts = sts;
4393       return NULL;
4394     }
4395     n = sizeof(Info);
4396     _ckvmssts_noperl(lib$get_vm(&n, &info));
4397
4398     strcpy(mode,in_mode);
4399     info->mode = *mode;
4400     info->done = FALSE;
4401     info->completion = 0;
4402     info->closing    = FALSE;
4403     info->in         = 0;
4404     info->out        = 0;
4405     info->err        = 0;
4406     info->fp         = NULL;
4407     info->useFILE    = 0;
4408     info->waiting    = 0;
4409     info->in_done    = TRUE;
4410     info->out_done   = TRUE;
4411     info->err_done   = TRUE;
4412     info->xchan      = 0;
4413     info->xchan_valid = 0;
4414
4415     in = PerlMem_malloc(VMS_MAXRSS);
4416     if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4417     out = PerlMem_malloc(VMS_MAXRSS);
4418     if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4419     err = PerlMem_malloc(VMS_MAXRSS);
4420     if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4421
4422     in[0] = out[0] = err[0] = '\0';
4423
4424     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4425         info->useFILE = 1;
4426         strcpy(p,p+1);
4427     }
4428     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4429         wait = 1;
4430         strcpy(p,p+1);
4431     }
4432
4433     if (*mode == 'r') {             /* piping from subroutine */
4434
4435         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4436         if (info->out) {
4437             info->out->pipe_done = &info->out_done;
4438             info->out_done = FALSE;
4439             info->out->info = info;
4440         }
4441         if (!info->useFILE) {
4442             info->fp  = PerlIO_open(mbx, mode);
4443         } else {
4444             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4445             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4446         }
4447
4448         if (!info->fp && info->out) {
4449             sys$cancel(info->out->chan_out);
4450
4451             while (!info->out_done) {
4452                 int done;
4453                 _ckvmssts_noperl(sys$setast(0));
4454                 done = info->out_done;
4455                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4456                 _ckvmssts_noperl(sys$setast(1));
4457                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4458             }
4459
4460             if (info->out->buf) {
4461                 n = info->out->bufsize * sizeof(char);
4462                 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4463             }
4464             n = sizeof(Pipe);
4465             _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4466             n = sizeof(Info);
4467             _ckvmssts_noperl(lib$free_vm(&n, &info));
4468             *psts = RMS$_FNF;
4469             return NULL;
4470         }
4471
4472         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4473         if (info->err) {
4474             info->err->pipe_done = &info->err_done;
4475             info->err_done = FALSE;
4476             info->err->info = info;
4477         }
4478
4479     } else if (*mode == 'w') {      /* piping to subroutine */
4480
4481         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4482         if (info->out) {
4483             info->out->pipe_done = &info->out_done;
4484             info->out_done = FALSE;
4485             info->out->info = info;
4486         }
4487
4488         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4489         if (info->err) {
4490             info->err->pipe_done = &info->err_done;
4491             info->err_done = FALSE;
4492             info->err->info = info;
4493         }
4494
4495         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4496         if (!info->useFILE) {
4497             info->fp  = PerlIO_open(mbx, mode);
4498         } else {
4499             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4500             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4501         }
4502
4503         if (info->in) {
4504             info->in->pipe_done = &info->in_done;
4505             info->in_done = FALSE;
4506             info->in->info = info;
4507         }
4508
4509         /* error cleanup */
4510         if (!info->fp && info->in) {
4511             info->done = TRUE;
4512             _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4513                                       0, 0, 0, 0, 0, 0, 0, 0));
4514
4515             while (!info->in_done) {
4516                 int done;
4517                 _ckvmssts_noperl(sys$setast(0));
4518                 done = info->in_done;
4519                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4520                 _ckvmssts_noperl(sys$setast(1));
4521                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4522             }
4523
4524             if (info->in->buf) {
4525                 n = info->in->bufsize * sizeof(char);
4526                 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4527             }
4528             n = sizeof(Pipe);
4529             _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4530             n = sizeof(Info);
4531             _ckvmssts_noperl(lib$free_vm(&n, &info));
4532             *psts = RMS$_FNF;
4533             return NULL;
4534         }
4535
4536
4537     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4538         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4539         if (info->out) {
4540             info->out->pipe_done = &info->out_done;
4541             info->out_done = FALSE;
4542             info->out->info = info;
4543         }
4544
4545         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4546         if (info->err) {
4547             info->err->pipe_done = &info->err_done;
4548             info->err_done = FALSE;
4549             info->err->info = info;
4550         }
4551     }
4552
4553     symbol[MAX_DCL_SYMBOL] = '\0';
4554
4555     strncpy(symbol, in, MAX_DCL_SYMBOL);
4556     d_symbol.dsc$w_length = strlen(symbol);
4557     _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4558
4559     strncpy(symbol, err, MAX_DCL_SYMBOL);
4560     d_symbol.dsc$w_length = strlen(symbol);
4561     _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4562
4563     strncpy(symbol, out, MAX_DCL_SYMBOL);
4564     d_symbol.dsc$w_length = strlen(symbol);
4565     _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4566
4567     /* Done with the names for the pipes */
4568     PerlMem_free(err);
4569     PerlMem_free(out);
4570     PerlMem_free(in);
4571
4572     p = vmscmd->dsc$a_pointer;
4573     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4574     if (*p == '$') p++;                         /* remove leading $ */
4575     while (*p == ' ' || *p == '\t') p++;
4576
4577     for (j = 0; j < 4; j++) {
4578         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4579         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4580
4581     strncpy(symbol, p, MAX_DCL_SYMBOL);
4582     d_symbol.dsc$w_length = strlen(symbol);
4583     _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4584
4585         if (strlen(p) > MAX_DCL_SYMBOL) {
4586             p += MAX_DCL_SYMBOL;
4587         } else {
4588             p += strlen(p);
4589         }
4590     }
4591     _ckvmssts_noperl(sys$setast(0));
4592     info->next=open_pipes;  /* prepend to list */
4593     open_pipes=info;
4594     _ckvmssts_noperl(sys$setast(1));
4595     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4596      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4597      * have SYS$COMMAND if we need it.
4598      */
4599     _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4600                       0, &info->pid, &info->completion,
4601                       0, popen_completion_ast,info,0,0,0));
4602
4603     /* if we were using a tempfile, close it now */
4604
4605     if (tpipe) fclose(tpipe);
4606
4607     /* once the subprocess is spawned, it has copied the symbols and
4608        we can get rid of ours */
4609
4610     for (j = 0; j < 4; j++) {
4611         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4612         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4613     _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4614     }
4615     _ckvmssts_noperl(lib$delete_symbol(&d_sym_in,  &table));
4616     _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4617     _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4618     vms_execfree(vmscmd);
4619
4620 #ifdef PERL_IMPLICIT_CONTEXT
4621     if (aTHX)
4622 #endif
4623     PL_forkprocess = info->pid;
4624
4625     ret_fp = info->fp;
4626     if (wait) {
4627          dSAVEDERRNO;
4628          int done = 0;
4629          while (!done) {
4630              _ckvmssts_noperl(sys$setast(0));
4631              done = info->done;
4632              if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4633              _ckvmssts_noperl(sys$setast(1));
4634              if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4635          }
4636         *psts = info->completion;
4637 /* Caller thinks it is open and tries to close it. */
4638 /* This causes some problems, as it changes the error status */
4639 /*        my_pclose(info->fp); */
4640
4641          /* If we did not have a file pointer open, then we have to */
4642          /* clean up here or eventually we will run out of something */
4643          SAVE_ERRNO;
4644          if (info->fp == NULL) {
4645              my_pclose_pinfo(aTHX_ info);
4646          }
4647          RESTORE_ERRNO;
4648
4649     } else {
4650         *psts = info->pid;
4651     }
4652     return ret_fp;
4653 }  /* end of safe_popen */
4654
4655
4656 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4657 PerlIO *
4658 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4659 {
4660     int sts;
4661     TAINT_ENV();
4662     TAINT_PROPER("popen");
4663     PERL_FLUSHALL_FOR_CHILD;
4664     return safe_popen(aTHX_ cmd,mode,&sts);
4665 }
4666
4667 /*}}}*/
4668
4669
4670 /* Routine to close and cleanup a pipe info structure */
4671
4672 static I32 my_pclose_pinfo(pTHX_ pInfo info) {
4673
4674     unsigned long int retsts;
4675     int done, iss, n;
4676     int status;
4677     pInfo next, last;
4678
4679     /* If we were writing to a subprocess, insure that someone reading from
4680      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4681      * produce an EOF record in the mailbox.
4682      *
4683      *  well, at least sometimes it *does*, so we have to watch out for
4684      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4685      */
4686      if (info->fp) {
4687         if (!info->useFILE
4688 #if defined(USE_ITHREADS)
4689           && my_perl
4690 #endif
4691 #ifdef USE_PERLIO
4692           && PL_perlio_fd_refcnt
4693 #endif
4694            )
4695             PerlIO_flush(info->fp);
4696         else
4697             fflush((FILE *)info->fp);
4698     }
4699
4700     _ckvmssts(sys$setast(0));
4701      info->closing = TRUE;
4702      done = info->done && info->in_done && info->out_done && info->err_done;
4703      /* hanging on write to Perl's input? cancel it */
4704      if (info->mode == 'r' && info->out && !info->out_done) {
4705         if (info->out->chan_out) {
4706             _ckvmssts(sys$cancel(info->out->chan_out));
4707             if (!info->out->chan_in) {   /* EOF generation, need AST */
4708                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4709             }
4710         }
4711      }
4712      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4713          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4714                            0, 0, 0, 0, 0, 0));
4715     _ckvmssts(sys$setast(1));
4716     if (info->fp) {
4717      if (!info->useFILE
4718 #if defined(USE_ITHREADS)
4719          && my_perl
4720 #endif
4721 #ifdef USE_PERLIO
4722          && PL_perlio_fd_refcnt
4723 #endif
4724         )
4725         PerlIO_close(info->fp);
4726      else
4727         fclose((FILE *)info->fp);
4728     }
4729      /*
4730         we have to wait until subprocess completes, but ALSO wait until all
4731         the i/o completes...otherwise we'll be freeing the "info" structure
4732         that the i/o ASTs could still be using...
4733      */
4734
4735      while (!done) {
4736          _ckvmssts(sys$setast(0));
4737          done = info->done && info->in_done && info->out_done && info->err_done;
4738          if (!done) _ckvmssts(sys$clref(pipe_ef));
4739          _ckvmssts(sys$setast(1));
4740          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4741      }
4742      retsts = info->completion;
4743
4744     /* remove from list of open pipes */
4745     _ckvmssts(sys$setast(0));
4746     last = NULL;
4747     for (next = open_pipes; next != NULL; last = next, next = next->next) {
4748         if (next == info)
4749             break;
4750     }
4751
4752     if (last)
4753         last->next = info->next;
4754     else
4755         open_pipes = info->next;
4756     _ckvmssts(sys$setast(1));
4757
4758     /* free buffers and structures */
4759
4760     if (info->in) {
4761         if (info->in->buf) {
4762             n = info->in->bufsize * sizeof(char);
4763             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4764         }
4765         n = sizeof(Pipe);
4766         _ckvmssts(lib$free_vm(&n, &info->in));
4767     }
4768     if (info->out) {
4769         if (info->out->buf) {
4770             n = info->out->bufsize * sizeof(char);
4771             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4772         }
4773         n = sizeof(Pipe);
4774         _ckvmssts(lib$free_vm(&n, &info->out));
4775     }
4776     if (info->err) {
4777         if (info->err->buf) {
4778             n = info->err->bufsize * sizeof(char);
4779             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4780         }
4781         n = sizeof(Pipe);
4782         _ckvmssts(lib$free_vm(&n, &info->err));
4783     }
4784     n = sizeof(Info);
4785     _ckvmssts(lib$free_vm(&n, &info));
4786
4787     return retsts;
4788 }
4789
4790
4791 /*{{{  I32 my_pclose(PerlIO *fp)*/
4792 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4793 {
4794     pInfo info, last = NULL;
4795     I32 ret_status;
4796
4797     /* Fixme - need ast and mutex protection here */
4798     for (info = open_pipes; info != NULL; last = info, info = info->next)
4799         if (info->fp == fp) break;
4800
4801     if (info == NULL) {  /* no such pipe open */
4802       set_errno(ECHILD); /* quoth POSIX */
4803       set_vaxc_errno(SS$_NONEXPR);
4804       return -1;
4805     }
4806
4807     ret_status = my_pclose_pinfo(aTHX_ info);
4808
4809     return ret_status;
4810
4811 }  /* end of my_pclose() */
4812
4813 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4814   /* Roll our own prototype because we want this regardless of whether
4815    * _VMS_WAIT is defined.
4816    */
4817   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4818 #endif
4819 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4820    created with popen(); otherwise partially emulate waitpid() unless
4821    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4822    Also check processes not considered by the CRTL waitpid().
4823  */
4824 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4825 Pid_t
4826 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4827 {
4828     pInfo info;
4829     int done;
4830     int sts;
4831     int j;
4832
4833     if (statusp) *statusp = 0;
4834
4835     for (info = open_pipes; info != NULL; info = info->next)
4836         if (info->pid == pid) break;
4837
4838     if (info != NULL) {  /* we know about this child */
4839       while (!info->done) {
4840           _ckvmssts(sys$setast(0));
4841           done = info->done;
4842           if (!done) _ckvmssts(sys$clref(pipe_ef));
4843           _ckvmssts(sys$setast(1));
4844           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4845       }
4846
4847       if (statusp) *statusp = info->completion;
4848       return pid;
4849     }
4850
4851     /* child that already terminated? */
4852
4853     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4854         if (closed_list[j].pid == pid) {
4855             if (statusp) *statusp = closed_list[j].completion;
4856             return pid;
4857         }
4858     }
4859
4860     /* fall through if this child is not one of our own pipe children */
4861
4862 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4863
4864       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4865        * in 7.2 did we get a version that fills in the VMS completion
4866        * status as Perl has always tried to do.
4867        */
4868
4869       sts = __vms_waitpid( pid, statusp, flags );
4870
4871       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4872          return sts;
4873
4874       /* If the real waitpid tells us the child does not exist, we
4875        * fall through here to implement waiting for a child that
4876        * was created by some means other than exec() (say, spawned
4877        * from DCL) or to wait for a process that is not a subprocess
4878        * of the current process.
4879        */
4880
4881 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4882
4883     {
4884       $DESCRIPTOR(intdsc,"0 00:00:01");
4885       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4886       unsigned long int pidcode = JPI$_PID, mypid;
4887       unsigned long int interval[2];
4888       unsigned int jpi_iosb[2];
4889       struct itmlst_3 jpilist[2] = {
4890           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4891           {                      0,         0,                 0, 0}
4892       };
4893
4894       if (pid <= 0) {
4895         /* Sorry folks, we don't presently implement rooting around for
4896            the first child we can find, and we definitely don't want to
4897            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4898          */
4899         set_errno(ENOTSUP);
4900         return -1;
4901       }
4902
4903       /* Get the owner of the child so I can warn if it's not mine. If the
4904        * process doesn't exist or I don't have the privs to look at it,
4905        * I can go home early.
4906        */
4907       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4908       if (sts & 1) sts = jpi_iosb[0];
4909       if (!(sts & 1)) {
4910         switch (sts) {
4911             case SS$_NONEXPR:
4912                 set_errno(ECHILD);
4913                 break;
4914             case SS$_NOPRIV:
4915                 set_errno(EACCES);
4916                 break;
4917             default:
4918                 _ckvmssts(sts);
4919         }
4920         set_vaxc_errno(sts);
4921         return -1;
4922       }
4923
4924       if (ckWARN(WARN_EXEC)) {
4925         /* remind folks they are asking for non-standard waitpid behavior */
4926         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4927         if (ownerpid != mypid)
4928           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4929                       "waitpid: process %x is not a child of process %x",
4930                       pid,mypid);
4931       }
4932
4933       /* simply check on it once a second until it's not there anymore. */
4934
4935       _ckvmssts(sys$bintim(&intdsc,interval));
4936       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4937             _ckvmssts(sys$schdwk(0,0,interval,0));
4938             _ckvmssts(sys$hiber());
4939       }
4940       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4941
4942       _ckvmssts(sts);
4943       return pid;
4944     }
4945 }  /* end of waitpid() */
4946 /*}}}*/
4947 /*}}}*/
4948 /*}}}*/
4949
4950 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4951 char *
4952 my_gconvert(double val, int ndig, int trail, char *buf)
4953 {
4954   static char __gcvtbuf[DBL_DIG+1];
4955   char *loc;
4956
4957   loc = buf ? buf : __gcvtbuf;
4958
4959 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4960   if (val < 1) {
4961     sprintf(loc,"%.*g",ndig,val);
4962     return loc;
4963   }
4964 #endif
4965
4966   if (val) {
4967     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4968     return gcvt(val,ndig,loc);
4969   }
4970   else {
4971     loc[0] = '0'; loc[1] = '\0';
4972     return loc;
4973   }
4974
4975 }
4976 /*}}}*/
4977
4978 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4979 static int rms_free_search_context(struct FAB * fab)
4980 {
4981 struct NAM * nam;
4982
4983     nam = fab->fab$l_nam;
4984     nam->nam$b_nop |= NAM$M_SYNCHK;
4985     nam->nam$l_rlf = NULL;
4986     fab->fab$b_dns = 0;
4987     return sys$parse(fab, NULL, NULL);
4988 }
4989
4990 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4991 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4992 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4993 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4994 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4995 #define rms_nam_esll(nam) nam.nam$b_esl
4996 #define rms_nam_esl(nam) nam.nam$b_esl
4997 #define rms_nam_name(nam) nam.nam$l_name
4998 #define rms_nam_namel(nam) nam.nam$l_name
4999 #define rms_nam_type(nam) nam.nam$l_type
5000 #define rms_nam_typel(nam) nam.nam$l_type
5001 #define rms_nam_ver(nam) nam.nam$l_ver
5002 #define rms_nam_verl(nam) nam.nam$l_ver
5003 #define rms_nam_rsll(nam) nam.nam$b_rsl
5004 #define rms_nam_rsl(nam) nam.nam$b_rsl
5005 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
5006 #define rms_set_fna(fab, nam, name, size) \
5007         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
5008 #define rms_get_fna(fab, nam) fab.fab$l_fna
5009 #define rms_set_dna(fab, nam, name, size) \
5010         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
5011 #define rms_nam_dns(fab, nam) fab.fab$b_dns
5012 #define rms_set_esa(nam, name, size) \
5013         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
5014 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
5015         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
5016 #define rms_set_rsa(nam, name, size) \
5017         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
5018 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
5019         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
5020 #define rms_nam_name_type_l_size(nam) \
5021         (nam.nam$b_name + nam.nam$b_type)
5022 #else
5023 static int rms_free_search_context(struct FAB * fab)
5024 {
5025 struct NAML * nam;
5026
5027     nam = fab->fab$l_naml;
5028     nam->naml$b_nop |= NAM$M_SYNCHK;
5029     nam->naml$l_rlf = NULL;
5030     nam->naml$l_long_defname_size = 0;
5031
5032     fab->fab$b_dns = 0;
5033     return sys$parse(fab, NULL, NULL);
5034 }
5035
5036 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
5037 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
5038 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
5039 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
5040 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
5041 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
5042 #define rms_nam_esl(nam) nam.naml$b_esl
5043 #define rms_nam_name(nam) nam.naml$l_name
5044 #define rms_nam_namel(nam) nam.naml$l_long_name
5045 #define rms_nam_type(nam) nam.naml$l_type
5046 #define rms_nam_typel(nam) nam.naml$l_long_type
5047 #define rms_nam_ver(nam) nam.naml$l_ver
5048 #define rms_nam_verl(nam) nam.naml$l_long_ver
5049 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
5050 #define rms_nam_rsl(nam) nam.naml$b_rsl
5051 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
5052 #define rms_set_fna(fab, nam, name, size) \
5053         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
5054         nam.naml$l_long_filename_size = size; \
5055         nam.naml$l_long_filename = name;}
5056 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
5057 #define rms_set_dna(fab, nam, name, size) \
5058         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
5059         nam.naml$l_long_defname_size = size; \
5060         nam.naml$l_long_defname = name; }
5061 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
5062 #define rms_set_esa(nam, name, size) \
5063         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
5064         nam.naml$l_long_expand_alloc = size; \
5065         nam.naml$l_long_expand = name; }
5066 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
5067         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
5068         nam.naml$l_long_expand = l_name; \
5069         nam.naml$l_long_expand_alloc = l_size; }
5070 #define rms_set_rsa(nam, name, size) \
5071         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
5072         nam.naml$l_long_result = name; \
5073         nam.naml$l_long_result_alloc = size; }
5074 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
5075         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
5076         nam.naml$l_long_result = l_name; \
5077         nam.naml$l_long_result_alloc = l_size; }
5078 #define rms_nam_name_type_l_size(nam) \
5079         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
5080 #endif
5081
5082
5083 /* rms_erase
5084  * The CRTL for 8.3 and later can create symbolic links in any mode,
5085  * however in 8.3 the unlink/remove/delete routines will only properly handle
5086  * them if one of the PCP modes is active.
5087  */
5088 static int rms_erase(const char * vmsname)
5089 {
5090   int status;
5091   struct FAB myfab = cc$rms_fab;
5092   rms_setup_nam(mynam);
5093
5094   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
5095   rms_bind_fab_nam(myfab, mynam);
5096
5097 #ifdef NAML$M_OPEN_SPECIAL
5098   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5099 #endif
5100
5101   status = sys$erase(&myfab, 0, 0);
5102
5103   return status;
5104 }
5105
5106
5107 static int
5108 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
5109                     const struct dsc$descriptor_s * vms_dst_dsc,
5110                     unsigned long flags)
5111 {
5112     /*  VMS and UNIX handle file permissions differently and the
5113      * the same ACL trick may be needed for renaming files,
5114      * especially if they are directories.
5115      */
5116
5117    /* todo: get kill_file and rename to share common code */
5118    /* I can not find online documentation for $change_acl
5119     * it appears to be replaced by $set_security some time ago */
5120
5121 const unsigned int access_mode = 0;
5122 $DESCRIPTOR(obj_file_dsc,"FILE");
5123 char *vmsname;
5124 char *rslt;
5125 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
5126 int aclsts, fndsts, rnsts = -1;
5127 unsigned int ctx = 0;
5128 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5129 struct dsc$descriptor_s * clean_dsc;
5130
5131 struct myacedef {
5132     unsigned char myace$b_length;
5133     unsigned char myace$b_type;
5134     unsigned short int myace$w_flags;
5135     unsigned long int myace$l_access;
5136     unsigned long int myace$l_ident;
5137 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
5138              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
5139              0},
5140              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
5141
5142 struct item_list_3
5143         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
5144                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
5145                       {0,0,0,0}},
5146         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
5147         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
5148                      {0,0,0,0}};
5149
5150
5151     /* Expand the input spec using RMS, since we do not want to put
5152      * ACLs on the target of a symbolic link */
5153     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
5154     if (vmsname == NULL)
5155         return SS$_INSFMEM;
5156
5157     rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
5158                         vmsname,
5159                         PERL_RMSEXPAND_M_SYMLINK);
5160     if (rslt == NULL) {
5161         PerlMem_free(vmsname);
5162         return SS$_INSFMEM;
5163     }
5164
5165     /* So we get our own UIC to use as a rights identifier,
5166      * and the insert an ACE at the head of the ACL which allows us
5167      * to delete the file.
5168      */
5169     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
5170
5171     fildsc.dsc$w_length = strlen(vmsname);
5172     fildsc.dsc$a_pointer = vmsname;
5173     ctx = 0;
5174     newace.myace$l_ident = oldace.myace$l_ident;
5175     rnsts = SS$_ABORT;
5176
5177     /* Grab any existing ACEs with this identifier in case we fail */
5178     clean_dsc = &fildsc;
5179     aclsts = fndsts = sys$get_security(&obj_file_dsc,
5180                                &fildsc,
5181                                NULL,
5182                                OSS$M_WLOCK,
5183                                findlst,
5184                                &ctx,
5185                                &access_mode);
5186
5187     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
5188         /* Add the new ACE . . . */
5189
5190         /* if the sys$get_security succeeded, then ctx is valid, and the
5191          * object/file descriptors will be ignored.  But otherwise they
5192          * are needed
5193          */
5194         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
5195                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
5196         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5197             set_errno(EVMSERR);
5198             set_vaxc_errno(aclsts);
5199             PerlMem_free(vmsname);
5200             return aclsts;
5201         }
5202
5203         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5204                                 NULL, NULL,
5205                                 &flags,
5206                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5207
5208         if ($VMS_STATUS_SUCCESS(rnsts)) {
5209             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5210         }
5211
5212         /* Put things back the way they were. */
5213         ctx = 0;
5214         aclsts = sys$get_security(&obj_file_dsc,
5215                                   clean_dsc,
5216                                   NULL,
5217                                   OSS$M_WLOCK,
5218                                   findlst,
5219                                   &ctx,
5220                                   &access_mode);
5221
5222         if ($VMS_STATUS_SUCCESS(aclsts)) {
5223         int sec_flags;
5224
5225             sec_flags = 0;
5226             if (!$VMS_STATUS_SUCCESS(fndsts))
5227                 sec_flags = OSS$M_RELCTX;
5228
5229             /* Get rid of the new ACE */
5230             aclsts = sys$set_security(NULL, NULL, NULL,
5231                                   sec_flags, dellst, &ctx, &access_mode);
5232
5233             /* If there was an old ACE, put it back */
5234             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5235                 addlst[0].bufadr = &oldace;
5236                 aclsts = sys$set_security(NULL, NULL, NULL,
5237                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
5238                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5239                     set_errno(EVMSERR);
5240                     set_vaxc_errno(aclsts);
5241                     rnsts = aclsts;
5242                 }
5243             } else {
5244             int aclsts2;
5245
5246                 /* Try to clear the lock on the ACL list */
5247                 aclsts2 = sys$set_security(NULL, NULL, NULL,
5248                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
5249
5250                 /* Rename errors are most important */
5251                 if (!$VMS_STATUS_SUCCESS(rnsts))
5252                     aclsts = rnsts;
5253                 set_errno(EVMSERR);
5254                 set_vaxc_errno(aclsts);
5255                 rnsts = aclsts;
5256             }
5257         }
5258         else {
5259             if (aclsts != SS$_ACLEMPTY)
5260                 rnsts = aclsts;
5261         }
5262     }
5263     else
5264         rnsts = fndsts;
5265
5266     PerlMem_free(vmsname);
5267     return rnsts;
5268 }
5269
5270
5271 /*{{{int rename(const char *, const char * */
5272 /* Not exactly what X/Open says to do, but doing it absolutely right
5273  * and efficiently would require a lot more work.  This should be close
5274  * enough to pass all but the most strict X/Open compliance test.
5275  */
5276 int
5277 Perl_rename(pTHX_ const char *src, const char * dst)
5278 {
5279 int retval;
5280 int pre_delete = 0;
5281 int src_sts;
5282 int dst_sts;
5283 Stat_t src_st;
5284 Stat_t dst_st;
5285
5286     /* Validate the source file */
5287     src_sts = flex_lstat(src, &src_st);
5288     if (src_sts != 0) {
5289
5290         /* No source file or other problem */
5291         return src_sts;
5292     }
5293     if (src_st.st_devnam[0] == 0)  {
5294         /* This may be possible so fail if it is seen. */
5295         errno = EIO;
5296         return -1;
5297     }
5298
5299     dst_sts = flex_lstat(dst, &dst_st);
5300     if (dst_sts == 0) {
5301
5302         if (dst_st.st_dev != src_st.st_dev) {
5303             /* Must be on the same device */
5304             errno = EXDEV;
5305             return -1;
5306         }
5307
5308         /* VMS_INO_T_COMPARE is true if the inodes are different
5309          * to match the output of memcmp
5310          */
5311
5312         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5313             /* That was easy, the files are the same! */
5314             return 0;
5315         }
5316
5317         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5318             /* If source is a directory, so must be dest */
5319                 errno = EISDIR;
5320                 return -1;
5321         }
5322
5323     }
5324
5325
5326     if ((dst_sts == 0) &&
5327         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5328
5329         /* We have issues here if vms_unlink_all_versions is set
5330          * If the destination exists, and is not a directory, then
5331          * we must delete in advance.
5332          *
5333          * If the src is a directory, then we must always pre-delete
5334          * the destination.
5335          *
5336          * If we successfully delete the dst in advance, and the rename fails
5337          * X/Open requires that errno be EIO.
5338          *
5339          */
5340
5341         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5342             int d_sts;
5343             d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam,
5344                                      S_ISDIR(dst_st.st_mode));
5345
5346            /* Need to delete all versions ? */
5347            if ((d_sts == 0) && (vms_unlink_all_versions == 1)) {
5348                 int i = 0;
5349
5350                 while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) {
5351                     d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 0);
5352                     if (d_sts != 0)
5353                         break;
5354                     i++;
5355
5356                     /* Make sure that we do not loop forever */
5357                     if (i > 32767) {
5358                         errno = EIO;
5359                         d_sts = -1;
5360                         break;
5361                     }
5362                 }
5363            }
5364
5365             if (d_sts != 0)
5366                 return d_sts;
5367
5368             /* We killed the destination, so only errno now is EIO */
5369             pre_delete = 1;
5370         }
5371     }
5372
5373     /* Originally the idea was to call the CRTL rename() and only
5374      * try the lib$rename_file if it failed.
5375      * It turns out that there are too many variants in what the
5376      * the CRTL rename might do, so only use lib$rename_file
5377      */
5378     retval = -1;
5379
5380     {
5381         /* Is the source and dest both in VMS format */
5382         /* if the source is a directory, then need to fileify */
5383         /*  and dest must be a directory or non-existant. */
5384
5385         char * vms_dst;
5386         int sts;
5387         char * ret_str;
5388         unsigned long flags;
5389         struct dsc$descriptor_s old_file_dsc;
5390         struct dsc$descriptor_s new_file_dsc;
5391
5392         /* We need to modify the src and dst depending
5393          * on if one or more of them are directories.
5394          */
5395
5396         vms_dst = PerlMem_malloc(VMS_MAXRSS);
5397         if (vms_dst == NULL)
5398             _ckvmssts_noperl(SS$_INSFMEM);
5399
5400         if (S_ISDIR(src_st.st_mode)) {
5401         char * ret_str;
5402         char * vms_dir_file;
5403
5404             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5405             if (vms_dir_file == NULL)
5406                 _ckvmssts_noperl(SS$_INSFMEM);
5407
5408             /* If the dest is a directory, we must remove it
5409             if (dst_sts == 0) {
5410                 int d_sts;
5411                 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1);
5412                 if (d_sts != 0) {
5413                     PerlMem_free(vms_dst);
5414                     errno = EIO;
5415                     return sts;
5416                 }
5417
5418                 pre_delete = 1;
5419             }
5420
5421            /* The dest must be a VMS file specification */
5422            ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5423            if (ret_str == NULL) {
5424                 PerlMem_free(vms_dst);
5425                 errno = EIO;
5426                 return -1;
5427            }
5428
5429             /* The source must be a file specification */
5430             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5431             if (vms_dir_file == NULL)
5432                 _ckvmssts_noperl(SS$_INSFMEM);
5433
5434             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5435             if (ret_str == NULL) {
5436                 PerlMem_free(vms_dst);
5437                 PerlMem_free(vms_dir_file);
5438                 errno = EIO;
5439                 return -1;
5440             }
5441             PerlMem_free(vms_dst);
5442             vms_dst = vms_dir_file;
5443
5444         } else {
5445             /* File to file or file to new dir */
5446
5447             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5448                 /* VMS pathify a dir target */
5449                 ret_str = int_tovmspath(dst, vms_dst, NULL);
5450                 if (ret_str == NULL) {
5451                     PerlMem_free(vms_dst);
5452                     errno = EIO;
5453                     return -1;
5454                 }
5455             } else {
5456                 char * v_spec, * r_spec, * d_spec, * n_spec;
5457                 char * e_spec, * vs_spec;
5458                 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5459
5460                 /* fileify a target VMS file specification */
5461                 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5462                 if (ret_str == NULL) {
5463                     PerlMem_free(vms_dst);
5464                     errno = EIO;
5465                     return -1;
5466                 }
5467
5468                 sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len,
5469                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5470                              &e_len, &vs_spec, &vs_len);
5471                 if (sts == 0) {
5472                      if (e_len == 0) {
5473                          /* Get rid of the version */
5474                          if (vs_len != 0) {
5475                              *vs_spec = '\0';
5476                          }
5477                          /* Need to specify a '.' so that the extension */
5478                          /* is not inherited */
5479                          strcat(vms_dst,".");
5480                      }
5481                 }
5482             }
5483         }
5484
5485         old_file_dsc.dsc$a_pointer = src_st.st_devnam;
5486         old_file_dsc.dsc$w_length = strlen(src_st.st_devnam);
5487         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5488         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5489
5490         new_file_dsc.dsc$a_pointer = vms_dst;
5491         new_file_dsc.dsc$w_length = strlen(vms_dst);
5492         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5493         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5494
5495         flags = 0;
5496 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5497         flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5498 #endif
5499
5500         sts = lib$rename_file(&old_file_dsc,
5501                               &new_file_dsc,
5502                               NULL, NULL,
5503                               &flags,
5504                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5505         if (!$VMS_STATUS_SUCCESS(sts)) {
5506
5507            /* We could have failed because VMS style permissions do not
5508             * permit renames that UNIX will allow.  Just like the hack
5509             * in for kill_file.
5510             */
5511            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5512         }
5513
5514         PerlMem_free(vms_dst);
5515         if (!$VMS_STATUS_SUCCESS(sts)) {
5516             errno = EIO;
5517             return -1;
5518         }
5519         retval = 0;
5520     }
5521
5522     if (vms_unlink_all_versions) {
5523         /* Now get rid of any previous versions of the source file that
5524          * might still exist
5525          */
5526         int i = 0;
5527         dSAVEDERRNO;
5528         SAVE_ERRNO;
5529         src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5530                                    S_ISDIR(src_st.st_mode));
5531         while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) {
5532              src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5533                                        S_ISDIR(src_st.st_mode));
5534              if (src_sts != 0)
5535                  break;
5536              i++;
5537
5538              /* Make sure that we do not loop forever */
5539              if (i > 32767) {
5540                  src_sts = -1;
5541                  break;
5542              }
5543         }
5544         RESTORE_ERRNO;
5545     }
5546
5547     /* We deleted the destination, so must force the error to be EIO */
5548     if ((retval != 0) && (pre_delete != 0))
5549         errno = EIO;
5550
5551     return retval;
5552 }
5553 /*}}}*/
5554
5555
5556 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5557 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5558  * to expand file specification.  Allows for a single default file
5559  * specification and a simple mask of options.  If outbuf is non-NULL,
5560  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5561  * the resultant file specification is placed.  If outbuf is NULL, the
5562  * resultant file specification is placed into a static buffer.
5563  * The third argument, if non-NULL, is taken to be a default file
5564  * specification string.  The fourth argument is unused at present.
5565  * rmesexpand() returns the address of the resultant string if
5566  * successful, and NULL on error.
5567  *
5568  * New functionality for previously unused opts value:
5569  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5570  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5571  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5572  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5573  */
5574 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5575
5576 static char *
5577 int_rmsexpand
5578    (const char *filespec,
5579     char *outbuf,
5580     const char *defspec,
5581     unsigned opts,
5582     int * fs_utf8,
5583     int * dfs_utf8)
5584 {
5585   char * ret_spec;
5586   const char * in_spec;
5587   char * spec_buf;
5588   const char * def_spec;
5589   char * vmsfspec, *vmsdefspec;
5590   char * esa;
5591   char * esal = NULL;
5592   char * outbufl;
5593   struct FAB myfab = cc$rms_fab;
5594   rms_setup_nam(mynam);
5595   STRLEN speclen;
5596   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5597   int sts;
5598
5599   /* temp hack until UTF8 is actually implemented */
5600   if (fs_utf8 != NULL)
5601     *fs_utf8 = 0;
5602
5603   if (!filespec || !*filespec) {
5604     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5605     return NULL;
5606   }
5607
5608   vmsfspec = NULL;
5609   vmsdefspec = NULL;
5610   outbufl = NULL;
5611
5612   in_spec = filespec;
5613   isunix = 0;
5614   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5615       char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5616       int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5617
5618       /* If this is a UNIX file spec, convert it to VMS */
5619       sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5620                            &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5621                            &e_len, &vs_spec, &vs_len);
5622       if (sts != 0) {
5623           isunix = 1;
5624           char * ret_spec;
5625
5626           vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5627           if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5628           ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5629           if (ret_spec == NULL) {
5630               PerlMem_free(vmsfspec);
5631               return NULL;
5632           }
5633           in_spec = (const char *)vmsfspec;
5634
5635           /* Unless we are forcing to VMS format, a UNIX input means
5636            * UNIX output, and that requires long names to be used
5637            */
5638           if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5639 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5640               opts |= PERL_RMSEXPAND_M_LONG;
5641 #else
5642               NOOP;
5643 #endif
5644           else
5645               isunix = 0;
5646       }
5647
5648   }
5649
5650   rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
5651   rms_bind_fab_nam(myfab, mynam);
5652
5653   /* Process the default file specification if present */
5654   def_spec = defspec;
5655   if (defspec && *defspec) {
5656     int t_isunix;
5657     t_isunix = is_unix_filespec(defspec);
5658     if (t_isunix) {
5659       vmsdefspec = PerlMem_malloc(VMS_MAXRSS);
5660       if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5661       ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5662
5663       if (ret_spec == NULL) {
5664           /* Clean up and bail */
5665           PerlMem_free(vmsdefspec);
5666           if (vmsfspec != NULL)
5667               PerlMem_free(vmsfspec);
5668               return NULL;
5669           }
5670           def_spec = (const char *)vmsdefspec;
5671       }
5672       rms_set_dna(myfab, mynam,
5673                   (char *)def_spec, strlen(def_spec)); /* cast ok */
5674   }
5675
5676   /* Now we need the expansion buffers */
5677   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5678   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5679 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5680   esal = PerlMem_malloc(VMS_MAXRSS);
5681   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5682 #endif
5683   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5684
5685   /* If a NAML block is used RMS always writes to the long and short
5686    * addresses unless you suppress the short name.
5687    */
5688 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5689   outbufl = PerlMem_malloc(VMS_MAXRSS);
5690   if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5691 #endif
5692    rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5693
5694 #ifdef NAM$M_NO_SHORT_UPCASE
5695   if (decc_efs_case_preserve)
5696     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5697 #endif
5698
5699    /* We may not want to follow symbolic links */
5700 #ifdef NAML$M_OPEN_SPECIAL
5701   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5702     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5703 #endif
5704
5705   /* First attempt to parse as an existing file */
5706   retsts = sys$parse(&myfab,0,0);
5707   if (!(retsts & STS$K_SUCCESS)) {
5708
5709     /* Could not find the file, try as syntax only if error is not fatal */
5710     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5711     if (retsts == RMS$_DNF ||
5712         retsts == RMS$_DIR ||
5713         retsts == RMS$_DEV ||
5714         retsts == RMS$_PRV) {
5715       retsts = sys$parse(&myfab,0,0);
5716       if (retsts & STS$K_SUCCESS) goto int_expanded;
5717     }
5718
5719      /* Still could not parse the file specification */
5720     /*----------------------------------------------*/
5721     sts = rms_free_search_context(&myfab); /* Free search context */
5722     if (vmsdefspec != NULL)
5723         PerlMem_free(vmsdefspec);
5724     if (vmsfspec != NULL)
5725         PerlMem_free(vmsfspec);
5726     if (outbufl != NULL)
5727         PerlMem_free(outbufl);
5728     PerlMem_free(esa);
5729     if (esal != NULL)
5730         PerlMem_free(esal);
5731     set_vaxc_errno(retsts);
5732     if      (retsts == RMS$_PRV) set_errno(EACCES);
5733     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5734     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5735     else                         set_errno(EVMSERR);
5736     return NULL;
5737   }
5738   retsts = sys$search(&myfab,0,0);
5739   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5740     sts = rms_free_search_context(&myfab); /* Free search context */
5741     if (vmsdefspec != NULL)
5742         PerlMem_free(vmsdefspec);
5743     if (vmsfspec != NULL)
5744         PerlMem_free(vmsfspec);
5745     if (outbufl != NULL)
5746         PerlMem_free(outbufl);
5747     PerlMem_free(esa);
5748     if (esal != NULL)
5749         PerlMem_free(esal);
5750     set_vaxc_errno(retsts);
5751     if      (retsts == RMS$_PRV) set_errno(EACCES);
5752     else                         set_errno(EVMSERR);
5753     return NULL;
5754   }
5755
5756   /* If the input filespec contained any lowercase characters,
5757    * downcase the result for compatibility with Unix-minded code. */
5758 int_expanded:
5759   if (!decc_efs_case_preserve) {
5760     char * tbuf;
5761     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5762       if (islower(*tbuf)) { haslower = 1; break; }
5763   }
5764
5765    /* Is a long or a short name expected */
5766   /*------------------------------------*/
5767   spec_buf = NULL;
5768 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5769   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5770     if (rms_nam_rsll(mynam)) {
5771         spec_buf = outbufl;
5772         speclen = rms_nam_rsll(mynam);
5773     }
5774     else {
5775         spec_buf = esal; /* Not esa */
5776         speclen = rms_nam_esll(mynam);
5777     }
5778   }
5779   else {
5780 #endif
5781     if (rms_nam_rsl(mynam)) {
5782         spec_buf = outbuf;
5783         speclen = rms_nam_rsl(mynam);
5784     }
5785     else {
5786         spec_buf = esa; /* Not esal */
5787         speclen = rms_nam_esl(mynam);
5788     }
5789 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5790   }
5791 #endif
5792   spec_buf[speclen] = '\0';
5793
5794   /* Trim off null fields added by $PARSE
5795    * If type > 1 char, must have been specified in original or default spec
5796    * (not true for version; $SEARCH may have added version of existing file).
5797    */
5798   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5799   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5800     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5801              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5802   }
5803   else {
5804     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5805              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5806   }
5807   if (trimver || trimtype) {
5808     if (defspec && *defspec) {
5809       char *defesal = NULL;
5810       char *defesa = NULL;
5811       defesa = PerlMem_malloc(VMS_MAXRSS + 1);
5812       if (defesa != NULL) {
5813         struct FAB deffab = cc$rms_fab;
5814 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5815         defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5816         if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5817 #endif
5818         rms_setup_nam(defnam);
5819
5820         rms_bind_fab_nam(deffab, defnam);
5821
5822         /* Cast ok */
5823         rms_set_fna
5824             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5825
5826         /* RMS needs the esa/esal as a work area if wildcards are involved */
5827         rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5828
5829         rms_clear_nam_nop(defnam);
5830         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5831 #ifdef NAM$M_NO_SHORT_UPCASE
5832         if (decc_efs_case_preserve)
5833           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5834 #endif
5835 #ifdef NAML$M_OPEN_SPECIAL
5836         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5837           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5838 #endif
5839         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5840           if (trimver) {
5841              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5842           }
5843           if (trimtype) {
5844             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5845           }
5846         }
5847         if (defesal != NULL)
5848             PerlMem_free(defesal);
5849         PerlMem_free(defesa);
5850       } else {
5851           _ckvmssts_noperl(SS$_INSFMEM);
5852       }
5853     }
5854     if (trimver) {
5855       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5856         if (*(rms_nam_verl(mynam)) != '\"')
5857           speclen = rms_nam_verl(mynam) - spec_buf;
5858       }
5859       else {
5860         if (*(rms_nam_ver(mynam)) != '\"')
5861           speclen = rms_nam_ver(mynam) - spec_buf;
5862       }
5863     }
5864     if (trimtype) {
5865       /* If we didn't already trim version, copy down */
5866       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5867         if (speclen > rms_nam_verl(mynam) - spec_buf)
5868           memmove
5869            (rms_nam_typel(mynam),
5870             rms_nam_verl(mynam),
5871             speclen - (rms_nam_verl(mynam) - spec_buf));
5872           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5873       }
5874       else {
5875         if (speclen > rms_nam_ver(mynam) - spec_buf)
5876           memmove
5877            (rms_nam_type(mynam),
5878             rms_nam_ver(mynam),
5879             speclen - (rms_nam_ver(mynam) - spec_buf));
5880           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5881       }
5882     }
5883   }
5884
5885    /* Done with these copies of the input files */
5886   /*-------------------------------------------*/
5887   if (vmsfspec != NULL)
5888         PerlMem_free(vmsfspec);
5889   if (vmsdefspec != NULL)
5890         PerlMem_free(vmsdefspec);
5891
5892   /* If we just had a directory spec on input, $PARSE "helpfully"
5893    * adds an empty name and type for us */
5894 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5895   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5896     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5897         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5898         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5899       speclen = rms_nam_namel(mynam) - spec_buf;
5900   }
5901   else
5902 #endif
5903   {
5904     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5905         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5906         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5907       speclen = rms_nam_name(mynam) - spec_buf;
5908   }
5909
5910   /* Posix format specifications must have matching quotes */
5911   if (speclen < (VMS_MAXRSS - 1)) {
5912     if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5913       if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5914         spec_buf[speclen] = '\"';
5915         speclen++;
5916       }
5917     }
5918   }
5919   spec_buf[speclen] = '\0';
5920   if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
5921
5922   /* Have we been working with an expanded, but not resultant, spec? */
5923   /* Also, convert back to Unix syntax if necessary. */
5924   {
5925   int rsl;
5926
5927 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5928     if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5929       rsl = rms_nam_rsll(mynam);
5930     } else
5931 #endif
5932     {
5933       rsl = rms_nam_rsl(mynam);
5934     }
5935     if (!rsl) {
5936       /* rsl is not present, it means that spec_buf is either */
5937       /* esa or esal, and needs to be copied to outbuf */
5938       /* convert to Unix if desired */
5939       if (isunix) {
5940         ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5941       } else {
5942         /* VMS file specs are not in UTF-8 */
5943         if (fs_utf8 != NULL)
5944             *fs_utf8 = 0;
5945         strcpy(outbuf, spec_buf);
5946         ret_spec = outbuf;
5947       }
5948     }
5949     else {
5950       /* Now spec_buf is either outbuf or outbufl */
5951       /* We need the result into outbuf */
5952       if (isunix) {
5953            /* If we need this in UNIX, then we need another buffer */
5954            /* to keep things in order */
5955            char * src;
5956            char * new_src = NULL;
5957            if (spec_buf == outbuf) {
5958                new_src = PerlMem_malloc(VMS_MAXRSS);
5959                strcpy(new_src, spec_buf);
5960            } else {
5961                src = spec_buf;
5962            }
5963            ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5964            if (new_src) {
5965                PerlMem_free(new_src);
5966            }
5967       } else {
5968            /* VMS file specs are not in UTF-8 */
5969            if (fs_utf8 != NULL)
5970                *fs_utf8 = 0;
5971
5972            /* Copy the buffer if needed */
5973            if (outbuf != spec_buf)
5974                strcpy(outbuf, spec_buf);
5975            ret_spec = outbuf;
5976       }
5977     }
5978   }
5979
5980   /* Need to clean up the search context */
5981   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5982   sts = rms_free_search_context(&myfab); /* Free search context */
5983
5984   /* Clean up the extra buffers */
5985   if (esal != NULL)
5986       PerlMem_free(esal);
5987   PerlMem_free(esa);
5988   if (outbufl != NULL)
5989      PerlMem_free(outbufl);
5990
5991   /* Return the result */
5992   return ret_spec;
5993 }
5994
5995 /* Common simple case - Expand an already VMS spec */
5996 static char *
5997 int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5998     opts |= PERL_RMSEXPAND_M_VMS_IN;
5999     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
6000 }
6001
6002 /* Common simple case - Expand to a VMS spec */
6003 static char *
6004 int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
6005     opts |= PERL_RMSEXPAND_M_VMS;
6006     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
6007 }
6008
6009
6010 /* Entry point used by perl routines */
6011 static char *
6012 mp_do_rmsexpand
6013    (pTHX_ const char *filespec,
6014     char *outbuf,
6015     int ts,
6016     const char *defspec,
6017     unsigned opts,
6018     int * fs_utf8,
6019     int * dfs_utf8)
6020 {
6021     static char __rmsexpand_retbuf[VMS_MAXRSS];
6022     char * expanded, *ret_spec, *ret_buf;
6023
6024     expanded = NULL;
6025     ret_buf = outbuf;
6026     if (ret_buf == NULL) {
6027         if (ts) {
6028             Newx(expanded, VMS_MAXRSS, char);
6029             if (expanded == NULL)
6030                 _ckvmssts(SS$_INSFMEM);
6031             ret_buf = expanded;
6032         } else {
6033             ret_buf = __rmsexpand_retbuf;
6034         }
6035     }
6036
6037
6038     ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
6039                              opts, fs_utf8,  dfs_utf8);
6040
6041     if (ret_spec == NULL) {
6042        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6043        if (expanded)
6044            Safefree(expanded);
6045     }
6046
6047     return ret_spec;
6048 }
6049 /*}}}*/
6050 /* External entry points */
6051 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
6052 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
6053 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
6054 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
6055 char *Perl_rmsexpand_utf8
6056   (pTHX_ const char *spec, char *buf, const char *def,
6057    unsigned opt, int * fs_utf8, int * dfs_utf8)
6058 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
6059 char *Perl_rmsexpand_utf8_ts
6060   (pTHX_ const char *spec, char *buf, const char *def,
6061    unsigned opt, int * fs_utf8, int * dfs_utf8)
6062 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
6063
6064
6065 /*
6066 ** The following routines are provided to make life easier when
6067 ** converting among VMS-style and Unix-style directory specifications.
6068 ** All will take input specifications in either VMS or Unix syntax. On
6069 ** failure, all return NULL.  If successful, the routines listed below
6070 ** return a pointer to a buffer containing the appropriately
6071 ** reformatted spec (and, therefore, subsequent calls to that routine
6072 ** will clobber the result), while the routines of the same names with
6073 ** a _ts suffix appended will return a pointer to a mallocd string
6074 ** containing the appropriately reformatted spec.
6075 ** In all cases, only explicit syntax is altered; no check is made that
6076 ** the resulting string is valid or that the directory in question
6077 ** actually exists.
6078 **
6079 **   fileify_dirspec() - convert a directory spec into the name of the
6080 **     directory file (i.e. what you can stat() to see if it's a dir).
6081 **     The style (VMS or Unix) of the result is the same as the style
6082 **     of the parameter passed in.
6083 **   pathify_dirspec() - convert a directory spec into a path (i.e.
6084 **     what you prepend to a filename to indicate what directory it's in).
6085 **     The style (VMS or Unix) of the result is the same as the style
6086 **     of the parameter passed in.
6087 **   tounixpath() - convert a directory spec into a Unix-style path.
6088 **   tovmspath() - convert a directory spec into a VMS-style path.
6089 **   tounixspec() - convert any file spec into a Unix-style file spec.
6090 **   tovmsspec() - convert any file spec into a VMS-style spec.
6091 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
6092 **
6093 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
6094 ** Permission is given to distribute this code as part of the Perl
6095 ** standard distribution under the terms of the GNU General Public
6096 ** License or the Perl Artistic License.  Copies of each may be
6097 ** found in the Perl standard distribution.
6098  */
6099
6100 /*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6101 static char *
6102 int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
6103 {
6104     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
6105     char *cp1, *cp2, *lastdir;
6106     char *trndir, *vmsdir;
6107     unsigned short int trnlnm_iter_count;
6108     int is_vms = 0;
6109     int is_unix = 0;
6110     int sts;
6111     if (utf8_fl != NULL)
6112         *utf8_fl = 0;
6113
6114     if (!dir || !*dir) {
6115       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6116     }
6117     dirlen = strlen(dir);
6118     while (dirlen && dir[dirlen-1] == '/') --dirlen;
6119     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
6120       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
6121         dir = "/sys$disk";
6122         dirlen = 9;
6123       }
6124       else
6125         dirlen = 1;
6126     }
6127     if (dirlen > (VMS_MAXRSS - 1)) {
6128       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
6129       return NULL;
6130     }
6131     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
6132     if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6133     if (!strpbrk(dir+1,"/]>:")  &&
6134         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
6135       strcpy(trndir,*dir == '/' ? dir + 1: dir);
6136       trnlnm_iter_count = 0;
6137       while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
6138         trnlnm_iter_count++;
6139         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6140       }
6141       dirlen = strlen(trndir);
6142     }
6143     else {
6144       strncpy(trndir,dir,dirlen);
6145       trndir[dirlen] = '\0';
6146     }
6147
6148     /* At this point we are done with *dir and use *trndir which is a
6149      * copy that can be modified.  *dir must not be modified.
6150      */
6151
6152     /* If we were handed a rooted logical name or spec, treat it like a
6153      * simple directory, so that
6154      *    $ Define myroot dev:[dir.]
6155      *    ... do_fileify_dirspec("myroot",buf,1) ...
6156      * does something useful.
6157      */
6158     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
6159       trndir[--dirlen] = '\0';
6160       trndir[dirlen-1] = ']';
6161     }
6162     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
6163       trndir[--dirlen] = '\0';
6164       trndir[dirlen-1] = '>';
6165     }
6166
6167     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
6168       /* If we've got an explicit filename, we can just shuffle the string. */
6169       if (*(cp1+1)) hasfilename = 1;
6170       /* Similarly, we can just back up a level if we've got multiple levels
6171          of explicit directories in a VMS spec which ends with directories. */
6172       else {
6173         for (cp2 = cp1; cp2 > trndir; cp2--) {
6174           if (*cp2 == '.') {
6175             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
6176 /* fix-me, can not scan EFS file specs backward like this */
6177               *cp2 = *cp1; *cp1 = '\0';
6178               hasfilename = 1;
6179               break;
6180             }
6181           }
6182           if (*cp2 == '[' || *cp2 == '<') break;
6183         }
6184       }
6185     }
6186
6187     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
6188     if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6189     cp1 = strpbrk(trndir,"]:>");
6190     if (hasfilename || !cp1) { /* filename present or not VMS */
6191
6192       if (decc_efs_charset && !cp1) {
6193
6194           /* EFS handling for UNIX mode */
6195
6196           /* Just remove the trailing '/' and we should be done */
6197           STRLEN trndir_len;
6198           trndir_len = strlen(trndir);
6199
6200           if (trndir_len > 1) {
6201               trndir_len--;
6202               if (trndir[trndir_len] == '/') {
6203                   trndir[trndir_len] = '\0';
6204               }
6205           }
6206           strcpy(buf, trndir);
6207           PerlMem_free(trndir);
6208           PerlMem_free(vmsdir);
6209           return buf;
6210       }
6211
6212       /* For non-EFS mode, this is left for backwards compatibility */
6213       /* For EFS mode, this is only done for VMS format filespecs as */
6214       /* Perl programs generally have problems when a UNIX format spec */
6215       /* returns a VMS format spec */
6216       if (trndir[0] == '.') {
6217         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
6218           PerlMem_free(trndir);
6219           PerlMem_free(vmsdir);
6220           return int_fileify_dirspec("[]", buf, NULL);
6221         }
6222         else if (trndir[1] == '.' &&
6223                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
6224           PerlMem_free(trndir);
6225           PerlMem_free(vmsdir);
6226           return int_fileify_dirspec("[-]", buf, NULL);
6227         }
6228       }
6229       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
6230         dirlen -= 1;                 /* to last element */
6231         lastdir = strrchr(trndir,'/');
6232       }
6233       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
6234         /* If we have "/." or "/..", VMSify it and let the VMS code
6235          * below expand it, rather than repeating the code to handle
6236          * relative components of a filespec here */
6237         do {
6238           if (*(cp1+2) == '.') cp1++;
6239           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
6240             char * ret_chr;
6241             if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
6242                 PerlMem_free(trndir);
6243                 PerlMem_free(vmsdir);
6244                 return NULL;
6245             }
6246             if (strchr(vmsdir,'/') != NULL) {
6247               /* If int_tovmsspec() returned it, it must have VMS syntax
6248                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
6249                * the time to check this here only so we avoid a recursion
6250                * loop; otherwise, gigo.
6251                */
6252               PerlMem_free(trndir);
6253               PerlMem_free(vmsdir);
6254               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
6255               return NULL;
6256             }
6257             if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6258                 PerlMem_free(trndir);
6259                 PerlMem_free(vmsdir);
6260                 return NULL;
6261             }
6262             ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6263             PerlMem_free(trndir);
6264             PerlMem_free(vmsdir);
6265             return ret_chr;
6266           }
6267           cp1++;
6268         } while ((cp1 = strstr(cp1,"/.")) != NULL);
6269         lastdir = strrchr(trndir,'/');
6270       }
6271       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
6272         char * ret_chr;
6273         /* Ditto for specs that end in an MFD -- let the VMS code
6274          * figure out whether it's a real device or a rooted logical. */
6275
6276         /* This should not happen any more.  Allowing the fake /000000
6277          * in a UNIX pathname causes all sorts of problems when trying
6278          * to run in UNIX emulation.  So the VMS to UNIX conversions
6279          * now remove the fake /000000 directories.
6280          */
6281
6282         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6283         if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6284             PerlMem_free(trndir);
6285             PerlMem_free(vmsdir);
6286             return NULL;
6287         }
6288         if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6289             PerlMem_free(trndir);
6290             PerlMem_free(vmsdir);
6291             return NULL;
6292         }
6293         ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6294         PerlMem_free(trndir);
6295         PerlMem_free(vmsdir);
6296         return ret_chr;
6297       }
6298       else {
6299
6300         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6301              !(lastdir = cp1 = strrchr(trndir,']')) &&
6302              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6303
6304         cp2 = strrchr(cp1,'.');
6305         if (cp2) {
6306             int e_len, vs_len = 0;
6307             int is_dir = 0;
6308             char * cp3;
6309             cp3 = strchr(cp2,';');
6310             e_len = strlen(cp2);
6311             if (cp3) {
6312                 vs_len = strlen(cp3);
6313                 e_len = e_len - vs_len;
6314             }
6315             is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6316             if (!is_dir) {
6317                 if (!decc_efs_charset) {
6318                     /* If this is not EFS, then not a directory */
6319                     PerlMem_free(trndir);
6320                     PerlMem_free(vmsdir);
6321                     set_errno(ENOTDIR);
6322                     set_vaxc_errno(RMS$_DIR);
6323                     return NULL;
6324                 }
6325             } else {
6326                 /* Ok, here we have an issue, technically if a .dir shows */
6327                 /* from inside a directory, then we should treat it as */
6328                 /* xxx^.dir.dir.  But we do not have that context at this */
6329                 /* point unless this is totally restructured, so we remove */
6330                 /* The .dir for now, and fix this better later */
6331                 dirlen = cp2 - trndir;
6332             }
6333         }
6334
6335       }
6336
6337       retlen = dirlen + 6;
6338       memcpy(buf, trndir, dirlen);
6339       buf[dirlen] = '\0';
6340
6341       /* We've picked up everything up to the directory file name.
6342          Now just add the type and version, and we're set. */
6343
6344       /* We should only add type for VMS syntax, but historically Perl
6345          has added it for UNIX style also */
6346
6347       /* Fix me - we should not be using the same routine for VMS and
6348          UNIX format files.  Things are too tangled so we need to lookup
6349          what syntax the output is */
6350
6351       is_unix = 0;
6352       is_vms = 0;
6353       lastdir = strrchr(trndir,'/');
6354       if (lastdir) {
6355           is_unix = 1;
6356       } else {
6357           lastdir = strpbrk(trndir,"]:>");
6358           if (lastdir) {
6359               is_vms = 1;
6360           }
6361       }
6362
6363       if ((is_vms == 0) && (is_unix == 0)) {
6364           /* We still do not  know? */
6365           is_unix = decc_filename_unix_report;
6366           if (is_unix == 0)
6367               is_vms = 1;
6368       }
6369
6370       if ((is_unix && !decc_efs_charset) || is_vms) {
6371
6372            /* It is a bug to add a .dir to a UNIX format directory spec */
6373            /* However Perl on VMS may have programs that expect this so */
6374            /* If not using EFS character specifications allow it. */
6375
6376            if ((!decc_efs_case_preserve) && vms_process_case_tolerant) {
6377                /* Traditionally Perl expects filenames in lower case */
6378                strcat(buf, ".dir");
6379            } else {
6380                /* VMS expects the .DIR to be in upper case */
6381                strcat(buf, ".DIR");
6382            }
6383
6384            /* It is also a bug to put a VMS format version on a UNIX file */
6385            /* specification.  Perl self tests are looking for this */
6386            if (is_vms || !(decc_efs_charset || decc_filename_unix_report))
6387                strcat(buf, ";1");
6388       }
6389       PerlMem_free(trndir);
6390       PerlMem_free(vmsdir);
6391       return buf;
6392     }
6393     else {  /* VMS-style directory spec */
6394
6395       char *esa, *esal, term, *cp;
6396       char *my_esa;
6397       int my_esa_len;
6398       unsigned long int sts, cmplen, haslower = 0;
6399       unsigned int nam_fnb;
6400       char * nam_type;
6401       struct FAB dirfab = cc$rms_fab;
6402       rms_setup_nam(savnam);
6403       rms_setup_nam(dirnam);
6404
6405       esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6406       if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6407       esal = NULL;
6408 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6409       esal = PerlMem_malloc(VMS_MAXRSS);
6410       if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6411 #endif
6412       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6413       rms_bind_fab_nam(dirfab, dirnam);
6414       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6415       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6416 #ifdef NAM$M_NO_SHORT_UPCASE
6417       if (decc_efs_case_preserve)
6418         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6419 #endif
6420
6421       for (cp = trndir; *cp; cp++)
6422         if (islower(*cp)) { haslower = 1; break; }
6423       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6424         if ((dirfab.fab$l_sts == RMS$_DIR) ||
6425             (dirfab.fab$l_sts == RMS$_DNF) ||
6426             (dirfab.fab$l_sts == RMS$_PRV)) {
6427             rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6428             sts = sys$parse(&dirfab);
6429         }
6430         if (!sts) {
6431           PerlMem_free(esa);
6432           if (esal != NULL)
6433               PerlMem_free(esal);
6434           PerlMem_free(trndir);
6435           PerlMem_free(vmsdir);
6436           set_errno(EVMSERR);
6437           set_vaxc_errno(dirfab.fab$l_sts);
6438           return NULL;
6439         }
6440       }
6441       else {
6442         savnam = dirnam;
6443         /* Does the file really exist? */
6444         if (sys$search(&dirfab)& STS$K_SUCCESS) {
6445           /* Yes; fake the fnb bits so we'll check type below */
6446           rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6447         }
6448         else { /* No; just work with potential name */
6449           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6450           else {
6451             int fab_sts;
6452             fab_sts = dirfab.fab$l_sts;
6453             sts = rms_free_search_context(&dirfab);
6454             PerlMem_free(esa);
6455             if (esal != NULL)
6456                 PerlMem_free(esal);
6457             PerlMem_free(trndir);
6458             PerlMem_free(vmsdir);
6459             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
6460             return NULL;
6461           }
6462         }
6463       }
6464
6465       /* Make sure we are using the right buffer */
6466 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6467       if (esal != NULL) {
6468         my_esa = esal;
6469         my_esa_len = rms_nam_esll(dirnam);
6470       } else {
6471 #endif
6472         my_esa = esa;
6473         my_esa_len = rms_nam_esl(dirnam);
6474 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6475       }
6476 #endif
6477       my_esa[my_esa_len] = '\0';
6478       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6479         cp1 = strchr(my_esa,']');
6480         if (!cp1) cp1 = strchr(my_esa,'>');
6481         if (cp1) {  /* Should always be true */
6482           my_esa_len -= cp1 - my_esa - 1;
6483           memmove(my_esa, cp1 + 1, my_esa_len);
6484         }
6485       }
6486       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6487         /* Yep; check version while we're at it, if it's there. */
6488         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6489         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6490           /* Something other than .DIR[;1].  Bzzt. */
6491           sts = rms_free_search_context(&dirfab);
6492           PerlMem_free(esa);
6493           if (esal != NULL)
6494              PerlMem_free(esal);
6495           PerlMem_free(trndir);
6496           PerlMem_free(vmsdir);
6497           set_errno(ENOTDIR);
6498           set_vaxc_errno(RMS$_DIR);
6499           return NULL;
6500         }
6501       }
6502
6503       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6504         /* They provided at least the name; we added the type, if necessary, */
6505         strcpy(buf, my_esa);
6506         sts = rms_free_search_context(&dirfab);
6507         PerlMem_free(trndir);
6508         PerlMem_free(esa);
6509         if (esal != NULL)
6510             PerlMem_free(esal);
6511         PerlMem_free(vmsdir);
6512         return buf;
6513       }
6514       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6515         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6516         *cp1 = '\0';
6517         my_esa_len -= 9;
6518       }
6519       if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6520       if (cp1 == NULL) { /* should never happen */
6521         sts = rms_free_search_context(&dirfab);
6522         PerlMem_free(trndir);
6523         PerlMem_free(esa);
6524         if (esal != NULL)
6525             PerlMem_free(esal);
6526         PerlMem_free(vmsdir);
6527         return NULL;
6528       }
6529       term = *cp1;
6530       *cp1 = '\0';
6531       retlen = strlen(my_esa);
6532       cp1 = strrchr(my_esa,'.');
6533       /* ODS-5 directory specifications can have extra "." in them. */
6534       /* Fix-me, can not scan EFS file specifications backwards */
6535       while (cp1 != NULL) {
6536         if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6537           break;
6538         else {
6539            cp1--;
6540            while ((cp1 > my_esa) && (*cp1 != '.'))
6541              cp1--;
6542         }
6543         if (cp1 == my_esa)
6544           cp1 = NULL;
6545       }
6546
6547       if ((cp1) != NULL) {
6548         /* There's more than one directory in the path.  Just roll back. */
6549         *cp1 = term;
6550         strcpy(buf, my_esa);
6551       }
6552       else {
6553         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6554           /* Go back and expand rooted logical name */
6555           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6556 #ifdef NAM$M_NO_SHORT_UPCASE
6557           if (decc_efs_case_preserve)
6558             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6559 #endif
6560           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6561             sts = rms_free_search_context(&dirfab);
6562             PerlMem_free(esa);
6563             if (esal != NULL)
6564                 PerlMem_free(esal);
6565             PerlMem_free(trndir);
6566             PerlMem_free(vmsdir);
6567             set_errno(EVMSERR);
6568             set_vaxc_errno(dirfab.fab$l_sts);
6569             return NULL;
6570           }
6571
6572           /* This changes the length of the string of course */
6573           if (esal != NULL) {
6574               my_esa_len = rms_nam_esll(dirnam);
6575           } else {
6576               my_esa_len = rms_nam_esl(dirnam);
6577           }
6578
6579           retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6580           cp1 = strstr(my_esa,"][");
6581           if (!cp1) cp1 = strstr(my_esa,"]<");
6582           dirlen = cp1 - my_esa;
6583           memcpy(buf, my_esa, dirlen);
6584           if (!strncmp(cp1+2,"000000]",7)) {
6585             buf[dirlen-1] = '\0';
6586             /* fix-me Not full ODS-5, just extra dots in directories for now */
6587             cp1 = buf + dirlen - 1;
6588             while (cp1 > buf)
6589             {
6590               if (*cp1 == '[')
6591                 break;
6592               if (*cp1 == '.') {
6593                 if (*(cp1-1) != '^')
6594                   break;
6595               }
6596               cp1--;
6597             }
6598             if (*cp1 == '.') *cp1 = ']';
6599             else {
6600               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6601               memmove(cp1+1,"000000]",7);
6602             }
6603           }
6604           else {
6605             memmove(buf+dirlen, cp1+2, retlen-dirlen);
6606             buf[retlen] = '\0';
6607             /* Convert last '.' to ']' */
6608             cp1 = buf+retlen-1;
6609             while (*cp != '[') {
6610               cp1--;
6611               if (*cp1 == '.') {
6612                 /* Do not trip on extra dots in ODS-5 directories */
6613                 if ((cp1 == buf) || (*(cp1-1) != '^'))
6614                 break;
6615               }
6616             }
6617             if (*cp1 == '.') *cp1 = ']';
6618             else {
6619               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6620               memmove(cp1+1,"000000]",7);
6621             }
6622           }
6623         }
6624         else {  /* This is a top-level dir.  Add the MFD to the path. */
6625           cp1 = my_esa;
6626           cp2 = buf;
6627           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6628           strcpy(cp2,":[000000]");
6629           cp1 += 2;
6630           strcpy(cp2+9,cp1);
6631         }
6632       }
6633       sts = rms_free_search_context(&dirfab);
6634       /* We've set up the string up through the filename.  Add the
6635          type and version, and we're done. */
6636       strcat(buf,".DIR;1");
6637
6638       /* $PARSE may have upcased filespec, so convert output to lower
6639        * case if input contained any lowercase characters. */
6640       if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
6641       PerlMem_free(trndir);
6642       PerlMem_free(esa);
6643       if (esal != NULL)
6644         PerlMem_free(esal);
6645       PerlMem_free(vmsdir);
6646       return buf;
6647     }
6648 }  /* end of int_fileify_dirspec() */
6649
6650
6651 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6652 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
6653 {
6654     static char __fileify_retbuf[VMS_MAXRSS];
6655     char * fileified, *ret_spec, *ret_buf;
6656
6657     fileified = NULL;
6658     ret_buf = buf;
6659     if (ret_buf == NULL) {
6660         if (ts) {
6661             Newx(fileified, VMS_MAXRSS, char);
6662             if (fileified == NULL)
6663                 _ckvmssts(SS$_INSFMEM);
6664             ret_buf = fileified;
6665         } else {
6666             ret_buf = __fileify_retbuf;
6667         }
6668     }
6669
6670     ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6671
6672     if (ret_spec == NULL) {
6673        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6674        if (fileified)
6675            Safefree(fileified);
6676     }
6677
6678     return ret_spec;
6679 }  /* end of do_fileify_dirspec() */
6680 /*}}}*/
6681
6682 /* External entry points */
6683 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6684 { return do_fileify_dirspec(dir,buf,0,NULL); }
6685 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6686 { return do_fileify_dirspec(dir,buf,1,NULL); }
6687 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6688 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6689 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6690 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6691
6692 static char * int_pathify_dirspec_simple(const char * dir, char * buf,
6693     char * v_spec, int v_len, char * r_spec, int r_len,
6694     char * d_spec, int d_len, char * n_spec, int n_len,
6695     char * e_spec, int e_len, char * vs_spec, int vs_len) {
6696
6697     /* VMS specification - Try to do this the simple way */
6698     if ((v_len + r_len > 0) || (d_len > 0)) {
6699         int is_dir;
6700
6701         /* No name or extension component, already a directory */
6702         if ((n_len + e_len + vs_len) == 0) {
6703             strcpy(buf, dir);
6704             return buf;
6705         }
6706
6707         /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6708         /* This results from catfile() being used instead of catdir() */
6709         /* So even though it should not work, we need to allow it */
6710
6711         /* If this is .DIR;1 then do a simple conversion */
6712         is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6713         if (is_dir || (e_len == 0) && (d_len > 0)) {
6714              int len;
6715              len = v_len + r_len + d_len - 1;
6716              char dclose = d_spec[d_len - 1];
6717              strncpy(buf, dir, len);
6718              buf[len] = '.';
6719              len++;
6720              strncpy(&buf[len], n_spec, n_len);
6721              len += n_len;
6722              buf[len] = dclose;
6723              buf[len + 1] = '\0';
6724              return buf;
6725         }
6726
6727 #ifdef HAS_SYMLINK
6728         else if (d_len > 0) {
6729             /* In the olden days, a directory needed to have a .DIR */
6730             /* extension to be a valid directory, but now it could  */
6731             /* be a symbolic link */
6732             int len;
6733             len = v_len + r_len + d_len - 1;
6734             char dclose = d_spec[d_len - 1];
6735             strncpy(buf, dir, len);
6736             buf[len] = '.';
6737             len++;
6738             strncpy(&buf[len], n_spec, n_len);
6739             len += n_len;
6740             if (e_len > 0) {
6741                 if (decc_efs_charset) {
6742                     buf[len] = '^';
6743                     len++;
6744                     strncpy(&buf[len], e_spec, e_len);
6745                     len += e_len;
6746                 } else {
6747                     set_vaxc_errno(RMS$_DIR);
6748                     set_errno(ENOTDIR);
6749                     return NULL;
6750                 }
6751             }
6752             buf[len] = dclose;
6753             buf[len + 1] = '\0';
6754             return buf;
6755         }
6756 #else
6757         else {
6758             set_vaxc_errno(RMS$_DIR);
6759             set_errno(ENOTDIR);
6760             return NULL;
6761         }
6762 #endif
6763     }
6764     set_vaxc_errno(RMS$_DIR);
6765     set_errno(ENOTDIR);
6766     return NULL;
6767 }
6768
6769
6770 /* Internal routine to make sure or convert a directory to be in a */
6771 /* path specification.  No utf8 flag because it is not changed or used */
6772 static char *int_pathify_dirspec(const char *dir, char *buf)
6773 {
6774     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6775     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6776     char * exp_spec, *ret_spec;
6777     char * trndir;
6778     unsigned short int trnlnm_iter_count;
6779     STRLEN trnlen;
6780     int need_to_lower;
6781
6782     if (vms_debug_fileify) {
6783         if (dir == NULL)
6784             fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6785         else
6786             fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6787     }
6788
6789     /* We may need to lower case the result if we translated  */
6790     /* a logical name or got the current working directory */
6791     need_to_lower = 0;
6792
6793     if (!dir || !*dir) {
6794       set_errno(EINVAL);
6795       set_vaxc_errno(SS$_BADPARAM);
6796       return NULL;
6797     }
6798
6799     trndir = PerlMem_malloc(VMS_MAXRSS);
6800     if (trndir == NULL)
6801         _ckvmssts_noperl(SS$_INSFMEM);
6802
6803     /* If no directory specified use the current default */
6804     if (*dir)
6805         strcpy(trndir, dir);
6806     else {
6807         getcwd(trndir, VMS_MAXRSS - 1);
6808         need_to_lower = 1;
6809     }
6810
6811     /* now deal with bare names that could be logical names */
6812     trnlnm_iter_count = 0;
6813     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6814            && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6815         trnlnm_iter_count++;
6816         need_to_lower = 1;
6817         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6818             break;
6819         trnlen = strlen(trndir);
6820
6821         /* Trap simple rooted lnms, and return lnm:[000000] */
6822         if (!strcmp(trndir+trnlen-2,".]")) {
6823             strcpy(buf, dir);
6824             strcat(buf, ":[000000]");
6825             PerlMem_free(trndir);
6826
6827             if (vms_debug_fileify) {
6828                 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6829             }
6830             return buf;
6831         }
6832     }
6833
6834     /* At this point we do not work with *dir, but the copy in  *trndir */
6835
6836     if (need_to_lower && !decc_efs_case_preserve) {
6837         /* Legacy mode, lower case the returned value */
6838         __mystrtolower(trndir);
6839     }
6840
6841
6842     /* Some special cases, '..', '.' */
6843     sts = 0;
6844     if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6845        /* Force UNIX filespec */
6846        sts = 1;
6847
6848     } else {
6849         /* Is this Unix or VMS format? */
6850         sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6851                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6852                              &e_len, &vs_spec, &vs_len);
6853         if (sts == 0) {
6854
6855             /* Just a filename? */
6856             if ((v_len + r_len + d_len) == 0) {
6857
6858                 /* Now we have a problem, this could be Unix or VMS */
6859                 /* We have to guess.  .DIR usually means VMS */
6860
6861                 /* In UNIX report mode, the .DIR extension is removed */
6862                 /* if one shows up, it is for a non-directory or a directory */
6863                 /* in EFS charset mode */
6864
6865                 /* So if we are in Unix report mode, assume that this */
6866                 /* is a relative Unix directory specification */
6867
6868                 sts = 1;
6869                 if (!decc_filename_unix_report && decc_efs_charset) {
6870                     int is_dir;
6871                     is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6872
6873                     if (is_dir) {
6874                         /* Traditional mode, assume .DIR is directory */
6875                         buf[0] = '[';
6876                         buf[1] = '.';
6877                         strncpy(&buf[2], n_spec, n_len);
6878                         buf[n_len + 2] = ']';
6879                         buf[n_len + 3] = '\0';
6880                         PerlMem_free(trndir);
6881                         if (vms_debug_fileify) {
6882                             fprintf(stderr,
6883                                     "int_pathify_dirspec: buf = %s\n",
6884                                     buf);
6885                         }
6886                         return buf;
6887                     }
6888                 }
6889             }
6890         }
6891     }
6892     if (sts == 0) {
6893         ret_spec = int_pathify_dirspec_simple(trndir, buf,
6894             v_spec, v_len, r_spec, r_len,
6895             d_spec, d_len, n_spec, n_len,
6896             e_spec, e_len, vs_spec, vs_len);
6897
6898         if (ret_spec != NULL) {
6899             PerlMem_free(trndir);
6900             if (vms_debug_fileify) {
6901                 fprintf(stderr,
6902                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6903             }
6904             return ret_spec;
6905         }
6906
6907         /* Simple way did not work, which means that a logical name */
6908         /* was present for the directory specification.             */
6909         /* Need to use an rmsexpand variant to decode it completely */
6910         exp_spec = PerlMem_malloc(VMS_MAXRSS);
6911         if (exp_spec == NULL)
6912             _ckvmssts_noperl(SS$_INSFMEM);
6913
6914         ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6915         if (ret_spec != NULL) {
6916             sts = vms_split_path(exp_spec, &v_spec, &v_len,
6917                                  &r_spec, &r_len, &d_spec, &d_len,
6918                                  &n_spec, &n_len, &e_spec,
6919                                  &e_len, &vs_spec, &vs_len);
6920             if (sts == 0) {
6921                 ret_spec = int_pathify_dirspec_simple(
6922                     exp_spec, buf, v_spec, v_len, r_spec, r_len,
6923                     d_spec, d_len, n_spec, n_len,
6924                     e_spec, e_len, vs_spec, vs_len);
6925
6926                 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6927                     /* Legacy mode, lower case the returned value */
6928                     __mystrtolower(ret_spec);
6929                 }
6930             } else {
6931                 set_vaxc_errno(RMS$_DIR);
6932                 set_errno(ENOTDIR);
6933                 ret_spec = NULL;
6934             }
6935         }
6936         PerlMem_free(exp_spec);
6937         PerlMem_free(trndir);
6938         if (vms_debug_fileify) {
6939             if (ret_spec == NULL)
6940                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6941             else
6942                 fprintf(stderr,
6943                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6944         }
6945         return ret_spec;
6946
6947     } else {
6948         /* Unix specification, Could be trivial conversion */
6949         STRLEN dir_len;
6950         dir_len = strlen(trndir);
6951
6952         /* If the extended file character set is in effect */
6953         /* then pathify is simple */
6954
6955         if (!decc_efs_charset) {
6956             /* Have to deal with traiing '.dir' or extra '.' */
6957             /* that should not be there in legacy mode, but is */
6958
6959             char * lastdot;
6960             char * lastslash;
6961             int is_dir;
6962
6963             lastslash = strrchr(trndir, '/');
6964             if (lastslash == NULL)
6965                 lastslash = trndir;
6966             else
6967                 lastslash++;
6968
6969             lastdot = NULL;
6970
6971             /* '..' or '.' are valid directory components */
6972             is_dir = 0;
6973             if (lastslash[0] == '.') {
6974                 if (lastslash[1] == '\0') {
6975                    is_dir = 1;
6976                 } else if (lastslash[1] == '.') {
6977                     if (lastslash[2] == '\0') {
6978                         is_dir = 1;
6979                     } else {
6980                         /* And finally allow '...' */
6981                         if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
6982                             is_dir = 1;
6983                         }
6984                     }
6985                 }
6986             }
6987
6988             if (!is_dir) {
6989                lastdot = strrchr(lastslash, '.');
6990             }
6991             if (lastdot != NULL) {
6992                 STRLEN e_len;
6993
6994                 /* '.dir' is discarded, and any other '.' is invalid */
6995                 e_len = strlen(lastdot);
6996
6997                 is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
6998
6999                 if (is_dir) {
7000                     dir_len = dir_len - 4;
7001
7002                 }
7003             }
7004         }
7005
7006         strcpy(buf, trndir);
7007         if (buf[dir_len - 1] != '/') {
7008             buf[dir_len] = '/';
7009             buf[dir_len + 1] = '\0';
7010         }
7011
7012         /* Under ODS-2 rules, '.' becomes '_', so fix it up */
7013         if (!decc_efs_charset) {
7014              int dir_start = 0;
7015              char * str = buf;
7016              if (str[0] == '.') {
7017                  char * dots = str;
7018                  int cnt = 1;
7019                  while ((dots[cnt] == '.') && (cnt < 3))
7020                      cnt++;
7021                  if (cnt <= 3) {
7022                      if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
7023                          dir_start = 1;
7024                          str += cnt;
7025                      }
7026                  }
7027              }
7028              for (; *str; ++str) {
7029                  while (*str == '/') {
7030                      dir_start = 1;
7031                      *str++;
7032                  }
7033                  if (dir_start) {
7034
7035                      /* Have to skip up to three dots which could be */
7036                      /* directories, 3 dots being a VMS extension for Perl */
7037                      char * dots = str;
7038                      int cnt = 0;
7039                      while ((dots[cnt] == '.') && (cnt < 3)) {
7040                          cnt++;
7041                      }
7042                      if (dots[cnt] == '\0')
7043                          break;
7044                      if ((cnt > 1) && (dots[cnt] != '/')) {
7045                          dir_start = 0;
7046                      } else {
7047                          str += cnt;
7048                      }
7049
7050                      /* too many dots? */
7051                      if ((cnt == 0) || (cnt > 3)) {
7052                          dir_start = 0;
7053                      }
7054                  }
7055                  if (!dir_start && (*str == '.')) {
7056                      *str = '_';
7057                  }
7058              }
7059         }
7060         PerlMem_free(trndir);
7061         ret_spec = buf;
7062         if (vms_debug_fileify) {
7063             if (ret_spec == NULL)
7064                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
7065             else
7066                 fprintf(stderr,
7067                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
7068         }
7069         return ret_spec;
7070     }
7071 }
7072
7073 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
7074 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
7075 {
7076     static char __pathify_retbuf[VMS_MAXRSS];
7077     char * pathified, *ret_spec, *ret_buf;
7078
7079     pathified = NULL;
7080     ret_buf = buf;
7081     if (ret_buf == NULL) {
7082         if (ts) {
7083             Newx(pathified, VMS_MAXRSS, char);
7084             if (pathified == NULL)
7085                 _ckvmssts(SS$_INSFMEM);
7086             ret_buf = pathified;
7087         } else {
7088             ret_buf = __pathify_retbuf;
7089         }
7090     }
7091
7092     ret_spec = int_pathify_dirspec(dir, ret_buf);
7093
7094     if (ret_spec == NULL) {
7095        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7096        if (pathified)
7097            Safefree(pathified);
7098     }
7099
7100     return ret_spec;
7101
7102 }  /* end of do_pathify_dirspec() */
7103
7104
7105 /* External entry points */
7106 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
7107 { return do_pathify_dirspec(dir,buf,0,NULL); }
7108 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
7109 { return do_pathify_dirspec(dir,buf,1,NULL); }
7110 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
7111 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
7112 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
7113 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
7114
7115 /* Internal tounixspec routine that does not use a thread context */
7116 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
7117 static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
7118 {
7119   char *dirend, *cp1, *cp3, *tmp;
7120   const char *cp2;
7121   int devlen, dirlen, retlen = VMS_MAXRSS;
7122   int expand = 1; /* guarantee room for leading and trailing slashes */
7123   unsigned short int trnlnm_iter_count;
7124   int cmp_rslt;
7125   if (utf8_fl != NULL)
7126     *utf8_fl = 0;
7127
7128   if (vms_debug_fileify) {
7129       if (spec == NULL)
7130           fprintf(stderr, "int_tounixspec: spec = NULL\n");
7131       else
7132           fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
7133   }
7134
7135
7136   if (spec == NULL) {
7137       set_errno(EINVAL);
7138       set_vaxc_errno(SS$_BADPARAM);
7139       return NULL;
7140   }
7141   if (strlen(spec) > (VMS_MAXRSS-1)) {
7142       set_errno(E2BIG);
7143       set_vaxc_errno(SS$_BUFFEROVF);
7144       return NULL;
7145   }
7146
7147   /* New VMS specific format needs translation
7148    * glob passes filenames with trailing '\n' and expects this preserved.
7149    */
7150   if (decc_posix_compliant_pathnames) {
7151     if (strncmp(spec, "\"^UP^", 5) == 0) {
7152       char * uspec;
7153       char *tunix;
7154       int tunix_len;
7155       int nl_flag;
7156
7157       tunix = PerlMem_malloc(VMS_MAXRSS);
7158       if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7159       strcpy(tunix, spec);
7160       tunix_len = strlen(tunix);
7161       nl_flag = 0;
7162       if (tunix[tunix_len - 1] == '\n') {
7163         tunix[tunix_len - 1] = '\"';
7164         tunix[tunix_len] = '\0';
7165         tunix_len--;
7166         nl_flag = 1;
7167       }
7168       uspec = decc$translate_vms(tunix);
7169       PerlMem_free(tunix);
7170       if ((int)uspec > 0) {
7171         strcpy(rslt,uspec);
7172         if (nl_flag) {
7173           strcat(rslt,"\n");
7174         }
7175         else {
7176           /* If we can not translate it, makemaker wants as-is */
7177           strcpy(rslt, spec);
7178         }
7179         return rslt;
7180       }
7181     }
7182   }
7183
7184   cmp_rslt = 0; /* Presume VMS */
7185   cp1 = strchr(spec, '/');
7186   if (cp1 == NULL)
7187     cmp_rslt = 0;
7188
7189     /* Look for EFS ^/ */
7190     if (decc_efs_charset) {
7191       while (cp1 != NULL) {
7192         cp2 = cp1 - 1;
7193         if (*cp2 != '^') {
7194           /* Found illegal VMS, assume UNIX */
7195           cmp_rslt = 1;
7196           break;
7197         }
7198       cp1++;
7199       cp1 = strchr(cp1, '/');
7200     }
7201   }
7202
7203   /* Look for "." and ".." */
7204   if (decc_filename_unix_report) {
7205     if (spec[0] == '.') {
7206       if ((spec[1] == '\0') || (spec[1] == '\n')) {
7207         cmp_rslt = 1;
7208       }
7209       else {
7210         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
7211           cmp_rslt = 1;
7212         }
7213       }
7214     }
7215   }
7216   /* This is already UNIX or at least nothing VMS understands */
7217   if (cmp_rslt) {
7218     strcpy(rslt,spec);
7219     if (vms_debug_fileify) {
7220         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7221     }
7222     return rslt;
7223   }
7224
7225   cp1 = rslt;
7226   cp2 = spec;
7227   dirend = strrchr(spec,']');
7228   if (dirend == NULL) dirend = strrchr(spec,'>');
7229   if (dirend == NULL) dirend = strchr(spec,':');
7230   if (dirend == NULL) {
7231     strcpy(rslt,spec);
7232     if (vms_debug_fileify) {
7233         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7234     }
7235     return rslt;
7236   }
7237
7238   /* Special case 1 - sys$posix_root = / */
7239 #if __CRTL_VER >= 70000000
7240   if (!decc_disable_posix_root) {
7241     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
7242       *cp1 = '/';
7243       cp1++;
7244       cp2 = cp2 + 15;
7245       }
7246   }
7247 #endif
7248
7249   /* Special case 2 - Convert NLA0: to /dev/null */
7250 #if __CRTL_VER < 70000000
7251   cmp_rslt = strncmp(spec,"NLA0:", 5);
7252   if (cmp_rslt != 0)
7253      cmp_rslt = strncmp(spec,"nla0:", 5);
7254 #else
7255   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
7256 #endif
7257   if (cmp_rslt == 0) {
7258     strcpy(rslt, "/dev/null");
7259     cp1 = cp1 + 9;
7260     cp2 = cp2 + 5;
7261     if (spec[6] != '\0') {
7262       cp1[9] == '/';
7263       cp1++;
7264       cp2++;
7265     }
7266   }
7267
7268    /* Also handle special case "SYS$SCRATCH:" */
7269 #if __CRTL_VER < 70000000
7270   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
7271   if (cmp_rslt != 0)
7272      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
7273 #else
7274   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
7275 #endif
7276   tmp = PerlMem_malloc(VMS_MAXRSS);
7277   if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7278   if (cmp_rslt == 0) {
7279   int islnm;
7280
7281     islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
7282     if (!islnm) {
7283       strcpy(rslt, "/tmp");
7284       cp1 = cp1 + 4;
7285       cp2 = cp2 + 12;
7286       if (spec[12] != '\0') {
7287         cp1[4] == '/';
7288         cp1++;
7289         cp2++;
7290       }
7291     }
7292   }
7293
7294   if (*cp2 != '[' && *cp2 != '<') {
7295     *(cp1++) = '/';
7296   }
7297   else {  /* the VMS spec begins with directories */
7298     cp2++;
7299     if (*cp2 == ']' || *cp2 == '>') {
7300       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
7301       PerlMem_free(tmp);
7302       return rslt;
7303     }
7304     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
7305       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
7306         PerlMem_free(tmp);
7307         if (vms_debug_fileify) {
7308             fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7309         }
7310         return NULL;
7311       }
7312       trnlnm_iter_count = 0;
7313       do {
7314         cp3 = tmp;
7315         while (*cp3 != ':' && *cp3) cp3++;
7316         *(cp3++) = '\0';
7317         if (strchr(cp3,']') != NULL) break;
7318         trnlnm_iter_count++;
7319         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7320       } while (vmstrnenv(tmp,tmp,0,fildev,0));
7321       cp1 = rslt;
7322       cp3 = tmp;
7323       *(cp1++) = '/';
7324       while (*cp3) {
7325         *(cp1++) = *(cp3++);
7326         if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7327             PerlMem_free(tmp);
7328             set_errno(ENAMETOOLONG);
7329             set_vaxc_errno(SS$_BUFFEROVF);
7330             if (vms_debug_fileify) {
7331                 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7332             }
7333             return NULL; /* No room */
7334         }
7335       }
7336       *(cp1++) = '/';
7337     }
7338     if ((*cp2 == '^')) {
7339         /* EFS file escape, pass the next character as is */
7340         /* Fix me: HEX encoding for Unicode not implemented */
7341         cp2++;
7342     }
7343     else if ( *cp2 == '.') {
7344       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7345         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7346         cp2 += 3;
7347       }
7348       else cp2++;
7349     }
7350   }
7351   PerlMem_free(tmp);
7352   for (; cp2 <= dirend; cp2++) {
7353     if ((*cp2 == '^')) {
7354         /* EFS file escape, pass the next character as is */
7355         /* Fix me: HEX encoding for Unicode not implemented */
7356         *(cp1++) = *(++cp2);
7357         /* An escaped dot stays as is -- don't convert to slash */
7358         if (*cp2 == '.') cp2++;
7359     }
7360     if (*cp2 == ':') {
7361       *(cp1++) = '/';
7362       if (*(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7363     }
7364     else if (*cp2 == ']' || *cp2 == '>') {
7365       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7366     }
7367     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7368       *(cp1++) = '/';
7369       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7370         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7371                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7372         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7373             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7374       }
7375       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7376         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7377         cp2 += 2;
7378       }
7379     }
7380     else if (*cp2 == '-') {
7381       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7382         while (*cp2 == '-') {
7383           cp2++;
7384           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7385         }
7386         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7387                                                          /* filespecs like */
7388           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
7389           if (vms_debug_fileify) {
7390               fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7391           }
7392           return NULL;
7393         }
7394       }
7395       else *(cp1++) = *cp2;
7396     }
7397     else *(cp1++) = *cp2;
7398   }
7399   /* Translate the rest of the filename. */
7400   while (*cp2) {
7401       int dot_seen;
7402       dot_seen = 0;
7403       switch(*cp2) {
7404       /* Fixme - for compatibility with the CRTL we should be removing */
7405       /* spaces from the file specifications, but this may show that */
7406       /* some tests that were appearing to pass are not really passing */
7407       case '%':
7408           cp2++;
7409           *(cp1++) = '?';
7410           break;
7411       case '^':
7412           /* Fix me hex expansions not implemented */
7413           cp2++;  /* '^.' --> '.' and other. */
7414           if (*cp2) {
7415               if (*cp2 == '_') {
7416                   cp2++;
7417                   *(cp1++) = ' ';
7418               } else {
7419                   *(cp1++) = *(cp2++);
7420               }
7421           }
7422           break;
7423       case ';':
7424           if (decc_filename_unix_no_version) {
7425               /* Easy, drop the version */
7426               while (*cp2)
7427                   cp2++;
7428               break;
7429           } else {
7430               /* Punt - passing the version as a dot will probably */
7431               /* break perl in weird ways, but so did passing */
7432               /* through the ; as a version.  Follow the CRTL and */
7433               /* hope for the best. */
7434               cp2++;
7435               *(cp1++) = '.';
7436           }
7437           break;
7438       case '.':
7439           if (dot_seen) {
7440               /* We will need to fix this properly later */
7441               /* As Perl may be installed on an ODS-5 volume, but not */
7442               /* have the EFS_CHARSET enabled, it still may encounter */
7443               /* filenames with extra dots in them, and a precedent got */
7444               /* set which allowed them to work, that we will uphold here */
7445               /* If extra dots are present in a name and no ^ is on them */
7446               /* VMS assumes that the first one is the extension delimiter */
7447               /* the rest have an implied ^. */
7448
7449               /* this is also a conflict as the . is also a version */
7450               /* delimiter in VMS, */
7451
7452               *(cp1++) = *(cp2++);
7453               break;
7454           }
7455           dot_seen = 1;
7456           /* This is an extension */
7457           if (decc_readdir_dropdotnotype) {
7458               cp2++;
7459               if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7460                   /* Drop the dot for the extension */
7461                   break;
7462               } else {
7463                   *(cp1++) = '.';
7464               }
7465               break;
7466           }
7467       default:
7468           *(cp1++) = *(cp2++);
7469       }
7470   }
7471   *cp1 = '\0';
7472
7473   /* This still leaves /000000/ when working with a
7474    * VMS device root or concealed root.
7475    */
7476   {
7477   int ulen;
7478   char * zeros;
7479
7480       ulen = strlen(rslt);
7481
7482       /* Get rid of "000000/ in rooted filespecs */
7483       if (ulen > 7) {
7484         zeros = strstr(rslt, "/000000/");
7485         if (zeros != NULL) {
7486           int mlen;
7487           mlen = ulen - (zeros - rslt) - 7;
7488           memmove(zeros, &zeros[7], mlen);
7489           ulen = ulen - 7;
7490           rslt[ulen] = '\0';
7491         }
7492       }
7493   }
7494
7495   if (vms_debug_fileify) {
7496       fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7497   }
7498   return rslt;
7499
7500 }  /* end of int_tounixspec() */
7501
7502
7503 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7504 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7505 {
7506     static char __tounixspec_retbuf[VMS_MAXRSS];
7507     char * unixspec, *ret_spec, *ret_buf;
7508
7509     unixspec = NULL;
7510     ret_buf = buf;
7511     if (ret_buf == NULL) {
7512         if (ts) {
7513             Newx(unixspec, VMS_MAXRSS, char);
7514             if (unixspec == NULL)
7515                 _ckvmssts(SS$_INSFMEM);
7516             ret_buf = unixspec;
7517         } else {
7518             ret_buf = __tounixspec_retbuf;
7519         }
7520     }
7521
7522     ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7523
7524     if (ret_spec == NULL) {
7525        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7526        if (unixspec)
7527            Safefree(unixspec);
7528     }
7529
7530     return ret_spec;
7531
7532 }  /* end of do_tounixspec() */
7533 /*}}}*/
7534 /* External entry points */
7535 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
7536   { return do_tounixspec(spec,buf,0, NULL); }
7537 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7538   { return do_tounixspec(spec,buf,1, NULL); }
7539 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7540   { return do_tounixspec(spec,buf,0, utf8_fl); }
7541 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7542   { return do_tounixspec(spec,buf,1, utf8_fl); }
7543
7544 #if __CRTL_VER >= 70200000 && !defined(__VAX)
7545
7546 /*
7547  This procedure is used to identify if a path is based in either
7548  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7549  it returns the OpenVMS format directory for it.
7550
7551  It is expecting specifications of only '/' or '/xxxx/'
7552
7553  If a posix root does not exist, or 'xxxx' is not a directory
7554  in the posix root, it returns a failure.
7555
7556  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7557
7558  It is used only internally by posix_to_vmsspec_hardway().
7559  */
7560
7561 static int posix_root_to_vms
7562   (char *vmspath, int vmspath_len,
7563    const char *unixpath,
7564    const int * utf8_fl)
7565 {
7566 int sts;
7567 struct FAB myfab = cc$rms_fab;
7568 rms_setup_nam(mynam);
7569 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7570 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7571 char * esa, * esal, * rsa, * rsal;
7572 char *vms_delim;
7573 int dir_flag;
7574 int unixlen;
7575
7576     dir_flag = 0;
7577     vmspath[0] = '\0';
7578     unixlen = strlen(unixpath);
7579     if (unixlen == 0) {
7580       return RMS$_FNF;
7581     }
7582
7583 #if __CRTL_VER >= 80200000
7584   /* If not a posix spec already, convert it */
7585   if (decc_posix_compliant_pathnames) {
7586     if (strncmp(unixpath,"\"^UP^",5) != 0) {
7587       sprintf(vmspath,"\"^UP^%s\"",unixpath);
7588     }
7589     else {
7590       /* This is already a VMS specification, no conversion */
7591       unixlen--;
7592       strncpy(vmspath,unixpath, vmspath_len);
7593     }
7594   }
7595   else
7596 #endif
7597   {
7598   int path_len;
7599   int i,j;
7600
7601      /* Check to see if this is under the POSIX root */
7602      if (decc_disable_posix_root) {
7603         return RMS$_FNF;
7604      }
7605
7606      /* Skip leading / */
7607      if (unixpath[0] == '/') {
7608         unixpath++;
7609         unixlen--;
7610      }
7611
7612
7613      strcpy(vmspath,"SYS$POSIX_ROOT:");
7614
7615      /* If this is only the / , or blank, then... */
7616      if (unixpath[0] == '\0') {
7617         /* by definition, this is the answer */
7618         return SS$_NORMAL;
7619      }
7620
7621      /* Need to look up a directory */
7622      vmspath[15] = '[';
7623      vmspath[16] = '\0';
7624
7625      /* Copy and add '^' escape characters as needed */
7626      j = 16;
7627      i = 0;
7628      while (unixpath[i] != 0) {
7629      int k;
7630
7631         j += copy_expand_unix_filename_escape
7632             (&vmspath[j], &unixpath[i], &k, utf8_fl);
7633         i += k;
7634      }
7635
7636      path_len = strlen(vmspath);
7637      if (vmspath[path_len - 1] == '/')
7638         path_len--;
7639      vmspath[path_len] = ']';
7640      path_len++;
7641      vmspath[path_len] = '\0';
7642
7643   }
7644   vmspath[vmspath_len] = 0;
7645   if (unixpath[unixlen - 1] == '/')
7646   dir_flag = 1;
7647   esal = PerlMem_malloc(VMS_MAXRSS);
7648   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7649   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7650   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7651   rsal = PerlMem_malloc(VMS_MAXRSS);
7652   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7653   rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7654   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7655   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7656   rms_bind_fab_nam(myfab, mynam);
7657   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7658   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7659   if (decc_efs_case_preserve)
7660     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7661 #ifdef NAML$M_OPEN_SPECIAL
7662   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7663 #endif
7664
7665   /* Set up the remaining naml fields */
7666   sts = sys$parse(&myfab);
7667
7668   /* It failed! Try again as a UNIX filespec */
7669   if (!(sts & 1)) {
7670     PerlMem_free(esal);
7671     PerlMem_free(esa);
7672     PerlMem_free(rsal);
7673     PerlMem_free(rsa);
7674     return sts;
7675   }
7676
7677    /* get the Device ID and the FID */
7678    sts = sys$search(&myfab);
7679
7680    /* These are no longer needed */
7681    PerlMem_free(esa);
7682    PerlMem_free(rsal);
7683    PerlMem_free(rsa);
7684
7685    /* on any failure, returned the POSIX ^UP^ filespec */
7686    if (!(sts & 1)) {
7687       PerlMem_free(esal);
7688       return sts;
7689    }
7690    specdsc.dsc$a_pointer = vmspath;
7691    specdsc.dsc$w_length = vmspath_len;
7692
7693    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7694    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7695    sts = lib$fid_to_name
7696       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7697
7698   /* on any failure, returned the POSIX ^UP^ filespec */
7699   if (!(sts & 1)) {
7700      /* This can happen if user does not have permission to read directories */
7701      if (strncmp(unixpath,"\"^UP^",5) != 0)
7702        sprintf(vmspath,"\"^UP^%s\"",unixpath);
7703      else
7704        strcpy(vmspath, unixpath);
7705   }
7706   else {
7707     vmspath[specdsc.dsc$w_length] = 0;
7708
7709     /* Are we expecting a directory? */
7710     if (dir_flag != 0) {
7711     int i;
7712     char *eptr;
7713
7714       eptr = NULL;
7715
7716       i = specdsc.dsc$w_length - 1;
7717       while (i > 0) {
7718       int zercnt;
7719         zercnt = 0;
7720         /* Version must be '1' */
7721         if (vmspath[i--] != '1')
7722           break;
7723         /* Version delimiter is one of ".;" */
7724         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7725           break;
7726         i--;
7727         if (vmspath[i--] != 'R')
7728           break;
7729         if (vmspath[i--] != 'I')
7730           break;
7731         if (vmspath[i--] != 'D')
7732           break;
7733         if (vmspath[i--] != '.')
7734           break;
7735         eptr = &vmspath[i+1];
7736         while (i > 0) {
7737           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7738             if (vmspath[i-1] != '^') {
7739               if (zercnt != 6) {
7740                 *eptr = vmspath[i];
7741                 eptr[1] = '\0';
7742                 vmspath[i] = '.';
7743                 break;
7744               }
7745               else {
7746                 /* Get rid of 6 imaginary zero directory filename */
7747                 vmspath[i+1] = '\0';
7748               }
7749             }
7750           }
7751           if (vmspath[i] == '0')
7752             zercnt++;
7753           else
7754             zercnt = 10;
7755           i--;
7756         }
7757         break;
7758       }
7759     }
7760   }
7761   PerlMem_free(esal);
7762   return sts;
7763 }
7764
7765 /* /dev/mumble needs to be handled special.
7766    /dev/null becomes NLA0:, And there is the potential for other stuff
7767    like /dev/tty which may need to be mapped to something.
7768 */
7769
7770 static int
7771 slash_dev_special_to_vms
7772    (const char * unixptr,
7773     char * vmspath,
7774     int vmspath_len)
7775 {
7776 char * nextslash;
7777 int len;
7778 int cmp;
7779 int islnm;
7780
7781     unixptr += 4;
7782     nextslash = strchr(unixptr, '/');
7783     len = strlen(unixptr);
7784     if (nextslash != NULL)
7785         len = nextslash - unixptr;
7786     cmp = strncmp("null", unixptr, 5);
7787     if (cmp == 0) {
7788         if (vmspath_len >= 6) {
7789             strcpy(vmspath, "_NLA0:");
7790             return SS$_NORMAL;
7791         }
7792     }
7793 }
7794
7795
7796 /* The built in routines do not understand perl's special needs, so
7797     doing a manual conversion from UNIX to VMS
7798
7799     If the utf8_fl is not null and points to a non-zero value, then
7800     treat 8 bit characters as UTF-8.
7801
7802     The sequence starting with '$(' and ending with ')' will be passed
7803     through with out interpretation instead of being escaped.
7804
7805   */
7806 static int posix_to_vmsspec_hardway
7807   (char *vmspath, int vmspath_len,
7808    const char *unixpath,
7809    int dir_flag,
7810    int * utf8_fl) {
7811
7812 char *esa;
7813 const char *unixptr;
7814 const char *unixend;
7815 char *vmsptr;
7816 const char *lastslash;
7817 const char *lastdot;
7818 int unixlen;
7819 int vmslen;
7820 int dir_start;
7821 int dir_dot;
7822 int quoted;
7823 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7824 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7825
7826   if (utf8_fl != NULL)
7827     *utf8_fl = 0;
7828
7829   unixptr = unixpath;
7830   dir_dot = 0;
7831
7832   /* Ignore leading "/" characters */
7833   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7834     unixptr++;
7835   }
7836   unixlen = strlen(unixptr);
7837
7838   /* Do nothing with blank paths */
7839   if (unixlen == 0) {
7840     vmspath[0] = '\0';
7841     return SS$_NORMAL;
7842   }
7843
7844   quoted = 0;
7845   /* This could have a "^UP^ on the front */
7846   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7847     quoted = 1;
7848     unixptr+= 5;
7849     unixlen-= 5;
7850   }
7851
7852   lastslash = strrchr(unixptr,'/');
7853   lastdot = strrchr(unixptr,'.');
7854   unixend = strrchr(unixptr,'\"');
7855   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7856     unixend = unixptr + unixlen;
7857   }
7858
7859   /* last dot is last dot or past end of string */
7860   if (lastdot == NULL)
7861     lastdot = unixptr + unixlen;
7862
7863   /* if no directories, set last slash to beginning of string */
7864   if (lastslash == NULL) {
7865     lastslash = unixptr;
7866   }
7867   else {
7868     /* Watch out for trailing "." after last slash, still a directory */
7869     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7870       lastslash = unixptr + unixlen;
7871     }
7872
7873     /* Watch out for traiing ".." after last slash, still a directory */
7874     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7875       lastslash = unixptr + unixlen;
7876     }
7877
7878     /* dots in directories are aways escaped */
7879     if (lastdot < lastslash)
7880       lastdot = unixptr + unixlen;
7881   }
7882
7883   /* if (unixptr < lastslash) then we are in a directory */
7884
7885   dir_start = 0;
7886
7887   vmsptr = vmspath;
7888   vmslen = 0;
7889
7890   /* Start with the UNIX path */
7891   if (*unixptr != '/') {
7892     /* relative paths */
7893
7894     /* If allowing logical names on relative pathnames, then handle here */
7895     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7896         !decc_posix_compliant_pathnames) {
7897     char * nextslash;
7898     int seg_len;
7899     char * trn;
7900     int islnm;
7901
7902         /* Find the next slash */
7903         nextslash = strchr(unixptr,'/');
7904
7905         esa = PerlMem_malloc(vmspath_len);
7906         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7907
7908         trn = PerlMem_malloc(VMS_MAXRSS);
7909         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7910
7911         if (nextslash != NULL) {
7912
7913             seg_len = nextslash - unixptr;
7914             strncpy(esa, unixptr, seg_len);
7915             esa[seg_len] = 0;
7916         }
7917         else {
7918             strcpy(esa, unixptr);
7919             seg_len = strlen(unixptr);
7920         }
7921         /* trnlnm(section) */
7922         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7923
7924         if (islnm) {
7925             /* Now fix up the directory */
7926
7927             /* Split up the path to find the components */
7928             sts = vms_split_path
7929                   (trn,
7930                    &v_spec,
7931                    &v_len,
7932                    &r_spec,
7933                    &r_len,
7934                    &d_spec,
7935                    &d_len,
7936                    &n_spec,
7937                    &n_len,
7938                    &e_spec,
7939                    &e_len,
7940                    &vs_spec,
7941                    &vs_len);
7942
7943             while (sts == 0) {
7944             char * strt;
7945             int cmp;
7946
7947                 /* A logical name must be a directory  or the full
7948                    specification.  It is only a full specification if
7949                    it is the only component */
7950                 if ((unixptr[seg_len] == '\0') ||
7951                     (unixptr[seg_len+1] == '\0')) {
7952
7953                     /* Is a directory being required? */
7954                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7955                         /* Not a logical name */
7956                         break;
7957                     }
7958
7959
7960                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7961                         /* This must be a directory */
7962                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7963                             strcpy(vmsptr, esa);
7964                             vmslen=strlen(vmsptr);
7965                             vmsptr[vmslen] = ':';
7966                             vmslen++;
7967                             vmsptr[vmslen] = '\0';
7968                             return SS$_NORMAL;
7969                         }
7970                     }
7971
7972                 }
7973
7974
7975                 /* must be dev/directory - ignore version */
7976                 if ((n_len + e_len) != 0)
7977                     break;
7978
7979                 /* transfer the volume */
7980                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7981                     strncpy(vmsptr, v_spec, v_len);
7982                     vmsptr += v_len;
7983                     vmsptr[0] = '\0';
7984                     vmslen += v_len;
7985                 }
7986
7987                 /* unroot the rooted directory */
7988                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7989                     r_spec[0] = '[';
7990                     r_spec[r_len - 1] = ']';
7991
7992                     /* This should not be there, but nothing is perfect */
7993                     if (r_len > 9) {
7994                         cmp = strcmp(&r_spec[1], "000000.");
7995                         if (cmp == 0) {
7996                             r_spec += 7;
7997                             r_spec[7] = '[';
7998                             r_len -= 7;
7999                             if (r_len == 2)
8000                                 r_len = 0;
8001                         }
8002                     }
8003                     if (r_len > 0) {
8004                         strncpy(vmsptr, r_spec, r_len);
8005                         vmsptr += r_len;
8006                         vmslen += r_len;
8007                         vmsptr[0] = '\0';
8008                     }
8009                 }
8010                 /* Bring over the directory. */
8011                 if ((d_len > 0) &&
8012                     ((d_len + vmslen) < vmspath_len)) {
8013                     d_spec[0] = '[';
8014                     d_spec[d_len - 1] = ']';
8015                     if (d_len > 9) {
8016                         cmp = strcmp(&d_spec[1], "000000.");
8017                         if (cmp == 0) {
8018                             d_spec += 7;
8019                             d_spec[7] = '[';
8020                             d_len -= 7;
8021                             if (d_len == 2)
8022                                 d_len = 0;
8023                         }
8024                     }
8025
8026                     if (r_len > 0) {
8027                         /* Remove the redundant root */
8028                         if (r_len > 0) {
8029                             /* remove the ][ */
8030                             vmsptr--;
8031                             vmslen--;
8032                             d_spec++;
8033                             d_len--;
8034                         }
8035                         strncpy(vmsptr, d_spec, d_len);
8036                             vmsptr += d_len;
8037                             vmslen += d_len;
8038                             vmsptr[0] = '\0';
8039                     }
8040                 }
8041                 break;
8042             }
8043         }
8044
8045         PerlMem_free(esa);
8046         PerlMem_free(trn);
8047     }
8048
8049     if (lastslash > unixptr) {
8050     int dotdir_seen;
8051
8052       /* skip leading ./ */
8053       dotdir_seen = 0;
8054       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
8055         dotdir_seen = 1;
8056         unixptr++;
8057         unixptr++;
8058       }
8059
8060       /* Are we still in a directory? */
8061       if (unixptr <= lastslash) {
8062         *vmsptr++ = '[';
8063         vmslen = 1;
8064         dir_start = 1;
8065
8066         /* if not backing up, then it is relative forward. */
8067         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
8068               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
8069           *vmsptr++ = '.';
8070           vmslen++;
8071           dir_dot = 1;
8072           }
8073        }
8074        else {
8075          if (dotdir_seen) {
8076            /* Perl wants an empty directory here to tell the difference
8077             * between a DCL commmand and a filename
8078             */
8079           *vmsptr++ = '[';
8080           *vmsptr++ = ']';
8081           vmslen = 2;
8082         }
8083       }
8084     }
8085     else {
8086       /* Handle two special files . and .. */
8087       if (unixptr[0] == '.') {
8088         if (&unixptr[1] == unixend) {
8089           *vmsptr++ = '[';
8090           *vmsptr++ = ']';
8091           vmslen += 2;
8092           *vmsptr++ = '\0';
8093           return SS$_NORMAL;
8094         }
8095         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
8096           *vmsptr++ = '[';
8097           *vmsptr++ = '-';
8098           *vmsptr++ = ']';
8099           vmslen += 3;
8100           *vmsptr++ = '\0';
8101           return SS$_NORMAL;
8102         }
8103       }
8104     }
8105   }
8106   else {        /* Absolute PATH handling */
8107   int sts;
8108   char * nextslash;
8109   int seg_len;
8110     /* Need to find out where root is */
8111
8112     /* In theory, this procedure should never get an absolute POSIX pathname
8113      * that can not be found on the POSIX root.
8114      * In practice, that can not be relied on, and things will show up
8115      * here that are a VMS device name or concealed logical name instead.
8116      * So to make things work, this procedure must be tolerant.
8117      */
8118     esa = PerlMem_malloc(vmspath_len);
8119     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8120
8121     sts = SS$_NORMAL;
8122     nextslash = strchr(&unixptr[1],'/');
8123     seg_len = 0;
8124     if (nextslash != NULL) {
8125     int cmp;
8126       seg_len = nextslash - &unixptr[1];
8127       strncpy(vmspath, unixptr, seg_len + 1);
8128       vmspath[seg_len+1] = 0;
8129       cmp = 1;
8130       if (seg_len == 3) {
8131         cmp = strncmp(vmspath, "dev", 4);
8132         if (cmp == 0) {
8133             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
8134             if (sts = SS$_NORMAL)
8135                 return SS$_NORMAL;
8136         }
8137       }
8138       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
8139     }
8140
8141     if ($VMS_STATUS_SUCCESS(sts)) {
8142       /* This is verified to be a real path */
8143
8144       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
8145       if ($VMS_STATUS_SUCCESS(sts)) {
8146         strcpy(vmspath, esa);
8147         vmslen = strlen(vmspath);
8148         vmsptr = vmspath + vmslen;
8149         unixptr++;
8150         if (unixptr < lastslash) {
8151         char * rptr;
8152           vmsptr--;
8153           *vmsptr++ = '.';
8154           dir_start = 1;
8155           dir_dot = 1;
8156           if (vmslen > 7) {
8157           int cmp;
8158             rptr = vmsptr - 7;
8159             cmp = strcmp(rptr,"000000.");
8160             if (cmp == 0) {
8161               vmslen -= 7;
8162               vmsptr -= 7;
8163               vmsptr[1] = '\0';
8164             } /* removing 6 zeros */
8165           } /* vmslen < 7, no 6 zeros possible */
8166         } /* Not in a directory */
8167       } /* Posix root found */
8168       else {
8169         /* No posix root, fall back to default directory */
8170         strcpy(vmspath, "SYS$DISK:[");
8171         vmsptr = &vmspath[10];
8172         vmslen = 10;
8173         if (unixptr > lastslash) {
8174            *vmsptr = ']';
8175            vmsptr++;
8176            vmslen++;
8177         }
8178         else {
8179            dir_start = 1;
8180         }
8181       }
8182     } /* end of verified real path handling */
8183     else {
8184     int add_6zero;
8185     int islnm;
8186
8187       /* Ok, we have a device or a concealed root that is not in POSIX
8188        * or we have garbage.  Make the best of it.
8189        */
8190
8191       /* Posix to VMS destroyed this, so copy it again */
8192       strncpy(vmspath, &unixptr[1], seg_len);
8193       vmspath[seg_len] = 0;
8194       vmslen = seg_len;
8195       vmsptr = &vmsptr[vmslen];
8196       islnm = 0;
8197
8198       /* Now do we need to add the fake 6 zero directory to it? */
8199       add_6zero = 1;
8200       if ((*lastslash == '/') && (nextslash < lastslash)) {
8201         /* No there is another directory */
8202         add_6zero = 0;
8203       }
8204       else {
8205       int trnend;
8206       int cmp;
8207
8208         /* now we have foo:bar or foo:[000000]bar to decide from */
8209         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
8210
8211         if (!islnm && !decc_posix_compliant_pathnames) {
8212
8213             cmp = strncmp("bin", vmspath, 4);
8214             if (cmp == 0) {
8215                 /* bin => SYS$SYSTEM: */
8216                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
8217             }
8218             else {
8219                 /* tmp => SYS$SCRATCH: */
8220                 cmp = strncmp("tmp", vmspath, 4);
8221                 if (cmp == 0) {
8222                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
8223                 }
8224             }
8225         }
8226
8227         trnend = islnm ? islnm - 1 : 0;
8228
8229         /* if this was a logical name, ']' or '>' must be present */
8230         /* if not a logical name, then assume a device and hope. */
8231         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
8232
8233         /* if log name and trailing '.' then rooted - treat as device */
8234         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
8235
8236         /* Fix me, if not a logical name, a device lookup should be
8237          * done to see if the device is file structured.  If the device
8238          * is not file structured, the 6 zeros should not be put on.
8239          *
8240          * As it is, perl is occasionally looking for dev:[000000]tty.
8241          * which looks a little strange.
8242          *
8243          * Not that easy to detect as "/dev" may be file structured with
8244          * special device files.
8245          */
8246
8247         if (!islnm && (add_6zero == 0) && (*nextslash == '/') &&
8248             (&nextslash[1] == unixend)) {
8249           /* No real directory present */
8250           add_6zero = 1;
8251         }
8252       }
8253
8254       /* Put the device delimiter on */
8255       *vmsptr++ = ':';
8256       vmslen++;
8257       unixptr = nextslash;
8258       unixptr++;
8259
8260       /* Start directory if needed */
8261       if (!islnm || add_6zero) {
8262         *vmsptr++ = '[';
8263         vmslen++;
8264         dir_start = 1;
8265       }
8266
8267       /* add fake 000000] if needed */
8268       if (add_6zero) {
8269         *vmsptr++ = '0';
8270         *vmsptr++ = '0';
8271         *vmsptr++ = '0';
8272         *vmsptr++ = '0';
8273         *vmsptr++ = '0';
8274         *vmsptr++ = '0';
8275         *vmsptr++ = ']';
8276         vmslen += 7;
8277         dir_start = 0;
8278       }
8279
8280     } /* non-POSIX translation */
8281     PerlMem_free(esa);
8282   } /* End of relative/absolute path handling */
8283
8284   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
8285   int dash_flag;
8286   int in_cnt;
8287   int out_cnt;
8288
8289     dash_flag = 0;
8290
8291     if (dir_start != 0) {
8292
8293       /* First characters in a directory are handled special */
8294       while ((*unixptr == '/') ||
8295              ((*unixptr == '.') &&
8296               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8297                 (&unixptr[1]==unixend)))) {
8298       int loop_flag;
8299
8300         loop_flag = 0;
8301
8302         /* Skip redundant / in specification */
8303         while ((*unixptr == '/') && (dir_start != 0)) {
8304           loop_flag = 1;
8305           unixptr++;
8306           if (unixptr == lastslash)
8307             break;
8308         }
8309         if (unixptr == lastslash)
8310           break;
8311
8312         /* Skip redundant ./ characters */
8313         while ((*unixptr == '.') &&
8314                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8315           loop_flag = 1;
8316           unixptr++;
8317           if (unixptr == lastslash)
8318             break;
8319           if (*unixptr == '/')
8320             unixptr++;
8321         }
8322         if (unixptr == lastslash)
8323           break;
8324
8325         /* Skip redundant ../ characters */
8326         while ((*unixptr == '.') && (unixptr[1] == '.') &&
8327              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8328           /* Set the backing up flag */
8329           loop_flag = 1;
8330           dir_dot = 0;
8331           dash_flag = 1;
8332           *vmsptr++ = '-';
8333           vmslen++;
8334           unixptr++; /* first . */
8335           unixptr++; /* second . */
8336           if (unixptr == lastslash)
8337             break;
8338           if (*unixptr == '/') /* The slash */
8339             unixptr++;
8340         }
8341         if (unixptr == lastslash)
8342           break;
8343
8344         /* To do: Perl expects /.../ to be translated to [...] on VMS */
8345         /* Not needed when VMS is pretending to be UNIX. */
8346
8347         /* Is this loop stuck because of too many dots? */
8348         if (loop_flag == 0) {
8349           /* Exit the loop and pass the rest through */
8350           break;
8351         }
8352       }
8353
8354       /* Are we done with directories yet? */
8355       if (unixptr >= lastslash) {
8356
8357         /* Watch out for trailing dots */
8358         if (dir_dot != 0) {
8359             vmslen --;
8360             vmsptr--;
8361         }
8362         *vmsptr++ = ']';
8363         vmslen++;
8364         dash_flag = 0;
8365         dir_start = 0;
8366         if (*unixptr == '/')
8367           unixptr++;
8368       }
8369       else {
8370         /* Have we stopped backing up? */
8371         if (dash_flag) {
8372           *vmsptr++ = '.';
8373           vmslen++;
8374           dash_flag = 0;
8375           /* dir_start continues to be = 1 */
8376         }
8377         if (*unixptr == '-') {
8378           *vmsptr++ = '^';
8379           *vmsptr++ = *unixptr++;
8380           vmslen += 2;
8381           dir_start = 0;
8382
8383           /* Now are we done with directories yet? */
8384           if (unixptr >= lastslash) {
8385
8386             /* Watch out for trailing dots */
8387             if (dir_dot != 0) {
8388               vmslen --;
8389               vmsptr--;
8390             }
8391
8392             *vmsptr++ = ']';
8393             vmslen++;
8394             dash_flag = 0;
8395             dir_start = 0;
8396           }
8397         }
8398       }
8399     }
8400
8401     /* All done? */
8402     if (unixptr >= unixend)
8403       break;
8404
8405     /* Normal characters - More EFS work probably needed */
8406     dir_start = 0;
8407     dir_dot = 0;
8408
8409     switch(*unixptr) {
8410     case '/':
8411         /* remove multiple / */
8412         while (unixptr[1] == '/') {
8413            unixptr++;
8414         }
8415         if (unixptr == lastslash) {
8416           /* Watch out for trailing dots */
8417           if (dir_dot != 0) {
8418             vmslen --;
8419             vmsptr--;
8420           }
8421           *vmsptr++ = ']';
8422         }
8423         else {
8424           dir_start = 1;
8425           *vmsptr++ = '.';
8426           dir_dot = 1;
8427
8428           /* To do: Perl expects /.../ to be translated to [...] on VMS */
8429           /* Not needed when VMS is pretending to be UNIX. */
8430
8431         }
8432         dash_flag = 0;
8433         if (unixptr != unixend)
8434           unixptr++;
8435         vmslen++;
8436         break;
8437     case '.':
8438         if ((unixptr < lastdot) || (unixptr < lastslash) ||
8439             (&unixptr[1] == unixend)) {
8440           *vmsptr++ = '^';
8441           *vmsptr++ = '.';
8442           vmslen += 2;
8443           unixptr++;
8444
8445           /* trailing dot ==> '^..' on VMS */
8446           if (unixptr == unixend) {
8447             *vmsptr++ = '.';
8448             vmslen++;
8449             unixptr++;
8450           }
8451           break;
8452         }
8453
8454         *vmsptr++ = *unixptr++;
8455         vmslen ++;
8456         break;
8457     case '"':
8458         if (quoted && (&unixptr[1] == unixend)) {
8459             unixptr++;
8460             break;
8461         }
8462         in_cnt = copy_expand_unix_filename_escape
8463                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8464         vmsptr += out_cnt;
8465         unixptr += in_cnt;
8466         break;
8467     case '~':
8468     case ';':
8469     case '\\':
8470     case '?':
8471     case ' ':
8472     default:
8473         in_cnt = copy_expand_unix_filename_escape
8474                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8475         vmsptr += out_cnt;
8476         unixptr += in_cnt;
8477         break;
8478     }
8479   }
8480
8481   /* Make sure directory is closed */
8482   if (unixptr == lastslash) {
8483     char *vmsptr2;
8484     vmsptr2 = vmsptr - 1;
8485
8486     if (*vmsptr2 != ']') {
8487       *vmsptr2--;
8488
8489       /* directories do not end in a dot bracket */
8490       if (*vmsptr2 == '.') {
8491         vmsptr2--;
8492
8493         /* ^. is allowed */
8494         if (*vmsptr2 != '^') {
8495           vmsptr--; /* back up over the dot */
8496         }
8497       }
8498       *vmsptr++ = ']';
8499     }
8500   }
8501   else {
8502     char *vmsptr2;
8503     /* Add a trailing dot if a file with no extension */
8504     vmsptr2 = vmsptr - 1;
8505     if ((vmslen > 1) &&
8506         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8507         (*vmsptr2 != ')') && (*lastdot != '.') && (*vmsptr2 != ':')) {
8508         *vmsptr++ = '.';
8509         vmslen++;
8510     }
8511   }
8512
8513   *vmsptr = '\0';
8514   return SS$_NORMAL;
8515 }
8516 #endif
8517
8518  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
8519 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
8520 {
8521 char * result;
8522 int utf8_flag;
8523
8524    /* If a UTF8 flag is being passed, honor it */
8525    utf8_flag = 0;
8526    if (utf8_fl != NULL) {
8527      utf8_flag = *utf8_fl;
8528     *utf8_fl = 0;
8529    }
8530
8531    if (utf8_flag) {
8532      /* If there is a possibility of UTF8, then if any UTF8 characters
8533         are present, then they must be converted to VTF-7
8534       */
8535      result = strcpy(rslt, path); /* FIX-ME */
8536    }
8537    else
8538      result = strcpy(rslt, path);
8539
8540    return result;
8541 }
8542
8543
8544
8545 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8546 static char *int_tovmsspec
8547    (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
8548   char *dirend;
8549   char *lastdot;
8550   char *vms_delim;
8551   register char *cp1;
8552   const char *cp2;
8553   unsigned long int infront = 0, hasdir = 1;
8554   int rslt_len;
8555   int no_type_seen;
8556   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8557   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8558
8559   if (vms_debug_fileify) {
8560       if (path == NULL)
8561           fprintf(stderr, "int_tovmsspec: path = NULL\n");
8562       else
8563           fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8564   }
8565
8566   if (path == NULL) {
8567       /* If we fail, we should be setting errno */
8568       set_errno(EINVAL);
8569       set_vaxc_errno(SS$_BADPARAM);
8570       return NULL;
8571   }
8572   rslt_len = VMS_MAXRSS-1;
8573
8574   /* '.' and '..' are "[]" and "[-]" for a quick check */
8575   if (path[0] == '.') {
8576     if (path[1] == '\0') {
8577       strcpy(rslt,"[]");
8578       if (utf8_flag != NULL)
8579         *utf8_flag = 0;
8580       return rslt;
8581     }
8582     else {
8583       if (path[1] == '.' && path[2] == '\0') {
8584         strcpy(rslt,"[-]");
8585         if (utf8_flag != NULL)
8586            *utf8_flag = 0;
8587         return rslt;
8588       }
8589     }
8590   }
8591
8592    /* Posix specifications are now a native VMS format */
8593   /*--------------------------------------------------*/
8594 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8595   if (decc_posix_compliant_pathnames) {
8596     if (strncmp(path,"\"^UP^",5) == 0) {
8597       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8598       return rslt;
8599     }
8600   }
8601 #endif
8602
8603   /* This is really the only way to see if this is already in VMS format */
8604   sts = vms_split_path
8605        (path,
8606         &v_spec,
8607         &v_len,
8608         &r_spec,
8609         &r_len,
8610         &d_spec,
8611         &d_len,
8612         &n_spec,
8613         &n_len,
8614         &e_spec,
8615         &e_len,
8616         &vs_spec,
8617         &vs_len);
8618   if (sts == 0) {
8619     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8620        replacement, because the above parse just took care of most of
8621        what is needed to do vmspath when the specification is already
8622        in VMS format.
8623
8624        And if it is not already, it is easier to do the conversion as
8625        part of this routine than to call this routine and then work on
8626        the result.
8627      */
8628
8629     /* If VMS punctuation was found, it is already VMS format */
8630     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8631       if (utf8_flag != NULL)
8632         *utf8_flag = 0;
8633       strcpy(rslt, path);
8634       if (vms_debug_fileify) {
8635           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8636       }
8637       return rslt;
8638     }
8639     /* Now, what to do with trailing "." cases where there is no
8640        extension?  If this is a UNIX specification, and EFS characters
8641        are enabled, then the trailing "." should be converted to a "^.".
8642        But if this was already a VMS specification, then it should be
8643        left alone.
8644
8645        So in the case of ambiguity, leave the specification alone.
8646      */
8647
8648
8649     /* If there is a possibility of UTF8, then if any UTF8 characters
8650         are present, then they must be converted to VTF-7
8651      */
8652     if (utf8_flag != NULL)
8653       *utf8_flag = 0;
8654     strcpy(rslt, path);
8655     if (vms_debug_fileify) {
8656         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8657     }
8658     return rslt;
8659   }
8660
8661   dirend = strrchr(path,'/');
8662
8663   if (dirend == NULL) {
8664      char *macro_start;
8665      int has_macro;
8666
8667      /* If we get here with no UNIX directory delimiters, then this is
8668         not a complete file specification, either garbage a UNIX glob
8669         specification that can not be converted to a VMS wildcard, or
8670         it a UNIX shell macro.  MakeMaker wants shell macros passed
8671         through AS-IS,
8672
8673         utf8 flag setting needs to be preserved.
8674       */
8675       hasdir = 0;
8676
8677       has_macro = 0;
8678       macro_start = strchr(path,'$');
8679       if (macro_start != NULL) {
8680           if (macro_start[1] == '(') {
8681               has_macro = 1;
8682           }
8683       }
8684       if ((decc_efs_charset == 0) || (has_macro)) {
8685           strcpy(rslt, path);
8686           if (vms_debug_fileify) {
8687               fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8688           }
8689           return rslt;
8690       }
8691   }
8692
8693 /* If EFS charset mode active, handle the conversion */
8694 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8695   if (decc_efs_charset) {
8696     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8697     if (vms_debug_fileify) {
8698         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8699     }
8700     return rslt;
8701   }
8702 #endif
8703
8704   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
8705     if (!*(dirend+2)) dirend +=2;
8706     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8707     if (decc_efs_charset == 0) {
8708       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8709     }
8710   }
8711
8712   cp1 = rslt;
8713   cp2 = path;
8714   lastdot = strrchr(cp2,'.');
8715   if (*cp2 == '/') {
8716     char *trndev;
8717     int islnm, rooted;
8718     STRLEN trnend;
8719
8720     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8721     if (!*(cp2+1)) {
8722       if (decc_disable_posix_root) {
8723         strcpy(rslt,"sys$disk:[000000]");
8724       }
8725       else {
8726         strcpy(rslt,"sys$posix_root:[000000]");
8727       }
8728       if (utf8_flag != NULL)
8729         *utf8_flag = 0;
8730       if (vms_debug_fileify) {
8731           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8732       }
8733       return rslt;
8734     }
8735     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8736     *cp1 = '\0';
8737     trndev = PerlMem_malloc(VMS_MAXRSS);
8738     if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8739     islnm =  simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8740
8741      /* DECC special handling */
8742     if (!islnm) {
8743       if (strcmp(rslt,"bin") == 0) {
8744         strcpy(rslt,"sys$system");
8745         cp1 = rslt + 10;
8746         *cp1 = 0;
8747         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8748       }
8749       else if (strcmp(rslt,"tmp") == 0) {
8750         strcpy(rslt,"sys$scratch");
8751         cp1 = rslt + 11;
8752         *cp1 = 0;
8753         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8754       }
8755       else if (!decc_disable_posix_root) {
8756         strcpy(rslt, "sys$posix_root");
8757         cp1 = rslt + 14;
8758         *cp1 = 0;
8759         cp2 = path;
8760         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8761         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8762       }
8763       else if (strcmp(rslt,"dev") == 0) {
8764         if (strncmp(cp2,"/null", 5) == 0) {
8765           if ((cp2[5] == 0) || (cp2[5] == '/')) {
8766             strcpy(rslt,"NLA0");
8767             cp1 = rslt + 4;
8768             *cp1 = 0;
8769             cp2 = cp2 + 5;
8770             islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8771           }
8772         }
8773       }
8774     }
8775
8776     trnend = islnm ? strlen(trndev) - 1 : 0;
8777     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8778     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8779     /* If the first element of the path is a logical name, determine
8780      * whether it has to be translated so we can add more directories. */
8781     if (!islnm || rooted) {
8782       *(cp1++) = ':';
8783       *(cp1++) = '[';
8784       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8785       else cp2++;
8786     }
8787     else {
8788       if (cp2 != dirend) {
8789         strcpy(rslt,trndev);
8790         cp1 = rslt + trnend;
8791         if (*cp2 != 0) {
8792           *(cp1++) = '.';
8793           cp2++;
8794         }
8795       }
8796       else {
8797         if (decc_disable_posix_root) {
8798           *(cp1++) = ':';
8799           hasdir = 0;
8800         }
8801       }
8802     }
8803     PerlMem_free(trndev);
8804   }
8805   else {
8806     *(cp1++) = '[';
8807     if (*cp2 == '.') {
8808       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8809         cp2 += 2;         /* skip over "./" - it's redundant */
8810         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8811       }
8812       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8813         *(cp1++) = '-';                                 /* "../" --> "-" */
8814         cp2 += 3;
8815       }
8816       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8817                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8818         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8819         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8820         cp2 += 4;
8821       }
8822       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8823         /* Escape the extra dots in EFS file specifications */
8824         *(cp1++) = '^';
8825       }
8826       if (cp2 > dirend) cp2 = dirend;
8827     }
8828     else *(cp1++) = '.';
8829   }
8830   for (; cp2 < dirend; cp2++) {
8831     if (*cp2 == '/') {
8832       if (*(cp2-1) == '/') continue;
8833       if (*(cp1-1) != '.') *(cp1++) = '.';
8834       infront = 0;
8835     }
8836     else if (!infront && *cp2 == '.') {
8837       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8838       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8839       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8840         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8841         else if (*(cp1-2) == '[') *(cp1-1) = '-';
8842         else {  /* back up over previous directory name */
8843           cp1--;
8844           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
8845           if (*(cp1-1) == '[') {
8846             memcpy(cp1,"000000.",7);
8847             cp1 += 7;
8848           }
8849         }
8850         cp2 += 2;
8851         if (cp2 == dirend) break;
8852       }
8853       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8854                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8855         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8856         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8857         if (!*(cp2+3)) {
8858           *(cp1++) = '.';  /* Simulate trailing '/' */
8859           cp2 += 2;  /* for loop will incr this to == dirend */
8860         }
8861         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8862       }
8863       else {
8864         if (decc_efs_charset == 0)
8865           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8866         else {
8867           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
8868           *(cp1++) = '.';
8869         }
8870       }
8871     }
8872     else {
8873       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
8874       if (*cp2 == '.') {
8875         if (decc_efs_charset == 0)
8876           *(cp1++) = '_';
8877         else {
8878           *(cp1++) = '^';
8879           *(cp1++) = '.';
8880         }
8881       }
8882       else                  *(cp1++) =  *cp2;
8883       infront = 1;
8884     }
8885   }
8886   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8887   if (hasdir) *(cp1++) = ']';
8888   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
8889   /* fixme for ODS5 */
8890   no_type_seen = 0;
8891   if (cp2 > lastdot)
8892     no_type_seen = 1;
8893   while (*cp2) {
8894     switch(*cp2) {
8895     case '?':
8896         if (decc_efs_charset == 0)
8897           *(cp1++) = '%';
8898         else
8899           *(cp1++) = '?';
8900         cp2++;
8901     case ' ':
8902         *(cp1)++ = '^';
8903         *(cp1)++ = '_';
8904         cp2++;
8905         break;
8906     case '.':
8907         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8908             decc_readdir_dropdotnotype) {
8909           *(cp1)++ = '^';
8910           *(cp1)++ = '.';
8911           cp2++;
8912
8913           /* trailing dot ==> '^..' on VMS */
8914           if (*cp2 == '\0') {
8915             *(cp1++) = '.';
8916             no_type_seen = 0;
8917           }
8918         }
8919         else {
8920           *(cp1++) = *(cp2++);
8921           no_type_seen = 0;
8922         }
8923         break;
8924     case '$':
8925          /* This could be a macro to be passed through */
8926         *(cp1++) = *(cp2++);
8927         if (*cp2 == '(') {
8928         const char * save_cp2;
8929         char * save_cp1;
8930         int is_macro;
8931
8932             /* paranoid check */
8933             save_cp2 = cp2;
8934             save_cp1 = cp1;
8935             is_macro = 0;
8936
8937             /* Test through */
8938             *(cp1++) = *(cp2++);
8939             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8940                 *(cp1++) = *(cp2++);
8941                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8942                     *(cp1++) = *(cp2++);
8943                 }
8944                 if (*cp2 == ')') {
8945                     *(cp1++) = *(cp2++);
8946                     is_macro = 1;
8947                 }
8948             }
8949             if (is_macro == 0) {
8950                 /* Not really a macro - never mind */
8951                 cp2 = save_cp2;
8952                 cp1 = save_cp1;
8953             }
8954         }
8955         break;
8956     case '\"':
8957     case '~':
8958     case '`':
8959     case '!':
8960     case '#':
8961     case '%':
8962     case '^':
8963         /* Don't escape again if following character is
8964          * already something we escape.
8965          */
8966         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8967             *(cp1++) = *(cp2++);
8968             break;
8969         }
8970         /* But otherwise fall through and escape it. */
8971     case '&':
8972     case '(':
8973     case ')':
8974     case '=':
8975     case '+':
8976     case '\'':
8977     case '@':
8978     case '[':
8979     case ']':
8980     case '{':
8981     case '}':
8982     case ':':
8983     case '\\':
8984     case '|':
8985     case '<':
8986     case '>':
8987         *(cp1++) = '^';
8988         *(cp1++) = *(cp2++);
8989         break;
8990     case ';':
8991         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8992          * which is wrong.  UNIX notation should be ".dir." unless
8993          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8994          * changing this behavior could break more things at this time.
8995          * efs character set effectively does not allow "." to be a version
8996          * delimiter as a further complication about changing this.
8997          */
8998         if (decc_filename_unix_report != 0) {
8999           *(cp1++) = '^';
9000         }
9001         *(cp1++) = *(cp2++);
9002         break;
9003     default:
9004         *(cp1++) = *(cp2++);
9005     }
9006   }
9007   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
9008   char *lcp1;
9009     lcp1 = cp1;
9010     lcp1--;
9011      /* Fix me for "^]", but that requires making sure that you do
9012       * not back up past the start of the filename
9013       */
9014     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
9015       *cp1++ = '.';
9016   }
9017   *cp1 = '\0';
9018
9019   if (utf8_flag != NULL)
9020     *utf8_flag = 0;
9021   if (vms_debug_fileify) {
9022       fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
9023   }
9024   return rslt;
9025
9026 }  /* end of int_tovmsspec() */
9027
9028
9029 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
9030 static char *mp_do_tovmsspec
9031    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
9032   static char __tovmsspec_retbuf[VMS_MAXRSS];
9033     char * vmsspec, *ret_spec, *ret_buf;
9034
9035     vmsspec = NULL;
9036     ret_buf = buf;
9037     if (ret_buf == NULL) {
9038         if (ts) {
9039             Newx(vmsspec, VMS_MAXRSS, char);
9040             if (vmsspec == NULL)
9041                 _ckvmssts(SS$_INSFMEM);
9042             ret_buf = vmsspec;
9043         } else {
9044             ret_buf = __tovmsspec_retbuf;
9045         }
9046     }
9047
9048     ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
9049
9050     if (ret_spec == NULL) {
9051        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
9052        if (vmsspec)
9053            Safefree(vmsspec);
9054     }
9055
9056     return ret_spec;
9057
9058 }  /* end of mp_do_tovmsspec() */
9059 /*}}}*/
9060 /* External entry points */
9061 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
9062   { return do_tovmsspec(path,buf,0,NULL); }
9063 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
9064   { return do_tovmsspec(path,buf,1,NULL); }
9065 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9066   { return do_tovmsspec(path,buf,0,utf8_fl); }
9067 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9068   { return do_tovmsspec(path,buf,1,utf8_fl); }
9069
9070 /*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
9071 /* Internal routine for use with out an explict context present */
9072 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl) {
9073
9074     char * ret_spec, *pathified;
9075
9076     if (path == NULL)
9077         return NULL;
9078
9079     pathified = PerlMem_malloc(VMS_MAXRSS);
9080     if (pathified == NULL)
9081         _ckvmssts_noperl(SS$_INSFMEM);
9082
9083     ret_spec = int_pathify_dirspec(path, pathified);
9084
9085     if (ret_spec == NULL) {
9086         PerlMem_free(pathified);
9087         return NULL;
9088     }
9089
9090     ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
9091
9092     PerlMem_free(pathified);
9093     return ret_spec;
9094
9095 }
9096
9097 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
9098 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
9099   static char __tovmspath_retbuf[VMS_MAXRSS];
9100   int vmslen;
9101   char *pathified, *vmsified, *cp;
9102
9103   if (path == NULL) return NULL;
9104   pathified = PerlMem_malloc(VMS_MAXRSS);
9105   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
9106   if (int_pathify_dirspec(path, pathified) == NULL) {
9107     PerlMem_free(pathified);
9108     return NULL;
9109   }
9110
9111   vmsified = NULL;
9112   if (buf == NULL)
9113      Newx(vmsified, VMS_MAXRSS, char);
9114   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
9115     PerlMem_free(pathified);
9116     if (vmsified) Safefree(vmsified);
9117     return NULL;
9118   }
9119   PerlMem_free(pathified);
9120   if (buf) {
9121     return buf;
9122   }
9123   else if (ts) {
9124     vmslen = strlen(vmsified);
9125     Newx(cp,vmslen+1,char);
9126     memcpy(cp,vmsified,vmslen);
9127     cp[vmslen] = '\0';
9128     Safefree(vmsified);
9129     return cp;
9130   }
9131   else {
9132     strcpy(__tovmspath_retbuf,vmsified);
9133     Safefree(vmsified);
9134     return __tovmspath_retbuf;
9135   }
9136
9137 }  /* end of do_tovmspath() */
9138 /*}}}*/
9139 /* External entry points */
9140 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
9141   { return do_tovmspath(path,buf,0, NULL); }
9142 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
9143   { return do_tovmspath(path,buf,1, NULL); }
9144 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
9145   { return do_tovmspath(path,buf,0,utf8_fl); }
9146 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
9147   { return do_tovmspath(path,buf,1,utf8_fl); }
9148
9149
9150 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
9151 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
9152   static char __tounixpath_retbuf[VMS_MAXRSS];
9153   int unixlen;
9154   char *pathified, *unixified, *cp;
9155
9156   if (path == NULL) return NULL;
9157   pathified = PerlMem_malloc(VMS_MAXRSS);
9158   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
9159   if (int_pathify_dirspec(path, pathified) == NULL) {
9160     PerlMem_free(pathified);
9161     return NULL;
9162   }
9163
9164   unixified = NULL;
9165   if (buf == NULL) {
9166       Newx(unixified, VMS_MAXRSS, char);
9167   }
9168   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
9169     PerlMem_free(pathified);
9170     if (unixified) Safefree(unixified);
9171     return NULL;
9172   }
9173   PerlMem_free(pathified);
9174   if (buf) {
9175     return buf;
9176   }
9177   else if (ts) {
9178     unixlen = strlen(unixified);
9179     Newx(cp,unixlen+1,char);
9180     memcpy(cp,unixified,unixlen);
9181     cp[unixlen] = '\0';
9182     Safefree(unixified);
9183     return cp;
9184   }
9185   else {
9186     strcpy(__tounixpath_retbuf,unixified);
9187     Safefree(unixified);
9188     return __tounixpath_retbuf;
9189   }
9190
9191 }  /* end of do_tounixpath() */
9192 /*}}}*/
9193 /* External entry points */
9194 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
9195   { return do_tounixpath(path,buf,0,NULL); }
9196 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
9197   { return do_tounixpath(path,buf,1,NULL); }
9198 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9199   { return do_tounixpath(path,buf,0,utf8_fl); }
9200 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9201   { return do_tounixpath(path,buf,1,utf8_fl); }
9202
9203 /*
9204  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
9205  *
9206  *****************************************************************************
9207  *                                                                           *
9208  *  Copyright (C) 1989-1994, 2007 by                                         *
9209  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
9210  *                                                                           *
9211  *  Permission is hereby granted for the reproduction of this software       *
9212  *  on condition that this copyright notice is included in source            *
9213  *  distributions of the software.  The code may be modified and             *
9214  *  distributed under the same terms as Perl itself.                         *
9215  *                                                                           *
9216  *  27-Aug-1994 Modified for inclusion in perl5                              *
9217  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
9218  *****************************************************************************
9219  */
9220
9221 /*
9222  * getredirection() is intended to aid in porting C programs
9223  * to VMS (Vax-11 C).  The native VMS environment does not support
9224  * '>' and '<' I/O redirection, or command line wild card expansion,
9225  * or a command line pipe mechanism using the '|' AND background
9226  * command execution '&'.  All of these capabilities are provided to any
9227  * C program which calls this procedure as the first thing in the
9228  * main program.
9229  * The piping mechanism will probably work with almost any 'filter' type
9230  * of program.  With suitable modification, it may useful for other
9231  * portability problems as well.
9232  *
9233  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
9234  */
9235 struct list_item
9236     {
9237     struct list_item *next;
9238     char *value;
9239     };
9240
9241 static void add_item(struct list_item **head,
9242                      struct list_item **tail,
9243                      char *value,
9244                      int *count);
9245
9246 static void mp_expand_wild_cards(pTHX_ char *item,
9247                                 struct list_item **head,
9248                                 struct list_item **tail,
9249                                 int *count);
9250
9251 static int background_process(pTHX_ int argc, char **argv);
9252
9253 static void pipe_and_fork(pTHX_ char **cmargv);
9254
9255 /*{{{ void getredirection(int *ac, char ***av)*/
9256 static void
9257 mp_getredirection(pTHX_ int *ac, char ***av)
9258 /*
9259  * Process vms redirection arg's.  Exit if any error is seen.
9260  * If getredirection() processes an argument, it is erased
9261  * from the vector.  getredirection() returns a new argc and argv value.
9262  * In the event that a background command is requested (by a trailing "&"),
9263  * this routine creates a background subprocess, and simply exits the program.
9264  *
9265  * Warning: do not try to simplify the code for vms.  The code
9266  * presupposes that getredirection() is called before any data is
9267  * read from stdin or written to stdout.
9268  *
9269  * Normal usage is as follows:
9270  *
9271  *      main(argc, argv)
9272  *      int             argc;
9273  *      char            *argv[];
9274  *      {
9275  *              getredirection(&argc, &argv);
9276  *      }
9277  */
9278 {
9279     int                 argc = *ac;     /* Argument Count         */
9280     char                **argv = *av;   /* Argument Vector        */
9281     char                *ap;            /* Argument pointer       */
9282     int                 j;              /* argv[] index           */
9283     int                 item_count = 0; /* Count of Items in List */
9284     struct list_item    *list_head = 0; /* First Item in List       */
9285     struct list_item    *list_tail;     /* Last Item in List        */
9286     char                *in = NULL;     /* Input File Name          */
9287     char                *out = NULL;    /* Output File Name         */
9288     char                *outmode = "w"; /* Mode to Open Output File */
9289     char                *err = NULL;    /* Error File Name          */
9290     char                *errmode = "w"; /* Mode to Open Error File  */
9291     int                 cmargc = 0;     /* Piped Command Arg Count  */
9292     char                **cmargv = NULL;/* Piped Command Arg Vector */
9293
9294     /*
9295      * First handle the case where the last thing on the line ends with
9296      * a '&'.  This indicates the desire for the command to be run in a
9297      * subprocess, so we satisfy that desire.
9298      */
9299     ap = argv[argc-1];
9300     if (0 == strcmp("&", ap))
9301        exit(background_process(aTHX_ --argc, argv));
9302     if (*ap && '&' == ap[strlen(ap)-1])
9303         {
9304         ap[strlen(ap)-1] = '\0';
9305        exit(background_process(aTHX_ argc, argv));
9306         }
9307     /*
9308      * Now we handle the general redirection cases that involve '>', '>>',
9309      * '<', and pipes '|'.
9310      */
9311     for (j = 0; j < argc; ++j)
9312         {
9313         if (0 == strcmp("<", argv[j]))
9314             {
9315             if (j+1 >= argc)
9316                 {
9317                 fprintf(stderr,"No input file after < on command line");
9318                 exit(LIB$_WRONUMARG);
9319                 }
9320             in = argv[++j];
9321             continue;
9322             }
9323         if ('<' == *(ap = argv[j]))
9324             {
9325             in = 1 + ap;
9326             continue;
9327             }
9328         if (0 == strcmp(">", ap))
9329             {
9330             if (j+1 >= argc)
9331                 {
9332                 fprintf(stderr,"No output file after > on command line");
9333                 exit(LIB$_WRONUMARG);
9334                 }
9335             out = argv[++j];
9336             continue;
9337             }
9338         if ('>' == *ap)
9339             {
9340             if ('>' == ap[1])
9341                 {
9342                 outmode = "a";
9343                 if ('\0' == ap[2])
9344                     out = argv[++j];
9345                 else
9346                     out = 2 + ap;
9347                 }
9348             else
9349                 out = 1 + ap;
9350             if (j >= argc)
9351                 {
9352                 fprintf(stderr,"No output file after > or >> on command line");
9353                 exit(LIB$_WRONUMARG);
9354                 }
9355             continue;
9356             }
9357         if (('2' == *ap) && ('>' == ap[1]))
9358             {
9359             if ('>' == ap[2])
9360                 {
9361                 errmode = "a";
9362                 if ('\0' == ap[3])
9363                     err = argv[++j];
9364                 else
9365                     err = 3 + ap;
9366                 }
9367             else
9368                 if ('\0' == ap[2])
9369                     err = argv[++j];
9370                 else
9371                     err = 2 + ap;
9372             if (j >= argc)
9373                 {
9374                 fprintf(stderr,"No output file after 2> or 2>> on command line");
9375                 exit(LIB$_WRONUMARG);
9376                 }
9377             continue;
9378             }
9379         if (0 == strcmp("|", argv[j]))
9380             {
9381             if (j+1 >= argc)
9382                 {
9383                 fprintf(stderr,"No command into which to pipe on command line");
9384                 exit(LIB$_WRONUMARG);
9385                 }
9386             cmargc = argc-(j+1);
9387             cmargv = &argv[j+1];
9388             argc = j;
9389             continue;
9390             }
9391         if ('|' == *(ap = argv[j]))
9392             {
9393             ++argv[j];
9394             cmargc = argc-j;
9395             cmargv = &argv[j];
9396             argc = j;
9397             continue;
9398             }
9399         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9400         }
9401     /*
9402      * Allocate and fill in the new argument vector, Some Unix's terminate
9403      * the list with an extra null pointer.
9404      */
9405     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9406     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9407     *av = argv;
9408     for (j = 0; j < item_count; ++j, list_head = list_head->next)
9409         argv[j] = list_head->value;
9410     *ac = item_count;
9411     if (cmargv != NULL)
9412         {
9413         if (out != NULL)
9414             {
9415             fprintf(stderr,"'|' and '>' may not both be specified on command line");
9416             exit(LIB$_INVARGORD);
9417             }
9418         pipe_and_fork(aTHX_ cmargv);
9419         }
9420
9421     /* Check for input from a pipe (mailbox) */
9422
9423     if (in == NULL && 1 == isapipe(0))
9424         {
9425         char mbxname[L_tmpnam];
9426         long int bufsize;
9427         long int dvi_item = DVI$_DEVBUFSIZ;
9428         $DESCRIPTOR(mbxnam, "");
9429         $DESCRIPTOR(mbxdevnam, "");
9430
9431         /* Input from a pipe, reopen it in binary mode to disable       */
9432         /* carriage control processing.                                 */
9433
9434         fgetname(stdin, mbxname, 1);
9435         mbxnam.dsc$a_pointer = mbxname;
9436         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9437         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9438         mbxdevnam.dsc$a_pointer = mbxname;
9439         mbxdevnam.dsc$w_length = sizeof(mbxname);
9440         dvi_item = DVI$_DEVNAM;
9441         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9442         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9443         set_errno(0);
9444         set_vaxc_errno(1);
9445         freopen(mbxname, "rb", stdin);
9446         if (errno != 0)
9447             {
9448             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9449             exit(vaxc$errno);
9450             }
9451         }
9452     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9453         {
9454         fprintf(stderr,"Can't open input file %s as stdin",in);
9455         exit(vaxc$errno);
9456         }
9457     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9458         {
9459         fprintf(stderr,"Can't open output file %s as stdout",out);
9460         exit(vaxc$errno);
9461         }
9462         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
9463
9464     if (err != NULL) {
9465         if (strcmp(err,"&1") == 0) {
9466             dup2(fileno(stdout), fileno(stderr));
9467             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
9468         } else {
9469         FILE *tmperr;
9470         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9471             {
9472             fprintf(stderr,"Can't open error file %s as stderr",err);
9473             exit(vaxc$errno);
9474             }
9475             fclose(tmperr);
9476            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9477                 {
9478                 exit(vaxc$errno);
9479                 }
9480             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
9481         }
9482         }
9483 #ifdef ARGPROC_DEBUG
9484     PerlIO_printf(Perl_debug_log, "Arglist:\n");
9485     for (j = 0; j < *ac;  ++j)
9486         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9487 #endif
9488    /* Clear errors we may have hit expanding wildcards, so they don't
9489       show up in Perl's $! later */
9490    set_errno(0); set_vaxc_errno(1);
9491 }  /* end of getredirection() */
9492 /*}}}*/
9493
9494 static void add_item(struct list_item **head,
9495                      struct list_item **tail,
9496                      char *value,
9497                      int *count)
9498 {
9499     if (*head == 0)
9500         {
9501         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9502         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9503         *tail = *head;
9504         }
9505     else {
9506         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9507         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9508         *tail = (*tail)->next;
9509         }
9510     (*tail)->value = value;
9511     ++(*count);
9512 }
9513
9514 static void mp_expand_wild_cards(pTHX_ char *item,
9515                               struct list_item **head,
9516                               struct list_item **tail,
9517                               int *count)
9518 {
9519 int expcount = 0;
9520 unsigned long int context = 0;
9521 int isunix = 0;
9522 int item_len = 0;
9523 char *had_version;
9524 char *had_device;
9525 int had_directory;
9526 char *devdir,*cp;
9527 char *vmsspec;
9528 $DESCRIPTOR(filespec, "");
9529 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9530 $DESCRIPTOR(resultspec, "");
9531 unsigned long int lff_flags = 0;
9532 int sts;
9533 int rms_sts;
9534
9535 #ifdef VMS_LONGNAME_SUPPORT
9536     lff_flags = LIB$M_FIL_LONG_NAMES;
9537 #endif
9538
9539     for (cp = item; *cp; cp++) {
9540         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9541         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9542     }
9543     if (!*cp || isspace(*cp))
9544         {
9545         add_item(head, tail, item, count);
9546         return;
9547         }
9548     else
9549         {
9550      /* "double quoted" wild card expressions pass as is */
9551      /* From DCL that means using e.g.:                  */
9552      /* perl program """perl.*"""                        */
9553      item_len = strlen(item);
9554      if ( '"' == *item && '"' == item[item_len-1] )
9555        {
9556        item++;
9557        item[item_len-2] = '\0';
9558        add_item(head, tail, item, count);
9559        return;
9560        }
9561      }
9562     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9563     resultspec.dsc$b_class = DSC$K_CLASS_D;
9564     resultspec.dsc$a_pointer = NULL;
9565     vmsspec = PerlMem_malloc(VMS_MAXRSS);
9566     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9567     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9568       filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9569     if (!isunix || !filespec.dsc$a_pointer)
9570       filespec.dsc$a_pointer = item;
9571     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9572     /*
9573      * Only return version specs, if the caller specified a version
9574      */
9575     had_version = strchr(item, ';');
9576     /*
9577      * Only return device and directory specs, if the caller specifed either.
9578      */
9579     had_device = strchr(item, ':');
9580     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9581
9582     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9583                                  (&filespec, &resultspec, &context,
9584                                   &defaultspec, 0, &rms_sts, &lff_flags)))
9585         {
9586         char *string;
9587         char *c;
9588
9589         string = PerlMem_malloc(resultspec.dsc$w_length+1);
9590         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9591         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
9592         string[resultspec.dsc$w_length] = '\0';
9593         if (NULL == had_version)
9594             *(strrchr(string, ';')) = '\0';
9595         if ((!had_directory) && (had_device == NULL))
9596             {
9597             if (NULL == (devdir = strrchr(string, ']')))
9598                 devdir = strrchr(string, '>');
9599             strcpy(string, devdir + 1);
9600             }
9601         /*
9602          * Be consistent with what the C RTL has already done to the rest of
9603          * the argv items and lowercase all of these names.
9604          */
9605         if (!decc_efs_case_preserve) {
9606             for (c = string; *c; ++c)
9607             if (isupper(*c))
9608                 *c = tolower(*c);
9609         }
9610         if (isunix) trim_unixpath(string,item,1);
9611         add_item(head, tail, string, count);
9612         ++expcount;
9613     }
9614     PerlMem_free(vmsspec);
9615     if (sts != RMS$_NMF)
9616         {
9617         set_vaxc_errno(sts);
9618         switch (sts)
9619             {
9620             case RMS$_FNF: case RMS$_DNF:
9621                 set_errno(ENOENT); break;
9622             case RMS$_DIR:
9623                 set_errno(ENOTDIR); break;
9624             case RMS$_DEV:
9625                 set_errno(ENODEV); break;
9626             case RMS$_FNM: case RMS$_SYN:
9627                 set_errno(EINVAL); break;
9628             case RMS$_PRV:
9629                 set_errno(EACCES); break;
9630             default:
9631                 _ckvmssts_noperl(sts);
9632             }
9633         }
9634     if (expcount == 0)
9635         add_item(head, tail, item, count);
9636     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9637     _ckvmssts_noperl(lib$find_file_end(&context));
9638 }
9639
9640 static int child_st[2];/* Event Flag set when child process completes   */
9641
9642 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
9643
9644 static unsigned long int exit_handler(int *status)
9645 {
9646 short iosb[4];
9647
9648     if (0 == child_st[0])
9649         {
9650 #ifdef ARGPROC_DEBUG
9651         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
9652 #endif
9653         fflush(stdout);     /* Have to flush pipe for binary data to    */
9654                             /* terminate properly -- <tp@mccall.com>    */
9655         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
9656         sys$dassgn(child_chan);
9657         fclose(stdout);
9658         sys$synch(0, child_st);
9659         }
9660     return(1);
9661 }
9662
9663 static void sig_child(int chan)
9664 {
9665 #ifdef ARGPROC_DEBUG
9666     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
9667 #endif
9668     if (child_st[0] == 0)
9669         child_st[0] = 1;
9670 }
9671
9672 static struct exit_control_block exit_block =
9673     {
9674     0,
9675     exit_handler,
9676     1,
9677     &exit_block.exit_status,
9678     0
9679     };
9680
9681 static void
9682 pipe_and_fork(pTHX_ char **cmargv)
9683 {
9684     PerlIO *fp;
9685     struct dsc$descriptor_s *vmscmd;
9686     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9687     int sts, j, l, ismcr, quote, tquote = 0;
9688
9689     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9690     vms_execfree(vmscmd);
9691
9692     j = l = 0;
9693     p = subcmd;
9694     q = cmargv[0];
9695     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
9696               && toupper(*(q+2)) == 'R' && !*(q+3);
9697
9698     while (q && l < MAX_DCL_LINE_LENGTH) {
9699         if (!*q) {
9700             if (j > 0 && quote) {
9701                 *p++ = '"';
9702                 l++;
9703             }
9704             q = cmargv[++j];
9705             if (q) {
9706                 if (ismcr && j > 1) quote = 1;
9707                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
9708                 *p++ = ' ';
9709                 l++;
9710                 if (quote || tquote) {
9711                     *p++ = '"';
9712                     l++;
9713                 }
9714             }
9715         } else {
9716             if ((quote||tquote) && *q == '"') {
9717                 *p++ = '"';
9718                 l++;
9719             }
9720             *p++ = *q++;
9721             l++;
9722         }
9723     }
9724     *p = '\0';
9725
9726     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9727     if (fp == NULL) {
9728         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9729     }
9730 }
9731
9732 static int background_process(pTHX_ int argc, char **argv)
9733 {
9734 char command[MAX_DCL_SYMBOL + 1] = "$";
9735 $DESCRIPTOR(value, "");
9736 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9737 static $DESCRIPTOR(null, "NLA0:");
9738 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9739 char pidstring[80];
9740 $DESCRIPTOR(pidstr, "");
9741 int pid;
9742 unsigned long int flags = 17, one = 1, retsts;
9743 int len;
9744
9745     strcat(command, argv[0]);
9746     len = strlen(command);
9747     while (--argc && (len < MAX_DCL_SYMBOL))
9748         {
9749         strcat(command, " \"");
9750         strcat(command, *(++argv));
9751         strcat(command, "\"");
9752         len = strlen(command);
9753         }
9754     value.dsc$a_pointer = command;
9755     value.dsc$w_length = strlen(value.dsc$a_pointer);
9756     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9757     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9758     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9759         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9760     }
9761     else {
9762         _ckvmssts_noperl(retsts);
9763     }
9764 #ifdef ARGPROC_DEBUG
9765     PerlIO_printf(Perl_debug_log, "%s\n", command);
9766 #endif
9767     sprintf(pidstring, "%08X", pid);
9768     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9769     pidstr.dsc$a_pointer = pidstring;
9770     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9771     lib$set_symbol(&pidsymbol, &pidstr);
9772     return(SS$_NORMAL);
9773 }
9774 /*}}}*/
9775 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9776
9777
9778 /* OS-specific initialization at image activation (not thread startup) */
9779 /* Older VAXC header files lack these constants */
9780 #ifndef JPI$_RIGHTS_SIZE
9781 #  define JPI$_RIGHTS_SIZE 817
9782 #endif
9783 #ifndef KGB$M_SUBSYSTEM
9784 #  define KGB$M_SUBSYSTEM 0x8
9785 #endif
9786
9787 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9788
9789 /*{{{void vms_image_init(int *, char ***)*/
9790 void
9791 vms_image_init(int *argcp, char ***argvp)
9792 {
9793   int status;
9794   char eqv[LNM$C_NAMLENGTH+1] = "";
9795   unsigned int len, tabct = 8, tabidx = 0;
9796   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9797   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9798   unsigned short int dummy, rlen;
9799   struct dsc$descriptor_s **tabvec;
9800 #if defined(PERL_IMPLICIT_CONTEXT)
9801   pTHX = NULL;
9802 #endif
9803   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
9804                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
9805                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9806                                  {          0,                0,    0,      0} };
9807
9808 #ifdef KILL_BY_SIGPRC
9809     Perl_csighandler_init();
9810 #endif
9811
9812 #if __CRTL_VER >= 70300000 && !defined(__VAX)
9813     /* This was moved from the pre-image init handler because on threaded */
9814     /* Perl it was always returning 0 for the default value. */
9815     status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9816     if (status > 0) {
9817         int s;
9818         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9819         if (s > 0) {
9820             int initial;
9821             initial = decc$feature_get_value(s, 4);
9822             if (initial > 0) {
9823                 /* initial is: 0 if nothing has set the feature */
9824                 /*            -1 if initialized to default */
9825                 /*             1 if set by logical name */
9826                 /*             2 if set by decc$feature_set_value */
9827                 decc_disable_posix_root = decc$feature_get_value(s, 1);
9828
9829                 /* If the value is not valid, force the feature off */
9830                 if (decc_disable_posix_root < 0) {
9831                     decc$feature_set_value(s, 1, 1);
9832                     decc_disable_posix_root = 1;
9833                 }
9834             }
9835             else {
9836                 /* Nothing has asked for it explicitly, so use our own default. */
9837                 decc_disable_posix_root = 1;
9838                 decc$feature_set_value(s, 1, 1);
9839             }
9840         }
9841     }
9842 #endif
9843
9844   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9845   _ckvmssts_noperl(iosb[0]);
9846   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9847     if (iprv[i]) {           /* Running image installed with privs? */
9848       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
9849       will_taint = TRUE;
9850       break;
9851     }
9852   }
9853   /* Rights identifiers might trigger tainting as well. */
9854   if (!will_taint && (rlen || rsz)) {
9855     while (rlen < rsz) {
9856       /* We didn't get all the identifiers on the first pass.  Allocate a
9857        * buffer much larger than $GETJPI wants (rsz is size in bytes that
9858        * were needed to hold all identifiers at time of last call; we'll
9859        * allocate that many unsigned long ints), and go back and get 'em.
9860        * If it gave us less than it wanted to despite ample buffer space,
9861        * something's broken.  Is your system missing a system identifier?
9862        */
9863       if (rsz <= jpilist[1].buflen) {
9864          /* Perl_croak accvios when used this early in startup. */
9865          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9866                          rsz, (unsigned long) jpilist[1].buflen,
9867                          "Check your rights database for corruption.\n");
9868          exit(SS$_ABORT);
9869       }
9870       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9871       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9872       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9873       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9874       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9875       _ckvmssts_noperl(iosb[0]);
9876     }
9877     mask = jpilist[1].bufadr;
9878     /* Check attribute flags for each identifier (2nd longword); protected
9879      * subsystem identifiers trigger tainting.
9880      */
9881     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9882       if (mask[i] & KGB$M_SUBSYSTEM) {
9883         will_taint = TRUE;
9884         break;
9885       }
9886     }
9887     if (mask != rlst) PerlMem_free(mask);
9888   }
9889
9890   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9891    * logical, some versions of the CRTL will add a phanthom /000000/
9892    * directory.  This needs to be removed.
9893    */
9894   if (decc_filename_unix_report) {
9895   char * zeros;
9896   int ulen;
9897     ulen = strlen(argvp[0][0]);
9898     if (ulen > 7) {
9899       zeros = strstr(argvp[0][0], "/000000/");
9900       if (zeros != NULL) {
9901         int mlen;
9902         mlen = ulen - (zeros - argvp[0][0]) - 7;
9903         memmove(zeros, &zeros[7], mlen);
9904         ulen = ulen - 7;
9905         argvp[0][0][ulen] = '\0';
9906       }
9907     }
9908     /* It also may have a trailing dot that needs to be removed otherwise
9909      * it will be converted to VMS mode incorrectly.
9910      */
9911     ulen--;
9912     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9913       argvp[0][0][ulen] = '\0';
9914   }
9915
9916   /* We need to use this hack to tell Perl it should run with tainting,
9917    * since its tainting flag may be part of the PL_curinterp struct, which
9918    * hasn't been allocated when vms_image_init() is called.
9919    */
9920   if (will_taint) {
9921     char **newargv, **oldargv;
9922     oldargv = *argvp;
9923     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9924     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9925     newargv[0] = oldargv[0];
9926     newargv[1] = PerlMem_malloc(3 * sizeof(char));
9927     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9928     strcpy(newargv[1], "-T");
9929     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9930     (*argcp)++;
9931     newargv[*argcp] = NULL;
9932     /* We orphan the old argv, since we don't know where it's come from,
9933      * so we don't know how to free it.
9934      */
9935     *argvp = newargv;
9936   }
9937   else {  /* Did user explicitly request tainting? */
9938     int i;
9939     char *cp, **av = *argvp;
9940     for (i = 1; i < *argcp; i++) {
9941       if (*av[i] != '-') break;
9942       for (cp = av[i]+1; *cp; cp++) {
9943         if (*cp == 'T') { will_taint = 1; break; }
9944         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9945                   strchr("DFIiMmx",*cp)) break;
9946       }
9947       if (will_taint) break;
9948     }
9949   }
9950
9951   for (tabidx = 0;
9952        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9953        tabidx++) {
9954     if (!tabidx) {
9955       tabvec = (struct dsc$descriptor_s **)
9956             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9957       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9958     }
9959     else if (tabidx >= tabct) {
9960       tabct += 8;
9961       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9962       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9963     }
9964     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9965     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9966     tabvec[tabidx]->dsc$w_length  = 0;
9967     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9968     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
9969     tabvec[tabidx]->dsc$a_pointer = NULL;
9970     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9971   }
9972   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9973
9974   getredirection(argcp,argvp);
9975 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9976   {
9977 # include <reentrancy.h>
9978   decc$set_reentrancy(C$C_MULTITHREAD);
9979   }
9980 #endif
9981   return;
9982 }
9983 /*}}}*/
9984
9985
9986 /* trim_unixpath()
9987  * Trim Unix-style prefix off filespec, so it looks like what a shell
9988  * glob expansion would return (i.e. from specified prefix on, not
9989  * full path).  Note that returned filespec is Unix-style, regardless
9990  * of whether input filespec was VMS-style or Unix-style.
9991  *
9992  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9993  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9994  * vector of options; at present, only bit 0 is used, and if set tells
9995  * trim unixpath to try the current default directory as a prefix when
9996  * presented with a possibly ambiguous ... wildcard.
9997  *
9998  * Returns !=0 on success, with trimmed filespec replacing contents of
9999  * fspec, and 0 on failure, with contents of fpsec unchanged.
10000  */
10001 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
10002 int
10003 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
10004 {
10005   char *unixified, *unixwild,
10006        *template, *base, *end, *cp1, *cp2;
10007   register int tmplen, reslen = 0, dirs = 0;
10008
10009   if (!wildspec || !fspec) return 0;
10010
10011   unixwild = PerlMem_malloc(VMS_MAXRSS);
10012   if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10013   template = unixwild;
10014   if (strpbrk(wildspec,"]>:") != NULL) {
10015     if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
10016         PerlMem_free(unixwild);
10017         return 0;
10018     }
10019   }
10020   else {
10021     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
10022     unixwild[VMS_MAXRSS-1] = 0;
10023   }
10024   unixified = PerlMem_malloc(VMS_MAXRSS);
10025   if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10026   if (strpbrk(fspec,"]>:") != NULL) {
10027     if (int_tounixspec(fspec, unixified, NULL) == NULL) {
10028         PerlMem_free(unixwild);
10029         PerlMem_free(unixified);
10030         return 0;
10031     }
10032     else base = unixified;
10033     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
10034      * check to see that final result fits into (isn't longer than) fspec */
10035     reslen = strlen(fspec);
10036   }
10037   else base = fspec;
10038
10039   /* No prefix or absolute path on wildcard, so nothing to remove */
10040   if (!*template || *template == '/') {
10041     PerlMem_free(unixwild);
10042     if (base == fspec) {
10043         PerlMem_free(unixified);
10044         return 1;
10045     }
10046     tmplen = strlen(unixified);
10047     if (tmplen > reslen) {
10048         PerlMem_free(unixified);
10049         return 0;  /* not enough space */
10050     }
10051     /* Copy unixified resultant, including trailing NUL */
10052     memmove(fspec,unixified,tmplen+1);
10053     PerlMem_free(unixified);
10054     return 1;
10055   }
10056
10057   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
10058   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
10059     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
10060     for (cp1 = end ;cp1 >= base; cp1--)
10061       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
10062         { cp1++; break; }
10063     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
10064     PerlMem_free(unixified);
10065     PerlMem_free(unixwild);
10066     return 1;
10067   }
10068   else {
10069     char *tpl, *lcres;
10070     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
10071     int ells = 1, totells, segdirs, match;
10072     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
10073                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10074
10075     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
10076     totells = ells;
10077     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
10078     tpl = PerlMem_malloc(VMS_MAXRSS);
10079     if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10080     if (ellipsis == template && opts & 1) {
10081       /* Template begins with an ellipsis.  Since we can't tell how many
10082        * directory names at the front of the resultant to keep for an
10083        * arbitrary starting point, we arbitrarily choose the current
10084        * default directory as a starting point.  If it's there as a prefix,
10085        * clip it off.  If not, fall through and act as if the leading
10086        * ellipsis weren't there (i.e. return shortest possible path that
10087        * could match template).
10088        */
10089       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
10090           PerlMem_free(tpl);
10091           PerlMem_free(unixified);
10092           PerlMem_free(unixwild);
10093           return 0;
10094       }
10095       if (!decc_efs_case_preserve) {
10096         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
10097           if (_tolower(*cp1) != _tolower(*cp2)) break;
10098       }
10099       segdirs = dirs - totells;  /* Min # of dirs we must have left */
10100       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
10101       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
10102         memmove(fspec,cp2+1,end - cp2);
10103         PerlMem_free(tpl);
10104         PerlMem_free(unixified);
10105         PerlMem_free(unixwild);
10106         return 1;
10107       }
10108     }
10109     /* First off, back up over constant elements at end of path */
10110     if (dirs) {
10111       for (front = end ; front >= base; front--)
10112          if (*front == '/' && !dirs--) { front++; break; }
10113     }
10114     lcres = PerlMem_malloc(VMS_MAXRSS);
10115     if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10116     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
10117          cp1++,cp2++) {
10118             if (!decc_efs_case_preserve) {
10119                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
10120             }
10121             else {
10122                 *cp2 = *cp1;
10123             }
10124     }
10125     if (cp1 != '\0') {
10126         PerlMem_free(tpl);
10127         PerlMem_free(unixified);
10128         PerlMem_free(unixwild);
10129         PerlMem_free(lcres);
10130         return 0;  /* Path too long. */
10131     }
10132     lcend = cp2;
10133     *cp2 = '\0';  /* Pick up with memcpy later */
10134     lcfront = lcres + (front - base);
10135     /* Now skip over each ellipsis and try to match the path in front of it. */
10136     while (ells--) {
10137       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
10138         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
10139             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
10140       if (cp1 < template) break; /* template started with an ellipsis */
10141       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
10142         ellipsis = cp1; continue;
10143       }
10144       wilddsc.dsc$a_pointer = tpl;
10145       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
10146       nextell = cp1;
10147       for (segdirs = 0, cp2 = tpl;
10148            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
10149            cp1++, cp2++) {
10150          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
10151          else {
10152             if (!decc_efs_case_preserve) {
10153               *cp2 = _tolower(*cp1);  /* else lowercase for match */
10154             }
10155             else {
10156               *cp2 = *cp1;  /* else preserve case for match */
10157             }
10158          }
10159          if (*cp2 == '/') segdirs++;
10160       }
10161       if (cp1 != ellipsis - 1) {
10162           PerlMem_free(tpl);
10163           PerlMem_free(unixified);
10164           PerlMem_free(unixwild);
10165           PerlMem_free(lcres);
10166           return 0; /* Path too long */
10167       }
10168       /* Back up at least as many dirs as in template before matching */
10169       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
10170         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
10171       for (match = 0; cp1 > lcres;) {
10172         resdsc.dsc$a_pointer = cp1;
10173         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
10174           match++;
10175           if (match == 1) lcfront = cp1;
10176         }
10177         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
10178       }
10179       if (!match) {
10180         PerlMem_free(tpl);
10181         PerlMem_free(unixified);
10182         PerlMem_free(unixwild);
10183         PerlMem_free(lcres);
10184         return 0;  /* Can't find prefix ??? */
10185       }
10186       if (match > 1 && opts & 1) {
10187         /* This ... wildcard could cover more than one set of dirs (i.e.
10188          * a set of similar dir names is repeated).  If the template
10189          * contains more than 1 ..., upstream elements could resolve the
10190          * ambiguity, but it's not worth a full backtracking setup here.
10191          * As a quick heuristic, clip off the current default directory
10192          * if it's present to find the trimmed spec, else use the
10193          * shortest string that this ... could cover.
10194          */
10195         char def[NAM$C_MAXRSS+1], *st;
10196
10197         if (getcwd(def, sizeof def,0) == NULL) {
10198             PerlMem_free(unixified);
10199             PerlMem_free(unixwild);
10200             PerlMem_free(lcres);
10201             PerlMem_free(tpl);
10202             return 0;
10203         }
10204         if (!decc_efs_case_preserve) {
10205           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
10206             if (_tolower(*cp1) != _tolower(*cp2)) break;
10207         }
10208         segdirs = dirs - totells;  /* Min # of dirs we must have left */
10209         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
10210         if (*cp1 == '\0' && *cp2 == '/') {
10211           memmove(fspec,cp2+1,end - cp2);
10212           PerlMem_free(tpl);
10213           PerlMem_free(unixified);
10214           PerlMem_free(unixwild);
10215           PerlMem_free(lcres);
10216           return 1;
10217         }
10218         /* Nope -- stick with lcfront from above and keep going. */
10219       }
10220     }
10221     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
10222     PerlMem_free(tpl);
10223     PerlMem_free(unixified);
10224     PerlMem_free(unixwild);
10225     PerlMem_free(lcres);
10226     return 1;
10227     ellipsis = nextell;
10228   }
10229
10230 }  /* end of trim_unixpath() */
10231 /*}}}*/
10232
10233
10234 /*
10235  *  VMS readdir() routines.
10236  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
10237  *
10238  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
10239  *  Minor modifications to original routines.
10240  */
10241
10242 /* readdir may have been redefined by reentr.h, so make sure we get
10243  * the local version for what we do here.
10244  */
10245 #ifdef readdir
10246 # undef readdir
10247 #endif
10248 #if !defined(PERL_IMPLICIT_CONTEXT)
10249 # define readdir Perl_readdir
10250 #else
10251 # define readdir(a) Perl_readdir(aTHX_ a)
10252 #endif
10253
10254     /* Number of elements in vms_versions array */
10255 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
10256
10257 /*
10258  *  Open a directory, return a handle for later use.
10259  */
10260 /*{{{ DIR *opendir(char*name) */
10261 DIR *
10262 Perl_opendir(pTHX_ const char *name)
10263 {
10264     DIR *dd;
10265     char *dir;
10266     Stat_t sb;
10267
10268     Newx(dir, VMS_MAXRSS, char);
10269     if (int_tovmspath(name, dir, NULL) == NULL) {
10270       Safefree(dir);
10271       return NULL;
10272     }
10273     /* Check access before stat; otherwise stat does not
10274      * accurately report whether it's a directory.
10275      */
10276     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
10277       /* cando_by_name has already set errno */
10278       Safefree(dir);
10279       return NULL;
10280     }
10281     if (flex_stat(dir,&sb) == -1) return NULL;
10282     if (!S_ISDIR(sb.st_mode)) {
10283       Safefree(dir);
10284       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
10285       return NULL;
10286     }
10287     /* Get memory for the handle, and the pattern. */
10288     Newx(dd,1,DIR);
10289     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
10290
10291     /* Fill in the fields; mainly playing with the descriptor. */
10292     sprintf(dd->pattern, "%s*.*",dir);
10293     Safefree(dir);
10294     dd->context = 0;
10295     dd->count = 0;
10296     dd->flags = 0;
10297     /* By saying we always want the result of readdir() in unix format, we
10298      * are really saying we want all the escapes removed.  Otherwise the caller,
10299      * having no way to know whether it's already in VMS format, might send it
10300      * through tovmsspec again, thus double escaping.
10301      */
10302     dd->flags = PERL_VMSDIR_M_UNIXSPECS;
10303     dd->pat.dsc$a_pointer = dd->pattern;
10304     dd->pat.dsc$w_length = strlen(dd->pattern);
10305     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
10306     dd->pat.dsc$b_class = DSC$K_CLASS_S;
10307 #if defined(USE_ITHREADS)
10308     Newx(dd->mutex,1,perl_mutex);
10309     MUTEX_INIT( (perl_mutex *) dd->mutex );
10310 #else
10311     dd->mutex = NULL;
10312 #endif
10313
10314     return dd;
10315 }  /* end of opendir() */
10316 /*}}}*/
10317
10318 /*
10319  *  Set the flag to indicate we want versions or not.
10320  */
10321 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10322 void
10323 vmsreaddirversions(DIR *dd, int flag)
10324 {
10325     if (flag)
10326         dd->flags |= PERL_VMSDIR_M_VERSIONS;
10327     else
10328         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10329 }
10330 /*}}}*/
10331
10332 /*
10333  *  Free up an opened directory.
10334  */
10335 /*{{{ void closedir(DIR *dd)*/
10336 void
10337 Perl_closedir(DIR *dd)
10338 {
10339     int sts;
10340
10341     sts = lib$find_file_end(&dd->context);
10342     Safefree(dd->pattern);
10343 #if defined(USE_ITHREADS)
10344     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10345     Safefree(dd->mutex);
10346 #endif
10347     Safefree(dd);
10348 }
10349 /*}}}*/
10350
10351 /*
10352  *  Collect all the version numbers for the current file.
10353  */
10354 static void
10355 collectversions(pTHX_ DIR *dd)
10356 {
10357     struct dsc$descriptor_s     pat;
10358     struct dsc$descriptor_s     res;
10359     struct dirent *e;
10360     char *p, *text, *buff;
10361     int i;
10362     unsigned long context, tmpsts;
10363
10364     /* Convenient shorthand. */
10365     e = &dd->entry;
10366
10367     /* Add the version wildcard, ignoring the "*.*" put on before */
10368     i = strlen(dd->pattern);
10369     Newx(text,i + e->d_namlen + 3,char);
10370     strcpy(text, dd->pattern);
10371     sprintf(&text[i - 3], "%s;*", e->d_name);
10372
10373     /* Set up the pattern descriptor. */
10374     pat.dsc$a_pointer = text;
10375     pat.dsc$w_length = i + e->d_namlen - 1;
10376     pat.dsc$b_dtype = DSC$K_DTYPE_T;
10377     pat.dsc$b_class = DSC$K_CLASS_S;
10378
10379     /* Set up result descriptor. */
10380     Newx(buff, VMS_MAXRSS, char);
10381     res.dsc$a_pointer = buff;
10382     res.dsc$w_length = VMS_MAXRSS - 1;
10383     res.dsc$b_dtype = DSC$K_DTYPE_T;
10384     res.dsc$b_class = DSC$K_CLASS_S;
10385
10386     /* Read files, collecting versions. */
10387     for (context = 0, e->vms_verscount = 0;
10388          e->vms_verscount < VERSIZE(e);
10389          e->vms_verscount++) {
10390         unsigned long rsts;
10391         unsigned long flags = 0;
10392
10393 #ifdef VMS_LONGNAME_SUPPORT
10394         flags = LIB$M_FIL_LONG_NAMES;
10395 #endif
10396         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10397         if (tmpsts == RMS$_NMF || context == 0) break;
10398         _ckvmssts(tmpsts);
10399         buff[VMS_MAXRSS - 1] = '\0';
10400         if ((p = strchr(buff, ';')))
10401             e->vms_versions[e->vms_verscount] = atoi(p + 1);
10402         else
10403             e->vms_versions[e->vms_verscount] = -1;
10404     }
10405
10406     _ckvmssts(lib$find_file_end(&context));
10407     Safefree(text);
10408     Safefree(buff);
10409
10410 }  /* end of collectversions() */
10411
10412 /*
10413  *  Read the next entry from the directory.
10414  */
10415 /*{{{ struct dirent *readdir(DIR *dd)*/
10416 struct dirent *
10417 Perl_readdir(pTHX_ DIR *dd)
10418 {
10419     struct dsc$descriptor_s     res;
10420     char *p, *buff;
10421     unsigned long int tmpsts;
10422     unsigned long rsts;
10423     unsigned long flags = 0;
10424     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10425     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10426
10427     /* Set up result descriptor, and get next file. */
10428     Newx(buff, VMS_MAXRSS, char);
10429     res.dsc$a_pointer = buff;
10430     res.dsc$w_length = VMS_MAXRSS - 1;
10431     res.dsc$b_dtype = DSC$K_DTYPE_T;
10432     res.dsc$b_class = DSC$K_CLASS_S;
10433
10434 #ifdef VMS_LONGNAME_SUPPORT
10435     flags = LIB$M_FIL_LONG_NAMES;
10436 #endif
10437
10438     tmpsts = lib$find_file
10439         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10440     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
10441     if (!(tmpsts & 1)) {
10442       set_vaxc_errno(tmpsts);
10443       switch (tmpsts) {
10444         case RMS$_PRV:
10445           set_errno(EACCES); break;
10446         case RMS$_DEV:
10447           set_errno(ENODEV); break;
10448         case RMS$_DIR:
10449           set_errno(ENOTDIR); break;
10450         case RMS$_FNF: case RMS$_DNF:
10451           set_errno(ENOENT); break;
10452         default:
10453           set_errno(EVMSERR);
10454       }
10455       Safefree(buff);
10456       return NULL;
10457     }
10458     dd->count++;
10459     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10460     buff[res.dsc$w_length] = '\0';
10461     p = buff + res.dsc$w_length;
10462     while (--p >= buff) if (!isspace(*p)) break;
10463     *p = '\0';
10464     if (!decc_efs_case_preserve) {
10465       for (p = buff; *p; p++) *p = _tolower(*p);
10466     }
10467
10468     /* Skip any directory component and just copy the name. */
10469     sts = vms_split_path
10470        (buff,
10471         &v_spec,
10472         &v_len,
10473         &r_spec,
10474         &r_len,
10475         &d_spec,
10476         &d_len,
10477         &n_spec,
10478         &n_len,
10479         &e_spec,
10480         &e_len,
10481         &vs_spec,
10482         &vs_len);
10483
10484     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10485
10486         /* In Unix report mode, remove the ".dir;1" from the name */
10487         /* if it is a real directory. */
10488         if (decc_filename_unix_report || decc_efs_charset) {
10489             if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
10490                 Stat_t statbuf;
10491                 int ret_sts;
10492
10493                 ret_sts = flex_lstat(buff, &statbuf);
10494                 if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10495                     e_len = 0;
10496                     e_spec[0] = 0;
10497                 }
10498             }
10499         }
10500
10501         /* Drop NULL extensions on UNIX file specification */
10502         if ((e_len == 1) && decc_readdir_dropdotnotype) {
10503             e_len = 0;
10504             e_spec[0] = '\0';
10505         }
10506     }
10507
10508     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
10509     dd->entry.d_name[n_len + e_len] = '\0';
10510     dd->entry.d_namlen = strlen(dd->entry.d_name);
10511
10512     /* Convert the filename to UNIX format if needed */
10513     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10514
10515         /* Translate the encoded characters. */
10516         /* Fixme: Unicode handling could result in embedded 0 characters */
10517         if (strchr(dd->entry.d_name, '^') != NULL) {
10518             char new_name[256];
10519             char * q;
10520             p = dd->entry.d_name;
10521             q = new_name;
10522             while (*p != 0) {
10523                 int inchars_read, outchars_added;
10524                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10525                 p += inchars_read;
10526                 q += outchars_added;
10527                 /* fix-me */
10528                 /* if outchars_added > 1, then this is a wide file specification */
10529                 /* Wide file specifications need to be passed in Perl */
10530                 /* counted strings apparently with a Unicode flag */
10531             }
10532             *q = 0;
10533             strcpy(dd->entry.d_name, new_name);
10534             dd->entry.d_namlen = strlen(dd->entry.d_name);
10535         }
10536     }
10537
10538     dd->entry.vms_verscount = 0;
10539     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10540     Safefree(buff);
10541     return &dd->entry;
10542
10543 }  /* end of readdir() */
10544 /*}}}*/
10545
10546 /*
10547  *  Read the next entry from the directory -- thread-safe version.
10548  */
10549 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10550 int
10551 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10552 {
10553     int retval;
10554
10555     MUTEX_LOCK( (perl_mutex *) dd->mutex );
10556
10557     entry = readdir(dd);
10558     *result = entry;
10559     retval = ( *result == NULL ? errno : 0 );
10560
10561     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10562
10563     return retval;
10564
10565 }  /* end of readdir_r() */
10566 /*}}}*/
10567
10568 /*
10569  *  Return something that can be used in a seekdir later.
10570  */
10571 /*{{{ long telldir(DIR *dd)*/
10572 long
10573 Perl_telldir(DIR *dd)
10574 {
10575     return dd->count;
10576 }
10577 /*}}}*/
10578
10579 /*
10580  *  Return to a spot where we used to be.  Brute force.
10581  */
10582 /*{{{ void seekdir(DIR *dd,long count)*/
10583 void
10584 Perl_seekdir(pTHX_ DIR *dd, long count)
10585 {
10586     int old_flags;
10587
10588     /* If we haven't done anything yet... */
10589     if (dd->count == 0)
10590         return;
10591
10592     /* Remember some state, and clear it. */
10593     old_flags = dd->flags;
10594     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10595     _ckvmssts(lib$find_file_end(&dd->context));
10596     dd->context = 0;
10597
10598     /* The increment is in readdir(). */
10599     for (dd->count = 0; dd->count < count; )
10600         readdir(dd);
10601
10602     dd->flags = old_flags;
10603
10604 }  /* end of seekdir() */
10605 /*}}}*/
10606
10607 /* VMS subprocess management
10608  *
10609  * my_vfork() - just a vfork(), after setting a flag to record that
10610  * the current script is trying a Unix-style fork/exec.
10611  *
10612  * vms_do_aexec() and vms_do_exec() are called in response to the
10613  * perl 'exec' function.  If this follows a vfork call, then they
10614  * call out the regular perl routines in doio.c which do an
10615  * execvp (for those who really want to try this under VMS).
10616  * Otherwise, they do exactly what the perl docs say exec should
10617  * do - terminate the current script and invoke a new command
10618  * (See below for notes on command syntax.)
10619  *
10620  * do_aspawn() and do_spawn() implement the VMS side of the perl
10621  * 'system' function.
10622  *
10623  * Note on command arguments to perl 'exec' and 'system': When handled
10624  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10625  * are concatenated to form a DCL command string.  If the first non-numeric
10626  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10627  * the command string is handed off to DCL directly.  Otherwise,
10628  * the first token of the command is taken as the filespec of an image
10629  * to run.  The filespec is expanded using a default type of '.EXE' and
10630  * the process defaults for device, directory, etc., and if found, the resultant
10631  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10632  * the command string as parameters.  This is perhaps a bit complicated,
10633  * but I hope it will form a happy medium between what VMS folks expect
10634  * from lib$spawn and what Unix folks expect from exec.
10635  */
10636
10637 static int vfork_called;
10638
10639 /*{{{int my_vfork()*/
10640 int
10641 my_vfork()
10642 {
10643   vfork_called++;
10644   return vfork();
10645 }
10646 /*}}}*/
10647
10648
10649 static void
10650 vms_execfree(struct dsc$descriptor_s *vmscmd)
10651 {
10652   if (vmscmd) {
10653       if (vmscmd->dsc$a_pointer) {
10654           PerlMem_free(vmscmd->dsc$a_pointer);
10655       }
10656       PerlMem_free(vmscmd);
10657   }
10658 }
10659
10660 static char *
10661 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10662 {
10663   char *junk, *tmps = NULL;
10664   register size_t cmdlen = 0;
10665   size_t rlen;
10666   register SV **idx;
10667   STRLEN n_a;
10668
10669   idx = mark;
10670   if (really) {
10671     tmps = SvPV(really,rlen);
10672     if (*tmps) {
10673       cmdlen += rlen + 1;
10674       idx++;
10675     }
10676   }
10677
10678   for (idx++; idx <= sp; idx++) {
10679     if (*idx) {
10680       junk = SvPVx(*idx,rlen);
10681       cmdlen += rlen ? rlen + 1 : 0;
10682     }
10683   }
10684   Newx(PL_Cmd, cmdlen+1, char);
10685
10686   if (tmps && *tmps) {
10687     strcpy(PL_Cmd,tmps);
10688     mark++;
10689   }
10690   else *PL_Cmd = '\0';
10691   while (++mark <= sp) {
10692     if (*mark) {
10693       char *s = SvPVx(*mark,n_a);
10694       if (!*s) continue;
10695       if (*PL_Cmd) strcat(PL_Cmd," ");
10696       strcat(PL_Cmd,s);
10697     }
10698   }
10699   return PL_Cmd;
10700
10701 }  /* end of setup_argstr() */
10702
10703
10704 static unsigned long int
10705 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10706                    struct dsc$descriptor_s **pvmscmd)
10707 {
10708   char * vmsspec;
10709   char * resspec;
10710   char image_name[NAM$C_MAXRSS+1];
10711   char image_argv[NAM$C_MAXRSS+1];
10712   $DESCRIPTOR(defdsc,".EXE");
10713   $DESCRIPTOR(defdsc2,".");
10714   struct dsc$descriptor_s resdsc;
10715   struct dsc$descriptor_s *vmscmd;
10716   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10717   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10718   register char *s, *rest, *cp, *wordbreak;
10719   char * cmd;
10720   int cmdlen;
10721   register int isdcl;
10722
10723   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10724   if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10725
10726   /* vmsspec is a DCL command buffer, not just a filename */
10727   vmsspec = PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10728   if (vmsspec == NULL)
10729       _ckvmssts_noperl(SS$_INSFMEM);
10730
10731   resspec = PerlMem_malloc(VMS_MAXRSS);
10732   if (resspec == NULL)
10733       _ckvmssts_noperl(SS$_INSFMEM);
10734
10735   /* Make a copy for modification */
10736   cmdlen = strlen(incmd);
10737   cmd = PerlMem_malloc(cmdlen+1);
10738   if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10739   strncpy(cmd, incmd, cmdlen);
10740   cmd[cmdlen] = 0;
10741   image_name[0] = 0;
10742   image_argv[0] = 0;
10743
10744   resdsc.dsc$a_pointer = resspec;
10745   resdsc.dsc$b_dtype  = DSC$K_DTYPE_T;
10746   resdsc.dsc$b_class  = DSC$K_CLASS_S;
10747   resdsc.dsc$w_length = VMS_MAXRSS - 1;
10748
10749   vmscmd->dsc$a_pointer = NULL;
10750   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
10751   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
10752   vmscmd->dsc$w_length = 0;
10753   if (pvmscmd) *pvmscmd = vmscmd;
10754
10755   if (suggest_quote) *suggest_quote = 0;
10756
10757   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10758     PerlMem_free(cmd);
10759     PerlMem_free(vmsspec);
10760     PerlMem_free(resspec);
10761     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
10762   }
10763
10764   s = cmd;
10765
10766   while (*s && isspace(*s)) s++;
10767
10768   if (*s == '@' || *s == '$') {
10769     vmsspec[0] = *s;  rest = s + 1;
10770     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10771   }
10772   else { cp = vmsspec; rest = s; }
10773   if (*rest == '.' || *rest == '/') {
10774     char *cp2;
10775     for (cp2 = resspec;
10776          *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10777          rest++, cp2++) *cp2 = *rest;
10778     *cp2 = '\0';
10779     if (int_tovmsspec(resspec, cp, 0, NULL)) {
10780       s = vmsspec;
10781
10782       /* When a UNIX spec with no file type is translated to VMS, */
10783       /* A trailing '.' is appended under ODS-5 rules.            */
10784       /* Here we do not want that trailing "." as it prevents     */
10785       /* Looking for a implied ".exe" type. */
10786       if (decc_efs_charset) {
10787           int i;
10788           i = strlen(vmsspec);
10789           if (vmsspec[i-1] == '.') {
10790               vmsspec[i-1] = '\0';
10791           }
10792       }
10793
10794       if (*rest) {
10795         for (cp2 = vmsspec + strlen(vmsspec);
10796              *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10797              rest++, cp2++) *cp2 = *rest;
10798         *cp2 = '\0';
10799       }
10800     }
10801   }
10802   /* Intuit whether verb (first word of cmd) is a DCL command:
10803    *   - if first nonspace char is '@', it's a DCL indirection
10804    * otherwise
10805    *   - if verb contains a filespec separator, it's not a DCL command
10806    *   - if it doesn't, caller tells us whether to default to a DCL
10807    *     command, or to a local image unless told it's DCL (by leading '$')
10808    */
10809   if (*s == '@') {
10810       isdcl = 1;
10811       if (suggest_quote) *suggest_quote = 1;
10812   } else {
10813     register char *filespec = strpbrk(s,":<[.;");
10814     rest = wordbreak = strpbrk(s," \"\t/");
10815     if (!wordbreak) wordbreak = s + strlen(s);
10816     if (*s == '$') check_img = 0;
10817     if (filespec && (filespec < wordbreak)) isdcl = 0;
10818     else isdcl = !check_img;
10819   }
10820
10821   if (!isdcl) {
10822     int rsts;
10823     imgdsc.dsc$a_pointer = s;
10824     imgdsc.dsc$w_length = wordbreak - s;
10825     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10826     if (!(retsts&1)) {
10827         _ckvmssts_noperl(lib$find_file_end(&cxt));
10828         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10829       if (!(retsts & 1) && *s == '$') {
10830         _ckvmssts_noperl(lib$find_file_end(&cxt));
10831         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10832         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10833         if (!(retsts&1)) {
10834           _ckvmssts_noperl(lib$find_file_end(&cxt));
10835           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10836         }
10837       }
10838     }
10839     _ckvmssts_noperl(lib$find_file_end(&cxt));
10840
10841     if (retsts & 1) {
10842       FILE *fp;
10843       s = resspec;
10844       while (*s && !isspace(*s)) s++;
10845       *s = '\0';
10846
10847       /* check that it's really not DCL with no file extension */
10848       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10849       if (fp) {
10850         char b[256] = {0,0,0,0};
10851         read(fileno(fp), b, 256);
10852         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10853         if (isdcl) {
10854           int shebang_len;
10855
10856           /* Check for script */
10857           shebang_len = 0;
10858           if ((b[0] == '#') && (b[1] == '!'))
10859              shebang_len = 2;
10860 #ifdef ALTERNATE_SHEBANG
10861           else {
10862             shebang_len = strlen(ALTERNATE_SHEBANG);
10863             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10864               char * perlstr;
10865                 perlstr = strstr("perl",b);
10866                 if (perlstr == NULL)
10867                   shebang_len = 0;
10868             }
10869             else
10870               shebang_len = 0;
10871           }
10872 #endif
10873
10874           if (shebang_len > 0) {
10875           int i;
10876           int j;
10877           char tmpspec[NAM$C_MAXRSS + 1];
10878
10879             i = shebang_len;
10880              /* Image is following after white space */
10881             /*--------------------------------------*/
10882             while (isprint(b[i]) && isspace(b[i]))
10883                 i++;
10884
10885             j = 0;
10886             while (isprint(b[i]) && !isspace(b[i])) {
10887                 tmpspec[j++] = b[i++];
10888                 if (j >= NAM$C_MAXRSS)
10889                    break;
10890             }
10891             tmpspec[j] = '\0';
10892
10893              /* There may be some default parameters to the image */
10894             /*---------------------------------------------------*/
10895             j = 0;
10896             while (isprint(b[i])) {
10897                 image_argv[j++] = b[i++];
10898                 if (j >= NAM$C_MAXRSS)
10899                    break;
10900             }
10901             while ((j > 0) && !isprint(image_argv[j-1]))
10902                 j--;
10903             image_argv[j] = 0;
10904
10905             /* It will need to be converted to VMS format and validated */
10906             if (tmpspec[0] != '\0') {
10907               char * iname;
10908
10909                /* Try to find the exact program requested to be run */
10910               /*---------------------------------------------------*/
10911               iname = int_rmsexpand
10912                  (tmpspec, image_name, ".exe",
10913                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10914               if (iname != NULL) {
10915                 if (cando_by_name_int
10916                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10917                   /* MCR prefix needed */
10918                   isdcl = 0;
10919                 }
10920                 else {
10921                    /* Try again with a null type */
10922                   /*----------------------------*/
10923                   iname = int_rmsexpand
10924                     (tmpspec, image_name, ".",
10925                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10926                   if (iname != NULL) {
10927                     if (cando_by_name_int
10928                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10929                       /* MCR prefix needed */
10930                       isdcl = 0;
10931                     }
10932                   }
10933                 }
10934
10935                  /* Did we find the image to run the script? */
10936                 /*------------------------------------------*/
10937                 if (isdcl) {
10938                   char *tchr;
10939
10940                    /* Assume DCL or foreign command exists */
10941                   /*--------------------------------------*/
10942                   tchr = strrchr(tmpspec, '/');
10943                   if (tchr != NULL) {
10944                     tchr++;
10945                   }
10946                   else {
10947                     tchr = tmpspec;
10948                   }
10949                   strcpy(image_name, tchr);
10950                 }
10951               }
10952             }
10953           }
10954         }
10955         fclose(fp);
10956       }
10957       if (check_img && isdcl) {
10958           PerlMem_free(cmd);
10959           PerlMem_free(resspec);
10960           PerlMem_free(vmsspec);
10961           return RMS$_FNF;
10962       }
10963
10964       if (cando_by_name(S_IXUSR,0,resspec)) {
10965         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10966         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10967         if (!isdcl) {
10968             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
10969             if (image_name[0] != 0) {
10970                 strcat(vmscmd->dsc$a_pointer, image_name);
10971                 strcat(vmscmd->dsc$a_pointer, " ");
10972             }
10973         } else if (image_name[0] != 0) {
10974             strcpy(vmscmd->dsc$a_pointer, image_name);
10975             strcat(vmscmd->dsc$a_pointer, " ");
10976         } else {
10977             strcpy(vmscmd->dsc$a_pointer,"@");
10978         }
10979         if (suggest_quote) *suggest_quote = 1;
10980
10981         /* If there is an image name, use original command */
10982         if (image_name[0] == 0)
10983             strcat(vmscmd->dsc$a_pointer,resspec);
10984         else {
10985             rest = cmd;
10986             while (*rest && isspace(*rest)) rest++;
10987         }
10988
10989         if (image_argv[0] != 0) {
10990           strcat(vmscmd->dsc$a_pointer,image_argv);
10991           strcat(vmscmd->dsc$a_pointer, " ");
10992         }
10993         if (rest) {
10994            int rest_len;
10995            int vmscmd_len;
10996
10997            rest_len = strlen(rest);
10998            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10999            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
11000               strcat(vmscmd->dsc$a_pointer,rest);
11001            else
11002              retsts = CLI$_BUFOVF;
11003         }
11004         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
11005         PerlMem_free(cmd);
11006         PerlMem_free(vmsspec);
11007         PerlMem_free(resspec);
11008         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
11009       }
11010       else
11011         retsts = RMS$_PRV;
11012     }
11013   }
11014   /* It's either a DCL command or we couldn't find a suitable image */
11015   vmscmd->dsc$w_length = strlen(cmd);
11016
11017   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
11018   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
11019   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
11020
11021   PerlMem_free(cmd);
11022   PerlMem_free(resspec);
11023   PerlMem_free(vmsspec);
11024
11025   /* check if it's a symbol (for quoting purposes) */
11026   if (suggest_quote && !*suggest_quote) {
11027     int iss;
11028     char equiv[LNM$C_NAMLENGTH];
11029     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11030     eqvdsc.dsc$a_pointer = equiv;
11031
11032     iss = lib$get_symbol(vmscmd,&eqvdsc);
11033     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
11034   }
11035   if (!(retsts & 1)) {
11036     /* just hand off status values likely to be due to user error */
11037     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
11038         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
11039        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
11040     else { _ckvmssts_noperl(retsts); }
11041   }
11042
11043   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
11044
11045 }  /* end of setup_cmddsc() */
11046
11047
11048 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
11049 bool
11050 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
11051 {
11052 bool exec_sts;
11053 char * cmd;
11054
11055   if (sp > mark) {
11056     if (vfork_called) {           /* this follows a vfork - act Unixish */
11057       vfork_called--;
11058       if (vfork_called < 0) {
11059         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
11060         vfork_called = 0;
11061       }
11062       else return do_aexec(really,mark,sp);
11063     }
11064                                            /* no vfork - act VMSish */
11065     cmd = setup_argstr(aTHX_ really,mark,sp);
11066     exec_sts = vms_do_exec(cmd);
11067     Safefree(cmd);  /* Clean up from setup_argstr() */
11068     return exec_sts;
11069   }
11070
11071   return FALSE;
11072 }  /* end of vms_do_aexec() */
11073 /*}}}*/
11074
11075 /* {{{bool vms_do_exec(char *cmd) */
11076 bool
11077 Perl_vms_do_exec(pTHX_ const char *cmd)
11078 {
11079   struct dsc$descriptor_s *vmscmd;
11080
11081   if (vfork_called) {             /* this follows a vfork - act Unixish */
11082     vfork_called--;
11083     if (vfork_called < 0) {
11084       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
11085       vfork_called = 0;
11086     }
11087     else return do_exec(cmd);
11088   }
11089
11090   {                               /* no vfork - act VMSish */
11091     unsigned long int retsts;
11092
11093     TAINT_ENV();
11094     TAINT_PROPER("exec");
11095     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
11096       retsts = lib$do_command(vmscmd);
11097
11098     switch (retsts) {
11099       case RMS$_FNF: case RMS$_DNF:
11100         set_errno(ENOENT); break;
11101       case RMS$_DIR:
11102         set_errno(ENOTDIR); break;
11103       case RMS$_DEV:
11104         set_errno(ENODEV); break;
11105       case RMS$_PRV:
11106         set_errno(EACCES); break;
11107       case RMS$_SYN:
11108         set_errno(EINVAL); break;
11109       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11110         set_errno(E2BIG); break;
11111       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11112         _ckvmssts_noperl(retsts); /* fall through */
11113       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11114         set_errno(EVMSERR);
11115     }
11116     set_vaxc_errno(retsts);
11117     if (ckWARN(WARN_EXEC)) {
11118       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
11119              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
11120     }
11121     vms_execfree(vmscmd);
11122   }
11123
11124   return FALSE;
11125
11126 }  /* end of vms_do_exec() */
11127 /*}}}*/
11128
11129 int do_spawn2(pTHX_ const char *, int);
11130
11131 int
11132 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
11133 {
11134 unsigned long int sts;
11135 char * cmd;
11136 int flags = 0;
11137
11138   if (sp > mark) {
11139
11140     /* We'll copy the (undocumented?) Win32 behavior and allow a
11141      * numeric first argument.  But the only value we'll support
11142      * through do_aspawn is a value of 1, which means spawn without
11143      * waiting for completion -- other values are ignored.
11144      */
11145     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
11146         ++mark;
11147         flags = SvIVx(*mark);
11148     }
11149
11150     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
11151         flags = CLI$M_NOWAIT;
11152     else
11153         flags = 0;
11154
11155     cmd = setup_argstr(aTHX_ really, mark, sp);
11156     sts = do_spawn2(aTHX_ cmd, flags);
11157     /* pp_sys will clean up cmd */
11158     return sts;
11159   }
11160   return SS$_ABORT;
11161 }  /* end of do_aspawn() */
11162 /*}}}*/
11163
11164
11165 /* {{{int do_spawn(char* cmd) */
11166 int
11167 Perl_do_spawn(pTHX_ char* cmd)
11168 {
11169     PERL_ARGS_ASSERT_DO_SPAWN;
11170
11171     return do_spawn2(aTHX_ cmd, 0);
11172 }
11173 /*}}}*/
11174
11175 /* {{{int do_spawn_nowait(char* cmd) */
11176 int
11177 Perl_do_spawn_nowait(pTHX_ char* cmd)
11178 {
11179     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
11180
11181     return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
11182 }
11183 /*}}}*/
11184
11185 /* {{{int do_spawn2(char *cmd) */
11186 int
11187 do_spawn2(pTHX_ const char *cmd, int flags)
11188 {
11189   unsigned long int sts, substs;
11190
11191   /* The caller of this routine expects to Safefree(PL_Cmd) */
11192   Newx(PL_Cmd,10,char);
11193
11194   TAINT_ENV();
11195   TAINT_PROPER("spawn");
11196   if (!cmd || !*cmd) {
11197     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
11198     if (!(sts & 1)) {
11199       switch (sts) {
11200         case RMS$_FNF:  case RMS$_DNF:
11201           set_errno(ENOENT); break;
11202         case RMS$_DIR:
11203           set_errno(ENOTDIR); break;
11204         case RMS$_DEV:
11205           set_errno(ENODEV); break;
11206         case RMS$_PRV:
11207           set_errno(EACCES); break;
11208         case RMS$_SYN:
11209           set_errno(EINVAL); break;
11210         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11211           set_errno(E2BIG); break;
11212         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11213           _ckvmssts_noperl(sts); /* fall through */
11214         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11215           set_errno(EVMSERR);
11216       }
11217       set_vaxc_errno(sts);
11218       if (ckWARN(WARN_EXEC)) {
11219         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
11220                     Strerror(errno));
11221       }
11222     }
11223     sts = substs;
11224   }
11225   else {
11226     char mode[3];
11227     PerlIO * fp;
11228     if (flags & CLI$M_NOWAIT)
11229         strcpy(mode, "n");
11230     else
11231         strcpy(mode, "nW");
11232
11233     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
11234     if (fp != NULL)
11235       my_pclose(fp);
11236     /* sts will be the pid in the nowait case */
11237   }
11238   return sts;
11239 }  /* end of do_spawn2() */
11240 /*}}}*/
11241
11242
11243 static unsigned int *sockflags, sockflagsize;
11244
11245 /*
11246  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
11247  * routines found in some versions of the CRTL can't deal with sockets.
11248  * We don't shim the other file open routines since a socket isn't
11249  * likely to be opened by a name.
11250  */
11251 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
11252 FILE *my_fdopen(int fd, const char *mode)
11253 {
11254   FILE *fp = fdopen(fd, mode);
11255
11256   if (fp) {
11257     unsigned int fdoff = fd / sizeof(unsigned int);
11258     Stat_t sbuf; /* native stat; we don't need flex_stat */
11259     if (!sockflagsize || fdoff > sockflagsize) {
11260       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
11261       else           Newx  (sockflags,fdoff+2,unsigned int);
11262       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11263       sockflagsize = fdoff + 2;
11264     }
11265     if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
11266       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11267   }
11268   return fp;
11269
11270 }
11271 /*}}}*/
11272
11273
11274 /*
11275  * Clear the corresponding bit when the (possibly) socket stream is closed.
11276  * There still a small hole: we miss an implicit close which might occur
11277  * via freopen().  >> Todo
11278  */
11279 /*{{{ int my_fclose(FILE *fp)*/
11280 int my_fclose(FILE *fp) {
11281   if (fp) {
11282     unsigned int fd = fileno(fp);
11283     unsigned int fdoff = fd / sizeof(unsigned int);
11284
11285     if (sockflagsize && fdoff < sockflagsize)
11286       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11287   }
11288   return fclose(fp);
11289 }
11290 /*}}}*/
11291
11292
11293 /*
11294  * A simple fwrite replacement which outputs itmsz*nitm chars without
11295  * introducing record boundaries every itmsz chars.
11296  * We are using fputs, which depends on a terminating null.  We may
11297  * well be writing binary data, so we need to accommodate not only
11298  * data with nulls sprinkled in the middle but also data with no null
11299  * byte at the end.
11300  */
11301 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
11302 int
11303 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11304 {
11305   register char *cp, *end, *cpd;
11306   char *data;
11307   register unsigned int fd = fileno(dest);
11308   register unsigned int fdoff = fd / sizeof(unsigned int);
11309   int retval;
11310   int bufsize = itmsz * nitm + 1;
11311
11312   if (fdoff < sockflagsize &&
11313       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11314     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11315     return nitm;
11316   }
11317
11318   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11319   memcpy( data, src, itmsz*nitm );
11320   data[itmsz*nitm] = '\0';
11321
11322   end = data + itmsz * nitm;
11323   retval = (int) nitm; /* on success return # items written */
11324
11325   cpd = data;
11326   while (cpd <= end) {
11327     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11328     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11329     if (cp < end)
11330       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11331     cpd = cp + 1;
11332   }
11333
11334   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11335   return retval;
11336
11337 }  /* end of my_fwrite() */
11338 /*}}}*/
11339
11340 /*{{{ int my_flush(FILE *fp)*/
11341 int
11342 Perl_my_flush(pTHX_ FILE *fp)
11343 {
11344     int res;
11345     if ((res = fflush(fp)) == 0 && fp) {
11346 #ifdef VMS_DO_SOCKETS
11347         Stat_t s;
11348         if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11349 #endif
11350             res = fsync(fileno(fp));
11351     }
11352 /*
11353  * If the flush succeeded but set end-of-file, we need to clear
11354  * the error because our caller may check ferror().  BTW, this
11355  * probably means we just flushed an empty file.
11356  */
11357     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11358
11359     return res;
11360 }
11361 /*}}}*/
11362
11363 /* fgetname() is not returning the correct file specifications when
11364  * decc_filename_unix_report mode is active.  So we have to have it
11365  * aways return filenames in VMS mode and convert it ourselves.
11366  */
11367
11368 /*{{{ char * my_fgetname(FILE *fp, buf)*/
11369 char *
11370 Perl_my_fgetname(FILE *fp, char * buf) {
11371     char * retname;
11372     char * vms_name;
11373
11374     retname = fgetname(fp, buf, 1);
11375
11376     /* If we are in VMS mode, then we are done */
11377     if (!decc_filename_unix_report || (retname == NULL)) {
11378        return retname;
11379     }
11380
11381     /* Convert this to Unix format */
11382     vms_name = PerlMem_malloc(VMS_MAXRSS + 1);
11383     strcpy(vms_name, retname);
11384     retname = int_tounixspec(vms_name, buf, NULL);
11385     PerlMem_free(vms_name);
11386
11387     return retname;
11388 }
11389 /*}}}*/
11390
11391 /*
11392  * Here are replacements for the following Unix routines in the VMS environment:
11393  *      getpwuid    Get information for a particular UIC or UID
11394  *      getpwnam    Get information for a named user
11395  *      getpwent    Get information for each user in the rights database
11396  *      setpwent    Reset search to the start of the rights database
11397  *      endpwent    Finish searching for users in the rights database
11398  *
11399  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11400  * (defined in pwd.h), which contains the following fields:-
11401  *      struct passwd {
11402  *              char        *pw_name;    Username (in lower case)
11403  *              char        *pw_passwd;  Hashed password
11404  *              unsigned int pw_uid;     UIC
11405  *              unsigned int pw_gid;     UIC group  number
11406  *              char        *pw_unixdir; Default device/directory (VMS-style)
11407  *              char        *pw_gecos;   Owner name
11408  *              char        *pw_dir;     Default device/directory (Unix-style)
11409  *              char        *pw_shell;   Default CLI name (eg. DCL)
11410  *      };
11411  * If the specified user does not exist, getpwuid and getpwnam return NULL.
11412  *
11413  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11414  * not the UIC member number (eg. what's returned by getuid()),
11415  * getpwuid() can accept either as input (if uid is specified, the caller's
11416  * UIC group is used), though it won't recognise gid=0.
11417  *
11418  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11419  * information about other users in your group or in other groups, respectively.
11420  * If the required privilege is not available, then these routines fill only
11421  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11422  * string).
11423  *
11424  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11425  */
11426
11427 /* sizes of various UAF record fields */
11428 #define UAI$S_USERNAME 12
11429 #define UAI$S_IDENT    31
11430 #define UAI$S_OWNER    31
11431 #define UAI$S_DEFDEV   31
11432 #define UAI$S_DEFDIR   63
11433 #define UAI$S_DEFCLI   31
11434 #define UAI$S_PWD       8
11435
11436 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
11437                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11438                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
11439
11440 static char __empty[]= "";
11441 static struct passwd __passwd_empty=
11442     {(char *) __empty, (char *) __empty, 0, 0,
11443      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11444 static int contxt= 0;
11445 static struct passwd __pwdcache;
11446 static char __pw_namecache[UAI$S_IDENT+1];
11447
11448 /*
11449  * This routine does most of the work extracting the user information.
11450  */
11451 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11452 {
11453     static struct {
11454         unsigned char length;
11455         char pw_gecos[UAI$S_OWNER+1];
11456     } owner;
11457     static union uicdef uic;
11458     static struct {
11459         unsigned char length;
11460         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11461     } defdev;
11462     static struct {
11463         unsigned char length;
11464         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11465     } defdir;
11466     static struct {
11467         unsigned char length;
11468         char pw_shell[UAI$S_DEFCLI+1];
11469     } defcli;
11470     static char pw_passwd[UAI$S_PWD+1];
11471
11472     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11473     struct dsc$descriptor_s name_desc;
11474     unsigned long int sts;
11475
11476     static struct itmlst_3 itmlst[]= {
11477         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
11478         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
11479         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
11480         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
11481         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
11482         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
11483         {0,                0,           NULL,    NULL}};
11484
11485     name_desc.dsc$w_length=  strlen(name);
11486     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11487     name_desc.dsc$b_class=   DSC$K_CLASS_S;
11488     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11489
11490 /*  Note that sys$getuai returns many fields as counted strings. */
11491     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11492     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11493       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11494     }
11495     else { _ckvmssts(sts); }
11496     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
11497
11498     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
11499     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11500     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11501     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11502     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11503     owner.pw_gecos[lowner]=            '\0';
11504     defdev.pw_dir[ldefdev+ldefdir]= '\0';
11505     defcli.pw_shell[ldefcli]=          '\0';
11506     if (valid_uic(uic)) {
11507         pwd->pw_uid= uic.uic$l_uic;
11508         pwd->pw_gid= uic.uic$v_group;
11509     }
11510     else
11511       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11512     pwd->pw_passwd=  pw_passwd;
11513     pwd->pw_gecos=   owner.pw_gecos;
11514     pwd->pw_dir=     defdev.pw_dir;
11515     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11516     pwd->pw_shell=   defcli.pw_shell;
11517     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11518         int ldir;
11519         ldir= strlen(pwd->pw_unixdir) - 1;
11520         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11521     }
11522     else
11523         strcpy(pwd->pw_unixdir, pwd->pw_dir);
11524     if (!decc_efs_case_preserve)
11525         __mystrtolower(pwd->pw_unixdir);
11526     return 1;
11527 }
11528
11529 /*
11530  * Get information for a named user.
11531 */
11532 /*{{{struct passwd *getpwnam(char *name)*/
11533 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
11534 {
11535     struct dsc$descriptor_s name_desc;
11536     union uicdef uic;
11537     unsigned long int status, sts;
11538
11539     __pwdcache = __passwd_empty;
11540     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11541       /* We still may be able to determine pw_uid and pw_gid */
11542       name_desc.dsc$w_length=  strlen(name);
11543       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11544       name_desc.dsc$b_class=   DSC$K_CLASS_S;
11545       name_desc.dsc$a_pointer= (char *) name;
11546       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11547         __pwdcache.pw_uid= uic.uic$l_uic;
11548         __pwdcache.pw_gid= uic.uic$v_group;
11549       }
11550       else {
11551         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11552           set_vaxc_errno(sts);
11553           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11554           return NULL;
11555         }
11556         else { _ckvmssts(sts); }
11557       }
11558     }
11559     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
11560     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
11561     __pwdcache.pw_name= __pw_namecache;
11562     return &__pwdcache;
11563 }  /* end of my_getpwnam() */
11564 /*}}}*/
11565
11566 /*
11567  * Get information for a particular UIC or UID.
11568  * Called by my_getpwent with uid=-1 to list all users.
11569 */
11570 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11571 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
11572 {
11573     const $DESCRIPTOR(name_desc,__pw_namecache);
11574     unsigned short lname;
11575     union uicdef uic;
11576     unsigned long int status;
11577
11578     if (uid == (unsigned int) -1) {
11579       do {
11580         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11581         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11582           set_vaxc_errno(status);
11583           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11584           my_endpwent();
11585           return NULL;
11586         }
11587         else { _ckvmssts(status); }
11588       } while (!valid_uic (uic));
11589     }
11590     else {
11591       uic.uic$l_uic= uid;
11592       if (!uic.uic$v_group)
11593         uic.uic$v_group= PerlProc_getgid();
11594       if (valid_uic(uic))
11595         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11596       else status = SS$_IVIDENT;
11597       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11598           status == RMS$_PRV) {
11599         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11600         return NULL;
11601       }
11602       else { _ckvmssts(status); }
11603     }
11604     __pw_namecache[lname]= '\0';
11605     __mystrtolower(__pw_namecache);
11606
11607     __pwdcache = __passwd_empty;
11608     __pwdcache.pw_name = __pw_namecache;
11609
11610 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11611     The identifier's value is usually the UIC, but it doesn't have to be,
11612     so if we can, we let fillpasswd update this. */
11613     __pwdcache.pw_uid =  uic.uic$l_uic;
11614     __pwdcache.pw_gid =  uic.uic$v_group;
11615
11616     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11617     return &__pwdcache;
11618
11619 }  /* end of my_getpwuid() */
11620 /*}}}*/
11621
11622 /*
11623  * Get information for next user.
11624 */
11625 /*{{{struct passwd *my_getpwent()*/
11626 struct passwd *Perl_my_getpwent(pTHX)
11627 {
11628     return (my_getpwuid((unsigned int) -1));
11629 }
11630 /*}}}*/
11631
11632 /*
11633  * Finish searching rights database for users.
11634 */
11635 /*{{{void my_endpwent()*/
11636 void Perl_my_endpwent(pTHX)
11637 {
11638     if (contxt) {
11639       _ckvmssts(sys$finish_rdb(&contxt));
11640       contxt= 0;
11641     }
11642 }
11643 /*}}}*/
11644
11645 #ifdef HOMEGROWN_POSIX_SIGNALS
11646   /* Signal handling routines, pulled into the core from POSIX.xs.
11647    *
11648    * We need these for threads, so they've been rolled into the core,
11649    * rather than left in POSIX.xs.
11650    *
11651    * (DRS, Oct 23, 1997)
11652    */
11653
11654   /* sigset_t is atomic under VMS, so these routines are easy */
11655 /*{{{int my_sigemptyset(sigset_t *) */
11656 int my_sigemptyset(sigset_t *set) {
11657     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11658     *set = 0; return 0;
11659 }
11660 /*}}}*/
11661
11662
11663 /*{{{int my_sigfillset(sigset_t *)*/
11664 int my_sigfillset(sigset_t *set) {
11665     int i;
11666     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11667     for (i = 0; i < NSIG; i++) *set |= (1 << i);
11668     return 0;
11669 }
11670 /*}}}*/
11671
11672
11673 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
11674 int my_sigaddset(sigset_t *set, int sig) {
11675     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11676     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11677     *set |= (1 << (sig - 1));
11678     return 0;
11679 }
11680 /*}}}*/
11681
11682
11683 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
11684 int my_sigdelset(sigset_t *set, int sig) {
11685     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11686     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11687     *set &= ~(1 << (sig - 1));
11688     return 0;
11689 }
11690 /*}}}*/
11691
11692
11693 /*{{{int my_sigismember(sigset_t *set, int sig)*/
11694 int my_sigismember(sigset_t *set, int sig) {
11695     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11696     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11697     return *set & (1 << (sig - 1));
11698 }
11699 /*}}}*/
11700
11701
11702 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
11703 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
11704     sigset_t tempmask;
11705
11706     /* If set and oset are both null, then things are badly wrong. Bail out. */
11707     if ((oset == NULL) && (set == NULL)) {
11708       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
11709       return -1;
11710     }
11711
11712     /* If set's null, then we're just handling a fetch. */
11713     if (set == NULL) {
11714         tempmask = sigblock(0);
11715     }
11716     else {
11717       switch (how) {
11718       case SIG_SETMASK:
11719         tempmask = sigsetmask(*set);
11720         break;
11721       case SIG_BLOCK:
11722         tempmask = sigblock(*set);
11723         break;
11724       case SIG_UNBLOCK:
11725         tempmask = sigblock(0);
11726         sigsetmask(*oset & ~tempmask);
11727         break;
11728       default:
11729         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11730         return -1;
11731       }
11732     }
11733
11734     /* Did they pass us an oset? If so, stick our holding mask into it */
11735     if (oset)
11736       *oset = tempmask;
11737
11738     return 0;
11739 }
11740 /*}}}*/
11741 #endif  /* HOMEGROWN_POSIX_SIGNALS */
11742
11743
11744 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11745  * my_utime(), and flex_stat(), all of which operate on UTC unless
11746  * VMSISH_TIMES is true.
11747  */
11748 /* method used to handle UTC conversions:
11749  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
11750  */
11751 static int gmtime_emulation_type;
11752 /* number of secs to add to UTC POSIX-style time to get local time */
11753 static long int utc_offset_secs;
11754
11755 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11756  * in vmsish.h.  #undef them here so we can call the CRTL routines
11757  * directly.
11758  */
11759 #undef gmtime
11760 #undef localtime
11761 #undef time
11762
11763
11764 /*
11765  * DEC C previous to 6.0 corrupts the behavior of the /prefix
11766  * qualifier with the extern prefix pragma.  This provisional
11767  * hack circumvents this prefix pragma problem in previous
11768  * precompilers.
11769  */
11770 #if defined(__VMS_VER) && __VMS_VER >= 70000000
11771 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
11772 #    pragma __extern_prefix save
11773 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
11774 #    define gmtime decc$__utctz_gmtime
11775 #    define localtime decc$__utctz_localtime
11776 #    define time decc$__utc_time
11777 #    pragma __extern_prefix restore
11778
11779      struct tm *gmtime(), *localtime();
11780
11781 #  endif
11782 #endif
11783
11784
11785 static time_t toutc_dst(time_t loc) {
11786   struct tm *rsltmp;
11787
11788   if ((rsltmp = localtime(&loc)) == NULL) return -1;
11789   loc -= utc_offset_secs;
11790   if (rsltmp->tm_isdst) loc -= 3600;
11791   return loc;
11792 }
11793 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11794        ((gmtime_emulation_type || my_time(NULL)), \
11795        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11796        ((secs) - utc_offset_secs))))
11797
11798 static time_t toloc_dst(time_t utc) {
11799   struct tm *rsltmp;
11800
11801   utc += utc_offset_secs;
11802   if ((rsltmp = localtime(&utc)) == NULL) return -1;
11803   if (rsltmp->tm_isdst) utc += 3600;
11804   return utc;
11805 }
11806 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11807        ((gmtime_emulation_type || my_time(NULL)), \
11808        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11809        ((secs) + utc_offset_secs))))
11810
11811 #ifndef RTL_USES_UTC
11812 /*
11813
11814     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
11815         DST starts on 1st sun of april      at 02:00  std time
11816             ends on last sun of october     at 02:00  dst time
11817     see the UCX management command reference, SET CONFIG TIMEZONE
11818     for formatting info.
11819
11820     No, it's not as general as it should be, but then again, NOTHING
11821     will handle UK times in a sensible way.
11822 */
11823
11824
11825 /*
11826     parse the DST start/end info:
11827     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
11828 */
11829
11830 static char *
11831 tz_parse_startend(char *s, struct tm *w, int *past)
11832 {
11833     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
11834     int ly, dozjd, d, m, n, hour, min, sec, j, k;
11835     time_t g;
11836
11837     if (!s)    return 0;
11838     if (!w) return 0;
11839     if (!past) return 0;
11840
11841     ly = 0;
11842     if (w->tm_year % 4        == 0) ly = 1;
11843     if (w->tm_year % 100      == 0) ly = 0;
11844     if (w->tm_year+1900 % 400 == 0) ly = 1;
11845     if (ly) dinm[1]++;
11846
11847     dozjd = isdigit(*s);
11848     if (*s == 'J' || *s == 'j' || dozjd) {
11849         if (!dozjd && !isdigit(*++s)) return 0;
11850         d = *s++ - '0';
11851         if (isdigit(*s)) {
11852             d = d*10 + *s++ - '0';
11853             if (isdigit(*s)) {
11854                 d = d*10 + *s++ - '0';
11855             }
11856         }
11857         if (d == 0) return 0;
11858         if (d > 366) return 0;
11859         d--;
11860         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
11861         g = d * 86400;
11862         dozjd = 1;
11863     } else if (*s == 'M' || *s == 'm') {
11864         if (!isdigit(*++s)) return 0;
11865         m = *s++ - '0';
11866         if (isdigit(*s)) m = 10*m + *s++ - '0';
11867         if (*s != '.') return 0;
11868         if (!isdigit(*++s)) return 0;
11869         n = *s++ - '0';
11870         if (n < 1 || n > 5) return 0;
11871         if (*s != '.') return 0;
11872         if (!isdigit(*++s)) return 0;
11873         d = *s++ - '0';
11874         if (d > 6) return 0;
11875     }
11876
11877     if (*s == '/') {
11878         if (!isdigit(*++s)) return 0;
11879         hour = *s++ - '0';
11880         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
11881         if (*s == ':') {
11882             if (!isdigit(*++s)) return 0;
11883             min = *s++ - '0';
11884             if (isdigit(*s)) min = 10*min + *s++ - '0';
11885             if (*s == ':') {
11886                 if (!isdigit(*++s)) return 0;
11887                 sec = *s++ - '0';
11888                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
11889             }
11890         }
11891     } else {
11892         hour = 2;
11893         min = 0;
11894         sec = 0;
11895     }
11896
11897     if (dozjd) {
11898         if (w->tm_yday < d) goto before;
11899         if (w->tm_yday > d) goto after;
11900     } else {
11901         if (w->tm_mon+1 < m) goto before;
11902         if (w->tm_mon+1 > m) goto after;
11903
11904         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
11905         k = d - j; /* mday of first d */
11906         if (k <= 0) k += 7;
11907         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
11908         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
11909         if (w->tm_mday < k) goto before;
11910         if (w->tm_mday > k) goto after;
11911     }
11912
11913     if (w->tm_hour < hour) goto before;
11914     if (w->tm_hour > hour) goto after;
11915     if (w->tm_min  < min)  goto before;
11916     if (w->tm_min  > min)  goto after;
11917     if (w->tm_sec  < sec)  goto before;
11918     goto after;
11919
11920 before:
11921     *past = 0;
11922     return s;
11923 after:
11924     *past = 1;
11925     return s;
11926 }
11927
11928
11929
11930
11931 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
11932
11933 static char *
11934 tz_parse_offset(char *s, int *offset)
11935 {
11936     int hour = 0, min = 0, sec = 0;
11937     int neg = 0;
11938     if (!s) return 0;
11939     if (!offset) return 0;
11940
11941     if (*s == '-') {neg++; s++;}
11942     if (*s == '+') s++;
11943     if (!isdigit(*s)) return 0;
11944     hour = *s++ - '0';
11945     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
11946     if (hour > 24) return 0;
11947     if (*s == ':') {
11948         if (!isdigit(*++s)) return 0;
11949         min = *s++ - '0';
11950         if (isdigit(*s)) min = min*10 + (*s++ - '0');
11951         if (min > 59) return 0;
11952         if (*s == ':') {
11953             if (!isdigit(*++s)) return 0;
11954             sec = *s++ - '0';
11955             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
11956             if (sec > 59) return 0;
11957         }
11958     }
11959
11960     *offset = (hour*60+min)*60 + sec;
11961     if (neg) *offset = -*offset;
11962     return s;
11963 }
11964
11965 /*
11966     input time is w, whatever type of time the CRTL localtime() uses.
11967     sets dst, the zone, and the gmtoff (seconds)
11968
11969     caches the value of TZ and UCX$TZ env variables; note that
11970     my_setenv looks for these and sets a flag if they're changed
11971     for efficiency.
11972
11973     We have to watch out for the "australian" case (dst starts in
11974     october, ends in april)...flagged by "reverse" and checked by
11975     scanning through the months of the previous year.
11976
11977 */
11978
11979 static int
11980 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
11981 {
11982     time_t when;
11983     struct tm *w2;
11984     char *s,*s2;
11985     char *dstzone, *tz, *s_start, *s_end;
11986     int std_off, dst_off, isdst;
11987     int y, dststart, dstend;
11988     static char envtz[1025];  /* longer than any logical, symbol, ... */
11989     static char ucxtz[1025];
11990     static char reversed = 0;
11991
11992     if (!w) return 0;
11993
11994     if (tz_updated) {
11995         tz_updated = 0;
11996         reversed = -1;  /* flag need to check  */
11997         envtz[0] = ucxtz[0] = '\0';
11998         tz = my_getenv("TZ",0);
11999         if (tz) strcpy(envtz, tz);
12000         tz = my_getenv("UCX$TZ",0);
12001         if (tz) strcpy(ucxtz, tz);
12002         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
12003     }
12004     tz = envtz;
12005     if (!*tz) tz = ucxtz;
12006
12007     s = tz;
12008     while (isalpha(*s)) s++;
12009     s = tz_parse_offset(s, &std_off);
12010     if (!s) return 0;
12011     if (!*s) {                  /* no DST, hurray we're done! */
12012         isdst = 0;
12013         goto done;
12014     }
12015
12016     dstzone = s;
12017     while (isalpha(*s)) s++;
12018     s2 = tz_parse_offset(s, &dst_off);
12019     if (s2) {
12020         s = s2;
12021     } else {
12022         dst_off = std_off - 3600;
12023     }
12024
12025     if (!*s) {      /* default dst start/end?? */
12026         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
12027             s = strchr(ucxtz,',');
12028         }
12029         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
12030     }
12031     if (*s != ',') return 0;
12032
12033     when = *w;
12034     when = _toutc(when);      /* convert to utc */
12035     when = when - std_off;    /* convert to pseudolocal time*/
12036
12037     w2 = localtime(&when);
12038     y = w2->tm_year;
12039     s_start = s+1;
12040     s = tz_parse_startend(s_start,w2,&dststart);
12041     if (!s) return 0;
12042     if (*s != ',') return 0;
12043
12044     when = *w;
12045     when = _toutc(when);      /* convert to utc */
12046     when = when - dst_off;    /* convert to pseudolocal time*/
12047     w2 = localtime(&when);
12048     if (w2->tm_year != y) {   /* spans a year, just check one time */
12049         when += dst_off - std_off;
12050         w2 = localtime(&when);
12051     }
12052     s_end = s+1;
12053     s = tz_parse_startend(s_end,w2,&dstend);
12054     if (!s) return 0;
12055
12056     if (reversed == -1) {  /* need to check if start later than end */
12057         int j, ds, de;
12058
12059         when = *w;
12060         if (when < 2*365*86400) {
12061             when += 2*365*86400;
12062         } else {
12063             when -= 365*86400;
12064         }
12065         w2 =localtime(&when);
12066         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
12067
12068         for (j = 0; j < 12; j++) {
12069             w2 =localtime(&when);
12070             tz_parse_startend(s_start,w2,&ds);
12071             tz_parse_startend(s_end,w2,&de);
12072             if (ds != de) break;
12073             when += 30*86400;
12074         }
12075         reversed = 0;
12076         if (de && !ds) reversed = 1;
12077     }
12078
12079     isdst = dststart && !dstend;
12080     if (reversed) isdst = dststart  || !dstend;
12081
12082 done:
12083     if (dst)    *dst = isdst;
12084     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
12085     if (isdst)  tz = dstzone;
12086     if (zone) {
12087         while(isalpha(*tz))  *zone++ = *tz++;
12088         *zone = '\0';
12089     }
12090     return 1;
12091 }
12092
12093 #endif /* !RTL_USES_UTC */
12094
12095 /* my_time(), my_localtime(), my_gmtime()
12096  * By default traffic in UTC time values, using CRTL gmtime() or
12097  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
12098  * Note: We need to use these functions even when the CRTL has working
12099  * UTC support, since they also handle C<use vmsish qw(times);>
12100  *
12101  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
12102  * Modified by Charles Bailey <bailey@newman.upenn.edu>
12103  */
12104
12105 /*{{{time_t my_time(time_t *timep)*/
12106 time_t Perl_my_time(pTHX_ time_t *timep)
12107 {
12108   time_t when;
12109   struct tm *tm_p;
12110
12111   if (gmtime_emulation_type == 0) {
12112     int dstnow;
12113     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
12114                               /* results of calls to gmtime() and localtime() */
12115                               /* for same &base */
12116
12117     gmtime_emulation_type++;
12118     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
12119       char off[LNM$C_NAMLENGTH+1];;
12120
12121       gmtime_emulation_type++;
12122       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
12123         gmtime_emulation_type++;
12124         utc_offset_secs = 0;
12125         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
12126       }
12127       else { utc_offset_secs = atol(off); }
12128     }
12129     else { /* We've got a working gmtime() */
12130       struct tm gmt, local;
12131
12132       gmt = *tm_p;
12133       tm_p = localtime(&base);
12134       local = *tm_p;
12135       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
12136       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
12137       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
12138       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
12139     }
12140   }
12141
12142   when = time(NULL);
12143 # ifdef VMSISH_TIME
12144 # ifdef RTL_USES_UTC
12145   if (VMSISH_TIME) when = _toloc(when);
12146 # else
12147   if (!VMSISH_TIME) when = _toutc(when);
12148 # endif
12149 # endif
12150   if (timep != NULL) *timep = when;
12151   return when;
12152
12153 }  /* end of my_time() */
12154 /*}}}*/
12155
12156
12157 /*{{{struct tm *my_gmtime(const time_t *timep)*/
12158 struct tm *
12159 Perl_my_gmtime(pTHX_ const time_t *timep)
12160 {
12161   char *p;
12162   time_t when;
12163   struct tm *rsltmp;
12164
12165   if (timep == NULL) {
12166     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12167     return NULL;
12168   }
12169   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
12170
12171   when = *timep;
12172 # ifdef VMSISH_TIME
12173   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
12174 #  endif
12175 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
12176   return gmtime(&when);
12177 # else
12178   /* CRTL localtime() wants local time as input, so does no tz correction */
12179   rsltmp = localtime(&when);
12180   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
12181   return rsltmp;
12182 #endif
12183 }  /* end of my_gmtime() */
12184 /*}}}*/
12185
12186
12187 /*{{{struct tm *my_localtime(const time_t *timep)*/
12188 struct tm *
12189 Perl_my_localtime(pTHX_ const time_t *timep)
12190 {
12191   time_t when, whenutc;
12192   struct tm *rsltmp;
12193   int dst, offset;
12194
12195   if (timep == NULL) {
12196     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12197     return NULL;
12198   }
12199   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
12200   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
12201
12202   when = *timep;
12203 # ifdef RTL_USES_UTC
12204 # ifdef VMSISH_TIME
12205   if (VMSISH_TIME) when = _toutc(when);
12206 # endif
12207   /* CRTL localtime() wants UTC as input, does tz correction itself */
12208   return localtime(&when);
12209
12210 # else /* !RTL_USES_UTC */
12211   whenutc = when;
12212 # ifdef VMSISH_TIME
12213   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
12214   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
12215 # endif
12216   dst = -1;
12217 #ifndef RTL_USES_UTC
12218   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
12219       when = whenutc - offset;                   /* pseudolocal time*/
12220   }
12221 # endif
12222   /* CRTL localtime() wants local time as input, so does no tz correction */
12223   rsltmp = localtime(&when);
12224   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
12225   return rsltmp;
12226 # endif
12227
12228 } /*  end of my_localtime() */
12229 /*}}}*/
12230
12231 /* Reset definitions for later calls */
12232 #define gmtime(t)    my_gmtime(t)
12233 #define localtime(t) my_localtime(t)
12234 #define time(t)      my_time(t)
12235
12236
12237 /* my_utime - update modification/access time of a file
12238  *
12239  * VMS 7.3 and later implementation
12240  * Only the UTC translation is home-grown. The rest is handled by the
12241  * CRTL utime(), which will take into account the relevant feature
12242  * logicals and ODS-5 volume characteristics for true access times.
12243  *
12244  * pre VMS 7.3 implementation:
12245  * The calling sequence is identical to POSIX utime(), but under
12246  * VMS with ODS-2, only the modification time is changed; ODS-2 does
12247  * not maintain access times.  Restrictions differ from the POSIX
12248  * definition in that the time can be changed as long as the
12249  * caller has permission to execute the necessary IO$_MODIFY $QIO;
12250  * no separate checks are made to insure that the caller is the
12251  * owner of the file or has special privs enabled.
12252  * Code here is based on Joe Meadows' FILE utility.
12253  *
12254  */
12255
12256 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
12257  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
12258  * in 100 ns intervals.
12259  */
12260 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
12261
12262 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
12263 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
12264 {
12265 #if __CRTL_VER >= 70300000
12266   struct utimbuf utc_utimes, *utc_utimesp;
12267
12268   if (utimes != NULL) {
12269     utc_utimes.actime = utimes->actime;
12270     utc_utimes.modtime = utimes->modtime;
12271 # ifdef VMSISH_TIME
12272     /* If input was local; convert to UTC for sys svc */
12273     if (VMSISH_TIME) {
12274       utc_utimes.actime = _toutc(utimes->actime);
12275       utc_utimes.modtime = _toutc(utimes->modtime);
12276     }
12277 # endif
12278     utc_utimesp = &utc_utimes;
12279   }
12280   else {
12281     utc_utimesp = NULL;
12282   }
12283
12284   return utime(file, utc_utimesp);
12285
12286 #else /* __CRTL_VER < 70300000 */
12287
12288   register int i;
12289   int sts;
12290   long int bintime[2], len = 2, lowbit, unixtime,
12291            secscale = 10000000; /* seconds --> 100 ns intervals */
12292   unsigned long int chan, iosb[2], retsts;
12293   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
12294   struct FAB myfab = cc$rms_fab;
12295   struct NAM mynam = cc$rms_nam;
12296 #if defined (__DECC) && defined (__VAX)
12297   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
12298    * at least through VMS V6.1, which causes a type-conversion warning.
12299    */
12300 #  pragma message save
12301 #  pragma message disable cvtdiftypes
12302 #endif
12303   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
12304   struct fibdef myfib;
12305 #if defined (__DECC) && defined (__VAX)
12306   /* This should be right after the declaration of myatr, but due
12307    * to a bug in VAX DEC C, this takes effect a statement early.
12308    */
12309 #  pragma message restore
12310 #endif
12311   /* cast ok for read only parameter */
12312   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
12313                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
12314                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
12315
12316   if (file == NULL || *file == '\0') {
12317     SETERRNO(ENOENT, LIB$_INVARG);
12318     return -1;
12319   }
12320
12321   /* Convert to VMS format ensuring that it will fit in 255 characters */
12322   if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
12323       SETERRNO(ENOENT, LIB$_INVARG);
12324       return -1;
12325   }
12326   if (utimes != NULL) {
12327     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
12328      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
12329      * Since time_t is unsigned long int, and lib$emul takes a signed long int
12330      * as input, we force the sign bit to be clear by shifting unixtime right
12331      * one bit, then multiplying by an extra factor of 2 in lib$emul().
12332      */
12333     lowbit = (utimes->modtime & 1) ? secscale : 0;
12334     unixtime = (long int) utimes->modtime;
12335 #   ifdef VMSISH_TIME
12336     /* If input was UTC; convert to local for sys svc */
12337     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
12338 #   endif
12339     unixtime >>= 1;  secscale <<= 1;
12340     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
12341     if (!(retsts & 1)) {
12342       SETERRNO(EVMSERR, retsts);
12343       return -1;
12344     }
12345     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
12346     if (!(retsts & 1)) {
12347       SETERRNO(EVMSERR, retsts);
12348       return -1;
12349     }
12350   }
12351   else {
12352     /* Just get the current time in VMS format directly */
12353     retsts = sys$gettim(bintime);
12354     if (!(retsts & 1)) {
12355       SETERRNO(EVMSERR, retsts);
12356       return -1;
12357     }
12358   }
12359
12360   myfab.fab$l_fna = vmsspec;
12361   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
12362   myfab.fab$l_nam = &mynam;
12363   mynam.nam$l_esa = esa;
12364   mynam.nam$b_ess = (unsigned char) sizeof esa;
12365   mynam.nam$l_rsa = rsa;
12366   mynam.nam$b_rss = (unsigned char) sizeof rsa;
12367   if (decc_efs_case_preserve)
12368       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
12369
12370   /* Look for the file to be affected, letting RMS parse the file
12371    * specification for us as well.  I have set errno using only
12372    * values documented in the utime() man page for VMS POSIX.
12373    */
12374   retsts = sys$parse(&myfab,0,0);
12375   if (!(retsts & 1)) {
12376     set_vaxc_errno(retsts);
12377     if      (retsts == RMS$_PRV) set_errno(EACCES);
12378     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
12379     else                         set_errno(EVMSERR);
12380     return -1;
12381   }
12382   retsts = sys$search(&myfab,0,0);
12383   if (!(retsts & 1)) {
12384     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12385     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12386     set_vaxc_errno(retsts);
12387     if      (retsts == RMS$_PRV) set_errno(EACCES);
12388     else if (retsts == RMS$_FNF) set_errno(ENOENT);
12389     else                         set_errno(EVMSERR);
12390     return -1;
12391   }
12392
12393   devdsc.dsc$w_length = mynam.nam$b_dev;
12394   /* cast ok for read only parameter */
12395   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
12396
12397   retsts = sys$assign(&devdsc,&chan,0,0);
12398   if (!(retsts & 1)) {
12399     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12400     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12401     set_vaxc_errno(retsts);
12402     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
12403     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
12404     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
12405     else                               set_errno(EVMSERR);
12406     return -1;
12407   }
12408
12409   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
12410   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
12411
12412   memset((void *) &myfib, 0, sizeof myfib);
12413 #if defined(__DECC) || defined(__DECCXX)
12414   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
12415   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
12416   /* This prevents the revision time of the file being reset to the current
12417    * time as a result of our IO$_MODIFY $QIO. */
12418   myfib.fib$l_acctl = FIB$M_NORECORD;
12419 #else
12420   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
12421   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
12422   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
12423 #endif
12424   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
12425   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12426   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12427   _ckvmssts(sys$dassgn(chan));
12428   if (retsts & 1) retsts = iosb[0];
12429   if (!(retsts & 1)) {
12430     set_vaxc_errno(retsts);
12431     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12432     else                      set_errno(EVMSERR);
12433     return -1;
12434   }
12435
12436   return 0;
12437
12438 #endif /* #if __CRTL_VER >= 70300000 */
12439
12440 }  /* end of my_utime() */
12441 /*}}}*/
12442
12443 /*
12444  * flex_stat, flex_lstat, flex_fstat
12445  * basic stat, but gets it right when asked to stat
12446  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
12447  */
12448
12449 #ifndef _USE_STD_STAT
12450 /* encode_dev packs a VMS device name string into an integer to allow
12451  * simple comparisons. This can be used, for example, to check whether two
12452  * files are located on the same device, by comparing their encoded device
12453  * names. Even a string comparison would not do, because stat() reuses the
12454  * device name buffer for each call; so without encode_dev, it would be
12455  * necessary to save the buffer and use strcmp (this would mean a number of
12456  * changes to the standard Perl code, to say nothing of what a Perl script
12457  * would have to do.
12458  *
12459  * The device lock id, if it exists, should be unique (unless perhaps compared
12460  * with lock ids transferred from other nodes). We have a lock id if the disk is
12461  * mounted cluster-wide, which is when we tend to get long (host-qualified)
12462  * device names. Thus we use the lock id in preference, and only if that isn't
12463  * available, do we try to pack the device name into an integer (flagged by
12464  * the sign bit (LOCKID_MASK) being set).
12465  *
12466  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
12467  * name and its encoded form, but it seems very unlikely that we will find
12468  * two files on different disks that share the same encoded device names,
12469  * and even more remote that they will share the same file id (if the test
12470  * is to check for the same file).
12471  *
12472  * A better method might be to use sys$device_scan on the first call, and to
12473  * search for the device, returning an index into the cached array.
12474  * The number returned would be more intelligible.
12475  * This is probably not worth it, and anyway would take quite a bit longer
12476  * on the first call.
12477  */
12478 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
12479 static mydev_t encode_dev (pTHX_ const char *dev)
12480 {
12481   int i;
12482   unsigned long int f;
12483   mydev_t enc;
12484   char c;
12485   const char *q;
12486
12487   if (!dev || !dev[0]) return 0;
12488
12489 #if LOCKID_MASK
12490   {
12491     struct dsc$descriptor_s dev_desc;
12492     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
12493
12494     /* For cluster-mounted disks, the disk lock identifier is unique, so we
12495        can try that first. */
12496     dev_desc.dsc$w_length =  strlen (dev);
12497     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
12498     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
12499     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
12500     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
12501     if (!$VMS_STATUS_SUCCESS(status)) {
12502       switch (status) {
12503         case SS$_NOSUCHDEV:
12504           SETERRNO(ENODEV, status);
12505           return 0;
12506         default:
12507           _ckvmssts(status);
12508       }
12509     }
12510     if (lockid) return (lockid & ~LOCKID_MASK);
12511   }
12512 #endif
12513
12514   /* Otherwise we try to encode the device name */
12515   enc = 0;
12516   f = 1;
12517   i = 0;
12518   for (q = dev + strlen(dev); q--; q >= dev) {
12519     if (*q == ':')
12520         break;
12521     if (isdigit (*q))
12522       c= (*q) - '0';
12523     else if (isalpha (toupper (*q)))
12524       c= toupper (*q) - 'A' + (char)10;
12525     else
12526       continue; /* Skip '$'s */
12527     i++;
12528     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
12529     if (i>1) f *= 36;
12530     enc += f * (unsigned long int) c;
12531   }
12532   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
12533
12534 }  /* end of encode_dev() */
12535 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12536         device_no = encode_dev(aTHX_ devname)
12537 #else
12538 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12539         device_no = new_dev_no
12540 #endif
12541
12542 static int
12543 is_null_device(name)
12544     const char *name;
12545 {
12546   if (decc_bug_devnull != 0) {
12547     if (strncmp("/dev/null", name, 9) == 0)
12548       return 1;
12549   }
12550     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
12551        The underscore prefix, controller letter, and unit number are
12552        independently optional; for our purposes, the colon punctuation
12553        is not.  The colon can be trailed by optional directory and/or
12554        filename, but two consecutive colons indicates a nodename rather
12555        than a device.  [pr]  */
12556   if (*name == '_') ++name;
12557   if (tolower(*name++) != 'n') return 0;
12558   if (tolower(*name++) != 'l') return 0;
12559   if (tolower(*name) == 'a') ++name;
12560   if (*name == '0') ++name;
12561   return (*name++ == ':') && (*name != ':');
12562 }
12563
12564 static int
12565 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
12566
12567 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
12568
12569 static I32
12570 Perl_cando_by_name_int
12571    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
12572 {
12573   char usrname[L_cuserid];
12574   struct dsc$descriptor_s usrdsc =
12575          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
12576   char *vmsname = NULL, *fileified = NULL;
12577   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
12578   unsigned short int retlen, trnlnm_iter_count;
12579   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12580   union prvdef curprv;
12581   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
12582          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
12583          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
12584   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
12585          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
12586          {0,0,0,0}};
12587   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
12588          {0,0,0,0}};
12589   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12590   Stat_t st;
12591   static int profile_context = -1;
12592
12593   if (!fname || !*fname) return FALSE;
12594
12595   /* Make sure we expand logical names, since sys$check_access doesn't */
12596   fileified = PerlMem_malloc(VMS_MAXRSS);
12597   if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12598   if (!strpbrk(fname,"/]>:")) {
12599       strcpy(fileified,fname);
12600       trnlnm_iter_count = 0;
12601       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
12602         trnlnm_iter_count++;
12603         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
12604       }
12605       fname = fileified;
12606   }
12607
12608   vmsname = PerlMem_malloc(VMS_MAXRSS);
12609   if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12610   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
12611     /* Don't know if already in VMS format, so make sure */
12612     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
12613       PerlMem_free(fileified);
12614       PerlMem_free(vmsname);
12615       return FALSE;
12616     }
12617   }
12618   else {
12619     strcpy(vmsname,fname);
12620   }
12621
12622   /* sys$check_access needs a file spec, not a directory spec.
12623    * flex_stat now will handle a null thread context during startup.
12624    */
12625
12626   retlen = namdsc.dsc$w_length = strlen(vmsname);
12627   if (vmsname[retlen-1] == ']'
12628       || vmsname[retlen-1] == '>'
12629       || vmsname[retlen-1] == ':'
12630       || (!flex_stat_int(vmsname, &st, 1) &&
12631           S_ISDIR(st.st_mode))) {
12632
12633       if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
12634         PerlMem_free(fileified);
12635         PerlMem_free(vmsname);
12636         return FALSE;
12637       }
12638       fname = fileified;
12639   }
12640   else {
12641       fname = vmsname;
12642   }
12643
12644   retlen = namdsc.dsc$w_length = strlen(fname);
12645   namdsc.dsc$a_pointer = (char *)fname;
12646
12647   switch (bit) {
12648     case S_IXUSR: case S_IXGRP: case S_IXOTH:
12649       access = ARM$M_EXECUTE;
12650       flags = CHP$M_READ;
12651       break;
12652     case S_IRUSR: case S_IRGRP: case S_IROTH:
12653       access = ARM$M_READ;
12654       flags = CHP$M_READ | CHP$M_USEREADALL;
12655       break;
12656     case S_IWUSR: case S_IWGRP: case S_IWOTH:
12657       access = ARM$M_WRITE;
12658       flags = CHP$M_READ | CHP$M_WRITE;
12659       break;
12660     case S_IDUSR: case S_IDGRP: case S_IDOTH:
12661       access = ARM$M_DELETE;
12662       flags = CHP$M_READ | CHP$M_WRITE;
12663       break;
12664     default:
12665       if (fileified != NULL)
12666         PerlMem_free(fileified);
12667       if (vmsname != NULL)
12668         PerlMem_free(vmsname);
12669       return FALSE;
12670   }
12671
12672   /* Before we call $check_access, create a user profile with the current
12673    * process privs since otherwise it just uses the default privs from the
12674    * UAF and might give false positives or negatives.  This only works on
12675    * VMS versions v6.0 and later since that's when sys$create_user_profile
12676    * became available.
12677    */
12678
12679   /* get current process privs and username */
12680   _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
12681   _ckvmssts_noperl(iosb[0]);
12682
12683 #if defined(__VMS_VER) && __VMS_VER >= 60000000
12684
12685   /* find out the space required for the profile */
12686   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
12687                                     &usrprodsc.dsc$w_length,&profile_context));
12688
12689   /* allocate space for the profile and get it filled in */
12690   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
12691   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12692   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
12693                                     &usrprodsc.dsc$w_length,&profile_context));
12694
12695   /* use the profile to check access to the file; free profile & analyze results */
12696   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
12697   PerlMem_free(usrprodsc.dsc$a_pointer);
12698   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
12699
12700 #else
12701
12702   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
12703
12704 #endif
12705
12706   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
12707       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
12708       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
12709     set_vaxc_errno(retsts);
12710     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12711     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12712     else set_errno(ENOENT);
12713     if (fileified != NULL)
12714       PerlMem_free(fileified);
12715     if (vmsname != NULL)
12716       PerlMem_free(vmsname);
12717     return FALSE;
12718   }
12719   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12720     if (fileified != NULL)
12721       PerlMem_free(fileified);
12722     if (vmsname != NULL)
12723       PerlMem_free(vmsname);
12724     return TRUE;
12725   }
12726   _ckvmssts_noperl(retsts);
12727
12728   if (fileified != NULL)
12729     PerlMem_free(fileified);
12730   if (vmsname != NULL)
12731     PerlMem_free(vmsname);
12732   return FALSE;  /* Should never get here */
12733
12734 }
12735
12736 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
12737 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12738  * subset of the applicable information.
12739  */
12740 bool
12741 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12742 {
12743   return cando_by_name_int
12744         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12745 }  /* end of cando() */
12746 /*}}}*/
12747
12748
12749 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12750 I32
12751 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12752 {
12753    return cando_by_name_int(bit, effective, fname, 0);
12754
12755 }  /* end of cando_by_name() */
12756 /*}}}*/
12757
12758
12759 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12760 int
12761 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12762 {
12763   if (!fstat(fd, &statbufp->crtl_stat)) {
12764     char *cptr;
12765     char *vms_filename;
12766     vms_filename = PerlMem_malloc(VMS_MAXRSS);
12767     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12768
12769     /* Save name for cando by name in VMS format */
12770     cptr = getname(fd, vms_filename, 1);
12771
12772     /* This should not happen, but just in case */
12773     if (cptr == NULL) {
12774         statbufp->st_devnam[0] = 0;
12775     }
12776     else {
12777         /* Make sure that the saved name fits in 255 characters */
12778         cptr = int_rmsexpand_vms
12779                        (vms_filename,
12780                         statbufp->st_devnam,
12781                         0);
12782         if (cptr == NULL)
12783             statbufp->st_devnam[0] = 0;
12784     }
12785     PerlMem_free(vms_filename);
12786
12787     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12788     VMS_DEVICE_ENCODE
12789         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12790
12791 #   ifdef RTL_USES_UTC
12792 #   ifdef VMSISH_TIME
12793     if (VMSISH_TIME) {
12794       statbufp->st_mtime = _toloc(statbufp->st_mtime);
12795       statbufp->st_atime = _toloc(statbufp->st_atime);
12796       statbufp->st_ctime = _toloc(statbufp->st_ctime);
12797     }
12798 #   endif
12799 #   else
12800 #   ifdef VMSISH_TIME
12801     if (!VMSISH_TIME) { /* Return UTC instead of local time */
12802 #   else
12803     if (1) {
12804 #   endif
12805       statbufp->st_mtime = _toutc(statbufp->st_mtime);
12806       statbufp->st_atime = _toutc(statbufp->st_atime);
12807       statbufp->st_ctime = _toutc(statbufp->st_ctime);
12808     }
12809 #endif
12810     return 0;
12811   }
12812   return -1;
12813
12814 }  /* end of flex_fstat() */
12815 /*}}}*/
12816
12817 static int
12818 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12819 {
12820     char *fileified;
12821     char *temp_fspec;
12822     const char *save_spec;
12823     char *ret_spec;
12824     int retval = -1;
12825     int efs_hack = 0;
12826     dSAVEDERRNO;
12827
12828     if (!fspec) {
12829         errno = EINVAL;
12830         return retval;
12831     }
12832
12833     if (decc_bug_devnull != 0) {
12834       if (is_null_device(fspec)) { /* Fake a stat() for the null device */
12835         memset(statbufp,0,sizeof *statbufp);
12836         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12837         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12838         statbufp->st_uid = 0x00010001;
12839         statbufp->st_gid = 0x0001;
12840         time((time_t *)&statbufp->st_mtime);
12841         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12842         return 0;
12843       }
12844     }
12845
12846     /* Try for a directory name first.  If fspec contains a filename without
12847      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12848      * and sea:[wine.dark]water. exist, we prefer the directory here.
12849      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12850      * not sea:[wine.dark]., if the latter exists.  If the intended target is
12851      * the file with null type, specify this by calling flex_stat() with
12852      * a '.' at the end of fspec.
12853      *
12854      * If we are in Posix filespec mode, accept the filename as is.
12855      */
12856
12857
12858     fileified = PerlMem_malloc(VMS_MAXRSS);
12859     if (fileified == NULL)
12860         _ckvmssts_noperl(SS$_INSFMEM);
12861
12862     temp_fspec = PerlMem_malloc(VMS_MAXRSS);
12863     if (temp_fspec == NULL)
12864         _ckvmssts_noperl(SS$_INSFMEM);
12865
12866     strcpy(temp_fspec, fspec);
12867
12868     SAVE_ERRNO;
12869
12870 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12871   if (decc_posix_compliant_pathnames == 0) {
12872 #endif
12873
12874     /* We may be able to optimize this, but in order for fileify_dirspec to
12875      * always return a usuable answer, we have to call vmspath first to
12876      * make sure that it is in VMS directory format, as stat/lstat on 8.3
12877      * can not handle directories in unix format that it does not have read
12878      * access to.  Vmspath handles the case where a bare name which could be
12879      * a logical name gets passed.
12880      */
12881     ret_spec = int_tovmspath(fspec, temp_fspec, NULL);
12882     if (ret_spec != NULL) {
12883         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
12884         if (ret_spec != NULL) {
12885             if (lstat_flag == 0)
12886                 retval = stat(fileified, &statbufp->crtl_stat);
12887             else
12888                 retval = lstat(fileified, &statbufp->crtl_stat);
12889             save_spec = fileified;
12890         }
12891     }
12892
12893     if (retval && vms_bug_stat_filename) {
12894
12895         /* We should try again as a vmsified file specification */
12896         /* However Perl traditionally has not done this, which  */
12897         /* causes problems with existing tests */
12898
12899         ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12900         if (ret_spec != NULL) {
12901             if (lstat_flag == 0)
12902                 retval = stat(temp_fspec, &statbufp->crtl_stat);
12903             else
12904                 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12905             save_spec = temp_fspec;
12906         }
12907     }
12908
12909     if (retval) {
12910         /* Last chance - allow multiple dots with out EFS CHARSET */
12911         /* The CRTL stat() falls down hard on multi-dot filenames in unix
12912          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12913          * enable it if it isn't already.
12914          */
12915 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12916         if (!decc_efs_charset && (decc_efs_charset_index > 0))
12917             decc$feature_set_value(decc_efs_charset_index, 1, 1);
12918 #endif
12919         if (lstat_flag == 0)
12920             retval = stat(fspec, &statbufp->crtl_stat);
12921         else
12922             retval = lstat(fspec, &statbufp->crtl_stat);
12923         save_spec = fspec;
12924 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12925         if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
12926             decc$feature_set_value(decc_efs_charset_index, 1, 0);
12927             efs_hack = 1;
12928         }
12929 #endif
12930     }
12931
12932 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12933   } else {
12934     if (lstat_flag == 0)
12935       retval = stat(temp_fspec, &statbufp->crtl_stat);
12936     else
12937       retval = lstat(temp_fspec, &statbufp->crtl_stat);
12938       save_spec = temp_fspec;
12939   }
12940 #endif
12941
12942 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12943   /* As you were... */
12944   if (!decc_efs_charset)
12945     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12946 #endif
12947
12948     if (!retval) {
12949     char * cptr;
12950     int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12951
12952       /* If this is an lstat, do not follow the link */
12953       if (lstat_flag)
12954         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12955
12956 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12957       /* If we used the efs_hack above, we must also use it here for */
12958       /* perl_cando to work */
12959       if (efs_hack && (decc_efs_charset_index > 0)) {
12960           decc$feature_set_value(decc_efs_charset_index, 1, 1);
12961       }
12962 #endif
12963       cptr = int_rmsexpand_tovms(save_spec, statbufp->st_devnam, rmsex_flags);
12964 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12965       if (efs_hack && (decc_efs_charset_index > 0)) {
12966           decc$feature_set_value(decc_efs_charset, 1, 0);
12967       }
12968 #endif
12969
12970       /* Fix me: If this is NULL then stat found a file, and we could */
12971       /* not convert the specification to VMS - Should never happen */
12972       if (cptr == NULL)
12973         statbufp->st_devnam[0] = 0;
12974
12975       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12976       VMS_DEVICE_ENCODE
12977         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12978 #     ifdef RTL_USES_UTC
12979 #     ifdef VMSISH_TIME
12980       if (VMSISH_TIME) {
12981         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12982         statbufp->st_atime = _toloc(statbufp->st_atime);
12983         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12984       }
12985 #     endif
12986 #     else
12987 #     ifdef VMSISH_TIME
12988       if (!VMSISH_TIME) { /* Return UTC instead of local time */
12989 #     else
12990       if (1) {
12991 #     endif
12992         statbufp->st_mtime = _toutc(statbufp->st_mtime);
12993         statbufp->st_atime = _toutc(statbufp->st_atime);
12994         statbufp->st_ctime = _toutc(statbufp->st_ctime);
12995       }
12996 #     endif
12997     }
12998     /* If we were successful, leave errno where we found it */
12999     if (retval == 0) RESTORE_ERRNO;
13000     return retval;
13001
13002 }  /* end of flex_stat_int() */
13003
13004
13005 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
13006 int
13007 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
13008 {
13009    return flex_stat_int(fspec, statbufp, 0);
13010 }
13011 /*}}}*/
13012
13013 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
13014 int
13015 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
13016 {
13017    return flex_stat_int(fspec, statbufp, 1);
13018 }
13019 /*}}}*/
13020
13021
13022 /*{{{char *my_getlogin()*/
13023 /* VMS cuserid == Unix getlogin, except calling sequence */
13024 char *
13025 my_getlogin(void)
13026 {
13027     static char user[L_cuserid];
13028     return cuserid(user);
13029 }
13030 /*}}}*/
13031
13032
13033 /*  rmscopy - copy a file using VMS RMS routines
13034  *
13035  *  Copies contents and attributes of spec_in to spec_out, except owner
13036  *  and protection information.  Name and type of spec_in are used as
13037  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
13038  *  should try to propagate timestamps from the input file to the output file.
13039  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
13040  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
13041  *  propagated to the output file at creation iff the output file specification
13042  *  did not contain an explicit name or type, and the revision date is always
13043  *  updated at the end of the copy operation.  If it is greater than 0, then
13044  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
13045  *  other than the revision date should be propagated, and bit 1 indicates
13046  *  that the revision date should be propagated.
13047  *
13048  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
13049  *
13050  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
13051  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
13052  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
13053  * as part of the Perl standard distribution under the terms of the
13054  * GNU General Public License or the Perl Artistic License.  Copies
13055  * of each may be found in the Perl standard distribution.
13056  */ /* FIXME */
13057 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
13058 int
13059 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
13060 {
13061     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
13062          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
13063     unsigned long int i, sts, sts2;
13064     int dna_len;
13065     struct FAB fab_in, fab_out;
13066     struct RAB rab_in, rab_out;
13067     rms_setup_nam(nam);
13068     rms_setup_nam(nam_out);
13069     struct XABDAT xabdat;
13070     struct XABFHC xabfhc;
13071     struct XABRDT xabrdt;
13072     struct XABSUM xabsum;
13073
13074     vmsin = PerlMem_malloc(VMS_MAXRSS);
13075     if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13076     vmsout = PerlMem_malloc(VMS_MAXRSS);
13077     if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13078     if (!spec_in  || !*spec_in  || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
13079         !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
13080       PerlMem_free(vmsin);
13081       PerlMem_free(vmsout);
13082       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13083       return 0;
13084     }
13085
13086     esa = PerlMem_malloc(VMS_MAXRSS);
13087     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13088     esal = NULL;
13089 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
13090     esal = PerlMem_malloc(VMS_MAXRSS);
13091     if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13092 #endif
13093     fab_in = cc$rms_fab;
13094     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
13095     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
13096     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
13097     fab_in.fab$l_fop = FAB$M_SQO;
13098     rms_bind_fab_nam(fab_in, nam);
13099     fab_in.fab$l_xab = (void *) &xabdat;
13100
13101     rsa = PerlMem_malloc(VMS_MAXRSS);
13102     if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13103     rsal = NULL;
13104 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
13105     rsal = PerlMem_malloc(VMS_MAXRSS);
13106     if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13107 #endif
13108     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
13109     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
13110     rms_nam_esl(nam) = 0;
13111     rms_nam_rsl(nam) = 0;
13112     rms_nam_esll(nam) = 0;
13113     rms_nam_rsll(nam) = 0;
13114 #ifdef NAM$M_NO_SHORT_UPCASE
13115     if (decc_efs_case_preserve)
13116         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
13117 #endif
13118
13119     xabdat = cc$rms_xabdat;        /* To get creation date */
13120     xabdat.xab$l_nxt = (void *) &xabfhc;
13121
13122     xabfhc = cc$rms_xabfhc;        /* To get record length */
13123     xabfhc.xab$l_nxt = (void *) &xabsum;
13124
13125     xabsum = cc$rms_xabsum;        /* To get key and area information */
13126
13127     if (!((sts = sys$open(&fab_in)) & 1)) {
13128       PerlMem_free(vmsin);
13129       PerlMem_free(vmsout);
13130       PerlMem_free(esa);
13131       if (esal != NULL)
13132         PerlMem_free(esal);
13133       PerlMem_free(rsa);
13134       if (rsal != NULL)
13135         PerlMem_free(rsal);
13136       set_vaxc_errno(sts);
13137       switch (sts) {
13138         case RMS$_FNF: case RMS$_DNF:
13139           set_errno(ENOENT); break;
13140         case RMS$_DIR:
13141           set_errno(ENOTDIR); break;
13142         case RMS$_DEV:
13143           set_errno(ENODEV); break;
13144         case RMS$_SYN:
13145           set_errno(EINVAL); break;
13146         case RMS$_PRV:
13147           set_errno(EACCES); break;
13148         default:
13149           set_errno(EVMSERR);
13150       }
13151       return 0;
13152     }
13153
13154     nam_out = nam;
13155     fab_out = fab_in;
13156     fab_out.fab$w_ifi = 0;
13157     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
13158     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
13159     fab_out.fab$l_fop = FAB$M_SQO;
13160     rms_bind_fab_nam(fab_out, nam_out);
13161     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
13162     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
13163     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
13164     esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
13165     if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13166     rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
13167     if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13168     esal_out = NULL;
13169     rsal_out = NULL;
13170 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
13171     esal_out = PerlMem_malloc(VMS_MAXRSS);
13172     if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13173     rsal_out = PerlMem_malloc(VMS_MAXRSS);
13174     if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13175 #endif
13176     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
13177     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
13178
13179     if (preserve_dates == 0) {  /* Act like DCL COPY */
13180       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
13181       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
13182       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
13183         PerlMem_free(vmsin);
13184         PerlMem_free(vmsout);
13185         PerlMem_free(esa);
13186         if (esal != NULL)
13187             PerlMem_free(esal);
13188         PerlMem_free(rsa);
13189         if (rsal != NULL)
13190             PerlMem_free(rsal);
13191         PerlMem_free(esa_out);
13192         if (esal_out != NULL)
13193             PerlMem_free(esal_out);
13194         PerlMem_free(rsa_out);
13195         if (rsal_out != NULL)
13196             PerlMem_free(rsal_out);
13197         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
13198         set_vaxc_errno(sts);
13199         return 0;
13200       }
13201       fab_out.fab$l_xab = (void *) &xabdat;
13202       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
13203         preserve_dates = 1;
13204     }
13205     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
13206       preserve_dates =0;      /* bitmask from this point forward   */
13207
13208     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
13209     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
13210       PerlMem_free(vmsin);
13211       PerlMem_free(vmsout);
13212       PerlMem_free(esa);
13213       if (esal != NULL)
13214           PerlMem_free(esal);
13215       PerlMem_free(rsa);
13216       if (rsal != NULL)
13217           PerlMem_free(rsal);
13218       PerlMem_free(esa_out);
13219       if (esal_out != NULL)
13220           PerlMem_free(esal_out);
13221       PerlMem_free(rsa_out);
13222       if (rsal_out != NULL)
13223           PerlMem_free(rsal_out);
13224       set_vaxc_errno(sts);
13225       switch (sts) {
13226         case RMS$_DNF:
13227           set_errno(ENOENT); break;
13228         case RMS$_DIR:
13229           set_errno(ENOTDIR); break;
13230         case RMS$_DEV:
13231           set_errno(ENODEV); break;
13232         case RMS$_SYN:
13233           set_errno(EINVAL); break;
13234         case RMS$_PRV:
13235           set_errno(EACCES); break;
13236         default:
13237           set_errno(EVMSERR);
13238       }
13239       return 0;
13240     }
13241     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
13242     if (preserve_dates & 2) {
13243       /* sys$close() will process xabrdt, not xabdat */
13244       xabrdt = cc$rms_xabrdt;
13245 #ifndef __GNUC__
13246       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
13247 #else
13248       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
13249        * is unsigned long[2], while DECC & VAXC use a struct */
13250       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
13251 #endif
13252       fab_out.fab$l_xab = (void *) &xabrdt;
13253     }
13254
13255     ubf = PerlMem_malloc(32256);
13256     if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13257     rab_in = cc$rms_rab;
13258     rab_in.rab$l_fab = &fab_in;
13259     rab_in.rab$l_rop = RAB$M_BIO;
13260     rab_in.rab$l_ubf = ubf;
13261     rab_in.rab$w_usz = 32256;
13262     if (!((sts = sys$connect(&rab_in)) & 1)) {
13263       sys$close(&fab_in); sys$close(&fab_out);
13264       PerlMem_free(vmsin);
13265       PerlMem_free(vmsout);
13266       PerlMem_free(ubf);
13267       PerlMem_free(esa);
13268       if (esal != NULL)
13269           PerlMem_free(esal);
13270       PerlMem_free(rsa);
13271       if (rsal != NULL)
13272           PerlMem_free(rsal);
13273       PerlMem_free(esa_out);
13274       if (esal_out != NULL)
13275           PerlMem_free(esal_out);
13276       PerlMem_free(rsa_out);
13277       if (rsal_out != NULL)
13278           PerlMem_free(rsal_out);
13279       set_errno(EVMSERR); set_vaxc_errno(sts);
13280       return 0;
13281     }
13282
13283     rab_out = cc$rms_rab;
13284     rab_out.rab$l_fab = &fab_out;
13285     rab_out.rab$l_rbf = ubf;
13286     if (!((sts = sys$connect(&rab_out)) & 1)) {
13287       sys$close(&fab_in); sys$close(&fab_out);
13288       PerlMem_free(vmsin);
13289       PerlMem_free(vmsout);
13290       PerlMem_free(ubf);
13291       PerlMem_free(esa);
13292       if (esal != NULL)
13293           PerlMem_free(esal);
13294       PerlMem_free(rsa);
13295       if (rsal != NULL)
13296           PerlMem_free(rsal);
13297       PerlMem_free(esa_out);
13298       if (esal_out != NULL)
13299           PerlMem_free(esal_out);
13300       PerlMem_free(rsa_out);
13301       if (rsal_out != NULL)
13302           PerlMem_free(rsal_out);
13303       set_errno(EVMSERR); set_vaxc_errno(sts);
13304       return 0;
13305     }
13306
13307     while ((sts = sys$read(&rab_in))) {  /* always true  */
13308       if (sts == RMS$_EOF) break;
13309       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
13310       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
13311         sys$close(&fab_in); sys$close(&fab_out);
13312         PerlMem_free(vmsin);
13313         PerlMem_free(vmsout);
13314         PerlMem_free(ubf);
13315         PerlMem_free(esa);
13316         if (esal != NULL)
13317             PerlMem_free(esal);
13318         PerlMem_free(rsa);
13319         if (rsal != NULL)
13320             PerlMem_free(rsal);
13321         PerlMem_free(esa_out);
13322         if (esal_out != NULL)
13323             PerlMem_free(esal_out);
13324         PerlMem_free(rsa_out);
13325         if (rsal_out != NULL)
13326             PerlMem_free(rsal_out);
13327         set_errno(EVMSERR); set_vaxc_errno(sts);
13328         return 0;
13329       }
13330     }
13331
13332
13333     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
13334     sys$close(&fab_in);  sys$close(&fab_out);
13335     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
13336
13337     PerlMem_free(vmsin);
13338     PerlMem_free(vmsout);
13339     PerlMem_free(ubf);
13340     PerlMem_free(esa);
13341     if (esal != NULL)
13342         PerlMem_free(esal);
13343     PerlMem_free(rsa);
13344     if (rsal != NULL)
13345         PerlMem_free(rsal);
13346     PerlMem_free(esa_out);
13347     if (esal_out != NULL)
13348         PerlMem_free(esal_out);
13349     PerlMem_free(rsa_out);
13350     if (rsal_out != NULL)
13351         PerlMem_free(rsal_out);
13352
13353     if (!(sts & 1)) {
13354       set_errno(EVMSERR); set_vaxc_errno(sts);
13355       return 0;
13356     }
13357
13358     return 1;
13359
13360 }  /* end of rmscopy() */
13361 /*}}}*/
13362
13363
13364 /***  The following glue provides 'hooks' to make some of the routines
13365  * from this file available from Perl.  These routines are sufficiently
13366  * basic, and are required sufficiently early in the build process,
13367  * that's it's nice to have them available to miniperl as well as the
13368  * full Perl, so they're set up here instead of in an extension.  The
13369  * Perl code which handles importation of these names into a given
13370  * package lives in [.VMS]Filespec.pm in @INC.
13371  */
13372
13373 void
13374 rmsexpand_fromperl(pTHX_ CV *cv)
13375 {
13376   dXSARGS;
13377   char *fspec, *defspec = NULL, *rslt;
13378   STRLEN n_a;
13379   int fs_utf8, dfs_utf8;
13380
13381   fs_utf8 = 0;
13382   dfs_utf8 = 0;
13383   if (!items || items > 2)
13384     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
13385   fspec = SvPV(ST(0),n_a);
13386   fs_utf8 = SvUTF8(ST(0));
13387   if (!fspec || !*fspec) XSRETURN_UNDEF;
13388   if (items == 2) {
13389     defspec = SvPV(ST(1),n_a);
13390     dfs_utf8 = SvUTF8(ST(1));
13391   }
13392   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
13393   ST(0) = sv_newmortal();
13394   if (rslt != NULL) {
13395     sv_usepvn(ST(0),rslt,strlen(rslt));
13396     if (fs_utf8) {
13397         SvUTF8_on(ST(0));
13398     }
13399   }
13400   XSRETURN(1);
13401 }
13402
13403 void
13404 vmsify_fromperl(pTHX_ CV *cv)
13405 {
13406   dXSARGS;
13407   char *vmsified;
13408   STRLEN n_a;
13409   int utf8_fl;
13410
13411   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
13412   utf8_fl = SvUTF8(ST(0));
13413   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13414   ST(0) = sv_newmortal();
13415   if (vmsified != NULL) {
13416     sv_usepvn(ST(0),vmsified,strlen(vmsified));
13417     if (utf8_fl) {
13418         SvUTF8_on(ST(0));
13419     }
13420   }
13421   XSRETURN(1);
13422 }
13423
13424 void
13425 unixify_fromperl(pTHX_ CV *cv)
13426 {
13427   dXSARGS;
13428   char *unixified;
13429   STRLEN n_a;
13430   int utf8_fl;
13431
13432   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
13433   utf8_fl = SvUTF8(ST(0));
13434   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13435   ST(0) = sv_newmortal();
13436   if (unixified != NULL) {
13437     sv_usepvn(ST(0),unixified,strlen(unixified));
13438     if (utf8_fl) {
13439         SvUTF8_on(ST(0));
13440     }
13441   }
13442   XSRETURN(1);
13443 }
13444
13445 void
13446 fileify_fromperl(pTHX_ CV *cv)
13447 {
13448   dXSARGS;
13449   char *fileified;
13450   STRLEN n_a;
13451   int utf8_fl;
13452
13453   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
13454   utf8_fl = SvUTF8(ST(0));
13455   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13456   ST(0) = sv_newmortal();
13457   if (fileified != NULL) {
13458     sv_usepvn(ST(0),fileified,strlen(fileified));
13459     if (utf8_fl) {
13460         SvUTF8_on(ST(0));
13461     }
13462   }
13463   XSRETURN(1);
13464 }
13465
13466 void
13467 pathify_fromperl(pTHX_ CV *cv)
13468 {
13469   dXSARGS;
13470   char *pathified;
13471   STRLEN n_a;
13472   int utf8_fl;
13473
13474   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
13475   utf8_fl = SvUTF8(ST(0));
13476   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13477   ST(0) = sv_newmortal();
13478   if (pathified != NULL) {
13479     sv_usepvn(ST(0),pathified,strlen(pathified));
13480     if (utf8_fl) {
13481         SvUTF8_on(ST(0));
13482     }
13483   }
13484   XSRETURN(1);
13485 }
13486
13487 void
13488 vmspath_fromperl(pTHX_ CV *cv)
13489 {
13490   dXSARGS;
13491   char *vmspath;
13492   STRLEN n_a;
13493   int utf8_fl;
13494
13495   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
13496   utf8_fl = SvUTF8(ST(0));
13497   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13498   ST(0) = sv_newmortal();
13499   if (vmspath != NULL) {
13500     sv_usepvn(ST(0),vmspath,strlen(vmspath));
13501     if (utf8_fl) {
13502         SvUTF8_on(ST(0));
13503     }
13504   }
13505   XSRETURN(1);
13506 }
13507
13508 void
13509 unixpath_fromperl(pTHX_ CV *cv)
13510 {
13511   dXSARGS;
13512   char *unixpath;
13513   STRLEN n_a;
13514   int utf8_fl;
13515
13516   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
13517   utf8_fl = SvUTF8(ST(0));
13518   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13519   ST(0) = sv_newmortal();
13520   if (unixpath != NULL) {
13521     sv_usepvn(ST(0),unixpath,strlen(unixpath));
13522     if (utf8_fl) {
13523         SvUTF8_on(ST(0));
13524     }
13525   }
13526   XSRETURN(1);
13527 }
13528
13529 void
13530 candelete_fromperl(pTHX_ CV *cv)
13531 {
13532   dXSARGS;
13533   char *fspec, *fsp;
13534   SV *mysv;
13535   IO *io;
13536   STRLEN n_a;
13537
13538   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
13539
13540   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13541   Newx(fspec, VMS_MAXRSS, char);
13542   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
13543   if (SvTYPE(mysv) == SVt_PVGV) {
13544     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
13545       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13546       ST(0) = &PL_sv_no;
13547       Safefree(fspec);
13548       XSRETURN(1);
13549     }
13550     fsp = fspec;
13551   }
13552   else {
13553     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
13554       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13555       ST(0) = &PL_sv_no;
13556       Safefree(fspec);
13557       XSRETURN(1);
13558     }
13559   }
13560
13561   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
13562   Safefree(fspec);
13563   XSRETURN(1);
13564 }
13565
13566 void
13567 rmscopy_fromperl(pTHX_ CV *cv)
13568 {
13569   dXSARGS;
13570   char *inspec, *outspec, *inp, *outp;
13571   int date_flag;
13572   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
13573                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13574   unsigned long int sts;
13575   SV *mysv;
13576   IO *io;
13577   STRLEN n_a;
13578
13579   if (items < 2 || items > 3)
13580     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
13581
13582   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13583   Newx(inspec, VMS_MAXRSS, char);
13584   if (SvTYPE(mysv) == SVt_PVGV) {
13585     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
13586       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13587       ST(0) = sv_2mortal(newSViv(0));
13588       Safefree(inspec);
13589       XSRETURN(1);
13590     }
13591     inp = inspec;
13592   }
13593   else {
13594     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
13595       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13596       ST(0) = sv_2mortal(newSViv(0));
13597       Safefree(inspec);
13598       XSRETURN(1);
13599     }
13600   }
13601   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
13602   Newx(outspec, VMS_MAXRSS, char);
13603   if (SvTYPE(mysv) == SVt_PVGV) {
13604     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
13605       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13606       ST(0) = sv_2mortal(newSViv(0));
13607       Safefree(inspec);
13608       Safefree(outspec);
13609       XSRETURN(1);
13610     }
13611     outp = outspec;
13612   }
13613   else {
13614     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
13615       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13616       ST(0) = sv_2mortal(newSViv(0));
13617       Safefree(inspec);
13618       Safefree(outspec);
13619       XSRETURN(1);
13620     }
13621   }
13622   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
13623
13624   ST(0) = sv_2mortal(newSViv(rmscopy(inp,outp,date_flag)));
13625   Safefree(inspec);
13626   Safefree(outspec);
13627   XSRETURN(1);
13628 }
13629
13630 /* The mod2fname is limited to shorter filenames by design, so it should
13631  * not be modified to support longer EFS pathnames
13632  */
13633 void
13634 mod2fname(pTHX_ CV *cv)
13635 {
13636   dXSARGS;
13637   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
13638        workbuff[NAM$C_MAXRSS*1 + 1];
13639   int total_namelen = 3, counter, num_entries;
13640   /* ODS-5 ups this, but we want to be consistent, so... */
13641   int max_name_len = 39;
13642   AV *in_array = (AV *)SvRV(ST(0));
13643
13644   num_entries = av_len(in_array);
13645
13646   /* All the names start with PL_. */
13647   strcpy(ultimate_name, "PL_");
13648
13649   /* Clean up our working buffer */
13650   Zero(work_name, sizeof(work_name), char);
13651
13652   /* Run through the entries and build up a working name */
13653   for(counter = 0; counter <= num_entries; counter++) {
13654     /* If it's not the first name then tack on a __ */
13655     if (counter) {
13656       strcat(work_name, "__");
13657     }
13658     strcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)));
13659   }
13660
13661   /* Check to see if we actually have to bother...*/
13662   if (strlen(work_name) + 3 <= max_name_len) {
13663     strcat(ultimate_name, work_name);
13664   } else {
13665     /* It's too darned big, so we need to go strip. We use the same */
13666     /* algorithm as xsubpp does. First, strip out doubled __ */
13667     char *source, *dest, last;
13668     dest = workbuff;
13669     last = 0;
13670     for (source = work_name; *source; source++) {
13671       if (last == *source && last == '_') {
13672         continue;
13673       }
13674       *dest++ = *source;
13675       last = *source;
13676     }
13677     /* Go put it back */
13678     strcpy(work_name, workbuff);
13679     /* Is it still too big? */
13680     if (strlen(work_name) + 3 > max_name_len) {
13681       /* Strip duplicate letters */
13682       last = 0;
13683       dest = workbuff;
13684       for (source = work_name; *source; source++) {
13685         if (last == toupper(*source)) {
13686         continue;
13687         }
13688         *dest++ = *source;
13689         last = toupper(*source);
13690       }
13691       strcpy(work_name, workbuff);
13692     }
13693
13694     /* Is it *still* too big? */
13695     if (strlen(work_name) + 3 > max_name_len) {
13696       /* Too bad, we truncate */
13697       work_name[max_name_len - 2] = 0;
13698     }
13699     strcat(ultimate_name, work_name);
13700   }
13701
13702   /* Okay, return it */
13703   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
13704   XSRETURN(1);
13705 }
13706
13707 void
13708 hushexit_fromperl(pTHX_ CV *cv)
13709 {
13710     dXSARGS;
13711
13712     if (items > 0) {
13713         VMSISH_HUSHED = SvTRUE(ST(0));
13714     }
13715     ST(0) = boolSV(VMSISH_HUSHED);
13716     XSRETURN(1);
13717 }
13718
13719
13720 PerlIO *
13721 Perl_vms_start_glob
13722    (pTHX_ SV *tmpglob,
13723     IO *io)
13724 {
13725     PerlIO *fp;
13726     struct vs_str_st *rslt;
13727     char *vmsspec;
13728     char *rstr;
13729     char *begin, *cp;
13730     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13731     PerlIO *tmpfp;
13732     STRLEN i;
13733     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13734     struct dsc$descriptor_vs rsdsc;
13735     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13736     unsigned long hasver = 0, isunix = 0;
13737     unsigned long int lff_flags = 0;
13738     int rms_sts;
13739     int vms_old_glob = 1;
13740
13741     if (!SvOK(tmpglob)) {
13742         SETERRNO(ENOENT,RMS$_FNF);
13743         return NULL;
13744     }
13745
13746     vms_old_glob = !decc_filename_unix_report;
13747
13748 #ifdef VMS_LONGNAME_SUPPORT
13749     lff_flags = LIB$M_FIL_LONG_NAMES;
13750 #endif
13751     /* The Newx macro will not allow me to assign a smaller array
13752      * to the rslt pointer, so we will assign it to the begin char pointer
13753      * and then copy the value into the rslt pointer.
13754      */
13755     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13756     rslt = (struct vs_str_st *)begin;
13757     rslt->length = 0;
13758     rstr = &rslt->str[0];
13759     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13760     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13761     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13762     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13763
13764     Newx(vmsspec, VMS_MAXRSS, char);
13765
13766         /* We could find out if there's an explicit dev/dir or version
13767            by peeking into lib$find_file's internal context at
13768            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13769            but that's unsupported, so I don't want to do it now and
13770            have it bite someone in the future. */
13771         /* Fix-me: vms_split_path() is the only way to do this, the
13772            existing method will fail with many legal EFS or UNIX specifications
13773          */
13774
13775     cp = SvPV(tmpglob,i);
13776
13777     for (; i; i--) {
13778         if (cp[i] == ';') hasver = 1;
13779         if (cp[i] == '.') {
13780             if (sts) hasver = 1;
13781             else sts = 1;
13782         }
13783         if (cp[i] == '/') {
13784             hasdir = isunix = 1;
13785             break;
13786         }
13787         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13788             hasdir = 1;
13789             break;
13790         }
13791     }
13792
13793     /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13794     if ((hasdir == 0) && decc_filename_unix_report) {
13795         isunix = 1;
13796     }
13797
13798     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13799         char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13800         int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13801         int wildstar = 0;
13802         int wildquery = 0;
13803         int found = 0;
13804         Stat_t st;
13805         int stat_sts;
13806         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13807         if (!stat_sts && S_ISDIR(st.st_mode)) {
13808             char * vms_dir;
13809             const char * fname;
13810             STRLEN fname_len;
13811
13812             /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13813             /* path delimiter of ':>]', if so, then the old behavior has */
13814             /* obviously been specificially requested */
13815
13816             fname = SvPVX_const(tmpglob);
13817             fname_len = strlen(fname);
13818             vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13819             if (vms_old_glob || (vms_dir != NULL)) {
13820                 wilddsc.dsc$a_pointer = tovmspath_utf8(
13821                                             SvPVX(tmpglob),vmsspec,NULL);
13822                 ok = (wilddsc.dsc$a_pointer != NULL);
13823                 /* maybe passed 'foo' rather than '[.foo]', thus not
13824                    detected above */
13825                 hasdir = 1;
13826             } else {
13827                 /* Operate just on the directory, the special stat/fstat for */
13828                 /* leaves the fileified  specification in the st_devnam */
13829                 /* member. */
13830                 wilddsc.dsc$a_pointer = st.st_devnam;
13831                 ok = 1;
13832             }
13833         }
13834         else {
13835             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13836             ok = (wilddsc.dsc$a_pointer != NULL);
13837         }
13838         if (ok)
13839             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13840
13841         /* If not extended character set, replace ? with % */
13842         /* With extended character set, ? is a wildcard single character */
13843         for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13844             if (*cp == '?') {
13845                 wildquery = 1;
13846                 if (!decc_efs_case_preserve)
13847                     *cp = '%';
13848             } else if (*cp == '%') {
13849                 wildquery = 1;
13850             } else if (*cp == '*') {
13851                 wildstar = 1;
13852             }
13853         }
13854
13855         if (ok) {
13856             wv_sts = vms_split_path(
13857                 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13858                 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13859                 &wvs_spec, &wvs_len);
13860         } else {
13861             wn_spec = NULL;
13862             wn_len = 0;
13863             we_spec = NULL;
13864             we_len = 0;
13865         }
13866
13867         sts = SS$_NORMAL;
13868         while (ok && $VMS_STATUS_SUCCESS(sts)) {
13869          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13870          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13871          int valid_find;
13872
13873             valid_find = 0;
13874             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13875                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
13876             if (!$VMS_STATUS_SUCCESS(sts))
13877                 break;
13878
13879             /* with varying string, 1st word of buffer contains result length */
13880             rstr[rslt->length] = '\0';
13881
13882              /* Find where all the components are */
13883              v_sts = vms_split_path
13884                        (rstr,
13885                         &v_spec,
13886                         &v_len,
13887                         &r_spec,
13888                         &r_len,
13889                         &d_spec,
13890                         &d_len,
13891                         &n_spec,
13892                         &n_len,
13893                         &e_spec,
13894                         &e_len,
13895                         &vs_spec,
13896                         &vs_len);
13897
13898             /* If no version on input, truncate the version on output */
13899             if (!hasver && (vs_len > 0)) {
13900                 *vs_spec = '\0';
13901                 vs_len = 0;
13902             }
13903
13904             if (isunix) {
13905
13906                 /* In Unix report mode, remove the ".dir;1" from the name */
13907                 /* if it is a real directory */
13908                 if (decc_filename_unix_report || decc_efs_charset) {
13909                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13910                         Stat_t statbuf;
13911                         int ret_sts;
13912
13913                         ret_sts = flex_lstat(rstr, &statbuf);
13914                         if ((ret_sts == 0) &&
13915                             S_ISDIR(statbuf.st_mode)) {
13916                             e_len = 0;
13917                             e_spec[0] = 0;
13918                         }
13919                     }
13920                 }
13921
13922                 /* No version & a null extension on UNIX handling */
13923                 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13924                     e_len = 0;
13925                     *e_spec = '\0';
13926                 }
13927             }
13928
13929             if (!decc_efs_case_preserve) {
13930                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13931             }
13932
13933             /* Find File treats a Null extension as return all extensions */
13934             /* This is contrary to Perl expectations */
13935
13936             if (wildstar || wildquery || vms_old_glob) {
13937                 /* really need to see if the returned file name matched */
13938                 /* but for now will assume that it matches */
13939                 valid_find = 1;
13940             } else {
13941                 /* Exact Match requested */
13942                 /* How are directories handled? - like a file */
13943                 if ((e_len == we_len) && (n_len == wn_len)) {
13944                     int t1;
13945                     t1 = e_len;
13946                     if (t1 > 0)
13947                         t1 = strncmp(e_spec, we_spec, e_len);
13948                     if (t1 == 0) {
13949                        t1 = n_len;
13950                        if (t1 > 0)
13951                            t1 = strncmp(n_spec, we_spec, n_len);
13952                        if (t1 == 0)
13953                            valid_find = 1;
13954                     }
13955                 }
13956             }
13957
13958             if (valid_find) {
13959                 found++;
13960
13961                 if (hasdir) {
13962                     if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13963                     begin = rstr;
13964                 }
13965                 else {
13966                     /* Start with the name */
13967                     begin = n_spec;
13968                 }
13969                 strcat(begin,"\n");
13970                 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13971             }
13972         }
13973         if (cxt) (void)lib$find_file_end(&cxt);
13974
13975         if (!found) {
13976             /* Be POSIXish: return the input pattern when no matches */
13977             strcpy(rstr,SvPVX(tmpglob));
13978             strcat(rstr,"\n");
13979             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13980         }
13981
13982         if (ok && sts != RMS$_NMF &&
13983             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13984         if (!ok) {
13985             if (!(sts & 1)) {
13986                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13987             }
13988             PerlIO_close(tmpfp);
13989             fp = NULL;
13990         }
13991         else {
13992             PerlIO_rewind(tmpfp);
13993             IoTYPE(io) = IoTYPE_RDONLY;
13994             IoIFP(io) = fp = tmpfp;
13995             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
13996         }
13997     }
13998     Safefree(vmsspec);
13999     Safefree(rslt);
14000     return fp;
14001 }
14002
14003
14004 static char *
14005 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
14006                    int *utf8_fl);
14007
14008 void
14009 unixrealpath_fromperl(pTHX_ CV *cv)
14010 {
14011     dXSARGS;
14012     char *fspec, *rslt_spec, *rslt;
14013     STRLEN n_a;
14014
14015     if (!items || items != 1)
14016         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
14017
14018     fspec = SvPV(ST(0),n_a);
14019     if (!fspec || !*fspec) XSRETURN_UNDEF;
14020
14021     Newx(rslt_spec, VMS_MAXRSS + 1, char);
14022     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
14023
14024     ST(0) = sv_newmortal();
14025     if (rslt != NULL)
14026         sv_usepvn(ST(0),rslt,strlen(rslt));
14027     else
14028         Safefree(rslt_spec);
14029         XSRETURN(1);
14030 }
14031
14032 static char *
14033 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
14034                    int *utf8_fl);
14035
14036 void
14037 vmsrealpath_fromperl(pTHX_ CV *cv)
14038 {
14039     dXSARGS;
14040     char *fspec, *rslt_spec, *rslt;
14041     STRLEN n_a;
14042
14043     if (!items || items != 1)
14044         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
14045
14046     fspec = SvPV(ST(0),n_a);
14047     if (!fspec || !*fspec) XSRETURN_UNDEF;
14048
14049     Newx(rslt_spec, VMS_MAXRSS + 1, char);
14050     rslt = do_vms_realname(fspec, rslt_spec, NULL);
14051
14052     ST(0) = sv_newmortal();
14053     if (rslt != NULL)
14054         sv_usepvn(ST(0),rslt,strlen(rslt));
14055     else
14056         Safefree(rslt_spec);
14057         XSRETURN(1);
14058 }
14059
14060 #ifdef HAS_SYMLINK
14061 /*
14062  * A thin wrapper around decc$symlink to make sure we follow the
14063  * standard and do not create a symlink with a zero-length name.
14064  *
14065  * Also in ODS-2 mode, existing tests assume that the link target
14066  * will be converted to UNIX format.
14067  */
14068 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
14069 int Perl_my_symlink(pTHX_ const char *contents, const char *link_name) {
14070   if (!link_name || !*link_name) {
14071     SETERRNO(ENOENT, SS$_NOSUCHFILE);
14072     return -1;
14073   }
14074
14075   if (decc_efs_charset) {
14076       return symlink(contents, link_name);
14077   } else {
14078       int sts;
14079       char * utarget;
14080
14081       /* Unless we are in ODS-5 mode, convert the symlink target to UNIX */
14082       /* because in order to work, the symlink target must be in UNIX format */
14083
14084       /* As symbolic links can hold things other than files, we will only do */
14085       /* the conversion in in ODS-2 mode */
14086
14087       utarget = PerlMem_malloc(VMS_MAXRSS + 1);
14088       if (int_tounixspec(contents, utarget, NULL) == NULL) {
14089
14090           /* This should not fail, as an untranslatable filename */
14091           /* should be passed through */
14092           utarget = (char *)contents;
14093       }
14094       sts = symlink(utarget, link_name);
14095       PerlMem_free(utarget);
14096       return sts;
14097   }
14098
14099 }
14100 /*}}}*/
14101
14102 #endif /* HAS_SYMLINK */
14103
14104 int do_vms_case_tolerant(void);
14105
14106 void
14107 case_tolerant_process_fromperl(pTHX_ CV *cv)
14108 {
14109   dXSARGS;
14110   ST(0) = boolSV(do_vms_case_tolerant());
14111   XSRETURN(1);
14112 }
14113
14114 #ifdef USE_ITHREADS
14115
14116 void
14117 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
14118                           struct interp_intern *dst)
14119 {
14120     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
14121
14122     memcpy(dst,src,sizeof(struct interp_intern));
14123 }
14124
14125 #endif
14126
14127 void
14128 Perl_sys_intern_clear(pTHX)
14129 {
14130 }
14131
14132 void
14133 Perl_sys_intern_init(pTHX)
14134 {
14135     unsigned int ix = RAND_MAX;
14136     double x;
14137
14138     VMSISH_HUSHED = 0;
14139
14140     MY_POSIX_EXIT = vms_posix_exit;
14141
14142     x = (float)ix;
14143     MY_INV_RAND_MAX = 1./x;
14144 }
14145
14146 void
14147 init_os_extras(void)
14148 {
14149   dTHX;
14150   char* file = __FILE__;
14151   if (decc_disable_to_vms_logname_translation) {
14152     no_translate_barewords = TRUE;
14153   } else {
14154     no_translate_barewords = FALSE;
14155   }
14156
14157   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
14158   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
14159   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
14160   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
14161   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
14162   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
14163   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
14164   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
14165   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
14166   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
14167   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
14168   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
14169   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
14170   newXSproto("VMS::Filespec::case_tolerant_process",
14171       case_tolerant_process_fromperl,file,"");
14172
14173   store_pipelocs(aTHX);         /* will redo any earlier attempts */
14174
14175   return;
14176 }
14177
14178 #if __CRTL_VER == 80200000
14179 /* This missed getting in to the DECC SDK for 8.2 */
14180 char *realpath(const char *file_name, char * resolved_name, ...);
14181 #endif
14182
14183 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
14184 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
14185  * The perl fallback routine to provide realpath() is not as efficient
14186  * on OpenVMS.
14187  */
14188
14189 /* Hack, use old stat() as fastest way of getting ino_t and device */
14190 int decc$stat(const char *name, void * statbuf);
14191 #if !defined(__VAX) && __CRTL_VER >= 80200000
14192 int decc$lstat(const char *name, void * statbuf);
14193 #else
14194 #define decc$lstat decc$stat
14195 #endif
14196
14197
14198 /* Realpath is fragile.  In 8.3 it does not work if the feature
14199  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
14200  * links are implemented in RMS, not the CRTL. It also can fail if the
14201  * user does not have read/execute access to some of the directories.
14202  * So in order for Do What I Mean mode to work, if realpath() fails,
14203  * fall back to looking up the filename by the device name and FID.
14204  */
14205
14206 int vms_fid_to_name(char * outname, int outlen,
14207                     const char * name, int lstat_flag, mode_t * mode)
14208 {
14209 #pragma message save
14210 #pragma message disable MISALGNDSTRCT
14211 #pragma message disable MISALGNDMEM
14212 #pragma member_alignment save
14213 #pragma nomember_alignment
14214 struct statbuf_t {
14215     char           * st_dev;
14216     unsigned short st_ino[3];
14217     unsigned short old_st_mode;
14218     unsigned long  padl[30];  /* plenty of room */
14219 } statbuf;
14220 #pragma message restore
14221 #pragma member_alignment restore
14222
14223     int sts;
14224     struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
14225     struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
14226     char *fileified;
14227     char *temp_fspec;
14228     char *ret_spec;
14229
14230     /* Need to follow the mostly the same rules as flex_stat_int, or we may get
14231      * unexpected answers
14232      */
14233
14234     fileified = PerlMem_malloc(VMS_MAXRSS);
14235     if (fileified == NULL)
14236         _ckvmssts_noperl(SS$_INSFMEM);
14237
14238     temp_fspec = PerlMem_malloc(VMS_MAXRSS);
14239     if (temp_fspec == NULL)
14240         _ckvmssts_noperl(SS$_INSFMEM);
14241
14242     sts = -1;
14243     /* First need to try as a directory */
14244     ret_spec = int_tovmspath(name, temp_fspec, NULL);
14245     if (ret_spec != NULL) {
14246         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
14247         if (ret_spec != NULL) {
14248             if (lstat_flag == 0)
14249                 sts = decc$stat(fileified, &statbuf);
14250             else
14251                 sts = decc$lstat(fileified, &statbuf);
14252         }
14253     }
14254
14255     /* Then as a VMS file spec */
14256     if (sts != 0) {
14257         ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
14258         if (ret_spec != NULL) {
14259             if (lstat_flag == 0) {
14260                 sts = decc$stat(temp_fspec, &statbuf);
14261             } else {
14262                 sts = decc$lstat(temp_fspec, &statbuf);
14263             }
14264         }
14265     }
14266
14267     if (sts) {
14268         /* Next try - allow multiple dots with out EFS CHARSET */
14269         /* The CRTL stat() falls down hard on multi-dot filenames in unix
14270          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
14271          * enable it if it isn't already.
14272          */
14273 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14274         if (!decc_efs_charset && (decc_efs_charset_index > 0))
14275             decc$feature_set_value(decc_efs_charset_index, 1, 1);
14276 #endif
14277         ret_spec = int_tovmspath(name, temp_fspec, NULL);
14278         if (lstat_flag == 0) {
14279             sts = decc$stat(name, &statbuf);
14280         } else {
14281             sts = decc$lstat(name, &statbuf);
14282         }
14283 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14284         if (!decc_efs_charset && (decc_efs_charset_index > 0))
14285             decc$feature_set_value(decc_efs_charset_index, 1, 0);
14286 #endif
14287     }
14288
14289
14290     /* and then because the Perl Unix to VMS conversion is not perfect */
14291     /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
14292     /* characters from filenames so we need to try it as-is */
14293     if (sts) {
14294         if (lstat_flag == 0) {
14295             sts = decc$stat(name, &statbuf);
14296         } else {
14297             sts = decc$lstat(name, &statbuf);
14298         }
14299     }
14300
14301     if (sts == 0) {
14302         int vms_sts;
14303
14304         dvidsc.dsc$a_pointer=statbuf.st_dev;
14305         dvidsc.dsc$w_length=strlen(statbuf.st_dev);
14306
14307         specdsc.dsc$a_pointer = outname;
14308         specdsc.dsc$w_length = outlen-1;
14309
14310         vms_sts = lib$fid_to_name
14311             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
14312         if ($VMS_STATUS_SUCCESS(vms_sts)) {
14313             outname[specdsc.dsc$w_length] = 0;
14314
14315             /* Return the mode */
14316             if (mode) {
14317                 *mode = statbuf.old_st_mode;
14318             }
14319             return 0;
14320         }
14321     }
14322     return sts;
14323 }
14324
14325
14326
14327 static char *
14328 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
14329                    int *utf8_fl)
14330 {
14331     char * rslt = NULL;
14332
14333 #ifdef HAS_SYMLINK
14334     if (decc_posix_compliant_pathnames > 0 ) {
14335         /* realpath currently only works if posix compliant pathnames are
14336          * enabled.  It may start working when they are not, but in that
14337          * case we still want the fallback behavior for backwards compatibility
14338          */
14339         rslt = realpath(filespec, outbuf);
14340     }
14341 #endif
14342
14343     if (rslt == NULL) {
14344         char * vms_spec;
14345         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
14346         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
14347         int file_len;
14348         mode_t my_mode;
14349
14350         /* Fall back to fid_to_name */
14351
14352         Newx(vms_spec, VMS_MAXRSS + 1, char);
14353
14354         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
14355         if (sts == 0) {
14356
14357
14358             /* Now need to trim the version off */
14359             sts = vms_split_path
14360                   (vms_spec,
14361                    &v_spec,
14362                    &v_len,
14363                    &r_spec,
14364                    &r_len,
14365                    &d_spec,
14366                    &d_len,
14367                    &n_spec,
14368                    &n_len,
14369                    &e_spec,
14370                    &e_len,
14371                    &vs_spec,
14372                    &vs_len);
14373
14374
14375                 if (sts == 0) {
14376                     int haslower = 0;
14377                     const char *cp;
14378
14379                     /* Trim off the version */
14380                     int file_len = v_len + r_len + d_len + n_len + e_len;
14381                     vms_spec[file_len] = 0;
14382
14383                     /* Trim off the .DIR if this is a directory */
14384                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
14385                         if (S_ISDIR(my_mode)) {
14386                             e_len = 0;
14387                             e_spec[0] = 0;
14388                         }
14389                     }
14390
14391                     /* Drop NULL extensions on UNIX file specification */
14392                     if ((e_len == 1) && decc_readdir_dropdotnotype) {
14393                         e_len = 0;
14394                         e_spec[0] = '\0';
14395                     }
14396
14397                     /* The result is expected to be in UNIX format */
14398                     rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
14399
14400                     /* Downcase if input had any lower case letters and
14401                      * case preservation is not in effect.
14402                      */
14403                     if (!decc_efs_case_preserve) {
14404                         for (cp = filespec; *cp; cp++)
14405                             if (islower(*cp)) { haslower = 1; break; }
14406
14407                         if (haslower) __mystrtolower(rslt);
14408                     }
14409                 }
14410         } else {
14411
14412             /* Now for some hacks to deal with backwards and forward */
14413             /* compatibilty */
14414             if (!decc_efs_charset) {
14415
14416                 /* 1. ODS-2 mode wants to do a syntax only translation */
14417                 rslt = int_rmsexpand(filespec, outbuf,
14418                                     NULL, 0, NULL, utf8_fl);
14419
14420             } else {
14421                 if (decc_filename_unix_report) {
14422                     char * dir_name;
14423                     char * vms_dir_name;
14424                     char * file_name;
14425
14426                     /* 2. ODS-5 / UNIX report mode should return a failure */
14427                     /*    if the parent directory also does not exist */
14428                     /*    Otherwise, get the real path for the parent */
14429                     /*    and add the child to it.
14430
14431                     /* basename / dirname only available for VMS 7.0+ */
14432                     /* So we may need to implement them as common routines */
14433
14434                     Newx(dir_name, VMS_MAXRSS + 1, char);
14435                     Newx(vms_dir_name, VMS_MAXRSS + 1, char);
14436                     dir_name[0] = '\0';
14437                     file_name = NULL;
14438
14439                     /* First try a VMS parse */
14440                     sts = vms_split_path
14441                           (filespec,
14442                            &v_spec,
14443                            &v_len,
14444                            &r_spec,
14445                            &r_len,
14446                            &d_spec,
14447                            &d_len,
14448                            &n_spec,
14449                            &n_len,
14450                            &e_spec,
14451                            &e_len,
14452                            &vs_spec,
14453                            &vs_len);
14454
14455                     if (sts == 0) {
14456                         /* This is VMS */
14457
14458                         int dir_len = v_len + r_len + d_len + n_len;
14459                         if (dir_len > 0) {
14460                            strncpy(dir_name, filespec, dir_len);
14461                            dir_name[dir_len] = '\0';
14462                            file_name = (char *)&filespec[dir_len + 1];
14463                         }
14464                     } else {
14465                         /* This must be UNIX */
14466                         char * tchar;
14467
14468                         tchar = strrchr(filespec, '/');
14469
14470                         if (tchar != NULL) {
14471                             int dir_len = tchar - filespec;
14472                             strncpy(dir_name, filespec, dir_len);
14473                             dir_name[dir_len] = '\0';
14474                             file_name = (char *) &filespec[dir_len + 1];
14475                         }
14476                     }
14477
14478                     /* Dir name is defaulted */
14479                     if (dir_name[0] == 0) {
14480                         dir_name[0] = '.';
14481                         dir_name[1] = '\0';
14482                     }
14483
14484                     /* Need realpath for the directory */
14485                     sts = vms_fid_to_name(vms_dir_name,
14486                                           VMS_MAXRSS + 1,
14487                                           dir_name, 0, NULL);
14488
14489                     if (sts == 0) {
14490                         /* Now need to pathify it.
14491                         char *tdir = int_pathify_dirspec(vms_dir_name,
14492                                                          outbuf);
14493
14494                         /* And now add the original filespec to it */
14495                         if (file_name != NULL) {
14496                             strcat(outbuf, file_name);
14497                         }
14498                         return outbuf;
14499                     }
14500                     Safefree(vms_dir_name);
14501                     Safefree(dir_name);
14502                 }
14503             }
14504         }
14505         Safefree(vms_spec);
14506     }
14507     return rslt;
14508 }
14509
14510 static char *
14511 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
14512                    int *utf8_fl)
14513 {
14514     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
14515     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
14516     int file_len;
14517
14518     /* Fall back to fid_to_name */
14519
14520     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
14521     if (sts != 0) {
14522         return NULL;
14523     }
14524     else {
14525
14526
14527         /* Now need to trim the version off */
14528         sts = vms_split_path
14529                   (outbuf,
14530                    &v_spec,
14531                    &v_len,
14532                    &r_spec,
14533                    &r_len,
14534                    &d_spec,
14535                    &d_len,
14536                    &n_spec,
14537                    &n_len,
14538                    &e_spec,
14539                    &e_len,
14540                    &vs_spec,
14541                    &vs_len);
14542
14543
14544         if (sts == 0) {
14545             int haslower = 0;
14546             const char *cp;
14547
14548             /* Trim off the version */
14549             int file_len = v_len + r_len + d_len + n_len + e_len;
14550             outbuf[file_len] = 0;
14551
14552             /* Downcase if input had any lower case letters and
14553              * case preservation is not in effect.
14554              */
14555             if (!decc_efs_case_preserve) {
14556                 for (cp = filespec; *cp; cp++)
14557                     if (islower(*cp)) { haslower = 1; break; }
14558
14559                 if (haslower) __mystrtolower(outbuf);
14560             }
14561         }
14562     }
14563     return outbuf;
14564 }
14565
14566
14567 /*}}}*/
14568 /* External entry points */
14569 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
14570 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
14571
14572 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
14573 { return do_vms_realname(filespec, outbuf, utf8_fl); }
14574
14575 /* case_tolerant */
14576
14577 /*{{{int do_vms_case_tolerant(void)*/
14578 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
14579  * controlled by a process setting.
14580  */
14581 int do_vms_case_tolerant(void)
14582 {
14583     return vms_process_case_tolerant;
14584 }
14585 /*}}}*/
14586 /* External entry points */
14587 #if __CRTL_VER >= 70301000 && !defined(__VAX)
14588 int Perl_vms_case_tolerant(void)
14589 { return do_vms_case_tolerant(); }
14590 #else
14591 int Perl_vms_case_tolerant(void)
14592 { return vms_process_case_tolerant; }
14593 #endif
14594
14595
14596  /* Start of DECC RTL Feature handling */
14597
14598 static int sys_trnlnm
14599    (const char * logname,
14600     char * value,
14601     int value_len)
14602 {
14603     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
14604     const unsigned long attr = LNM$M_CASE_BLIND;
14605     struct dsc$descriptor_s name_dsc;
14606     int status;
14607     unsigned short result;
14608     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
14609                                 {0, 0, 0, 0}};
14610
14611     name_dsc.dsc$w_length = strlen(logname);
14612     name_dsc.dsc$a_pointer = (char *)logname;
14613     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14614     name_dsc.dsc$b_class = DSC$K_CLASS_S;
14615
14616     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
14617
14618     if ($VMS_STATUS_SUCCESS(status)) {
14619
14620          /* Null terminate and return the string */
14621         /*--------------------------------------*/
14622         value[result] = 0;
14623     }
14624
14625     return status;
14626 }
14627
14628 static int sys_crelnm
14629    (const char * logname,
14630     const char * value)
14631 {
14632     int ret_val;
14633     const char * proc_table = "LNM$PROCESS_TABLE";
14634     struct dsc$descriptor_s proc_table_dsc;
14635     struct dsc$descriptor_s logname_dsc;
14636     struct itmlst_3 item_list[2];
14637
14638     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
14639     proc_table_dsc.dsc$w_length = strlen(proc_table);
14640     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14641     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
14642
14643     logname_dsc.dsc$a_pointer = (char *) logname;
14644     logname_dsc.dsc$w_length = strlen(logname);
14645     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14646     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
14647
14648     item_list[0].buflen = strlen(value);
14649     item_list[0].itmcode = LNM$_STRING;
14650     item_list[0].bufadr = (char *)value;
14651     item_list[0].retlen = NULL;
14652
14653     item_list[1].buflen = 0;
14654     item_list[1].itmcode = 0;
14655
14656     ret_val = sys$crelnm
14657                        (NULL,
14658                         (const struct dsc$descriptor_s *)&proc_table_dsc,
14659                         (const struct dsc$descriptor_s *)&logname_dsc,
14660                         NULL,
14661                         (const struct item_list_3 *) item_list);
14662
14663     return ret_val;
14664 }
14665
14666 /* C RTL Feature settings */
14667
14668 static int set_features
14669    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
14670     int (* cli_routine)(void),  /* Not documented */
14671     void *image_info)           /* Not documented */
14672 {
14673     int status;
14674     int s;
14675     char* str;
14676     char val_str[10];
14677 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
14678     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
14679     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
14680     unsigned long case_perm;
14681     unsigned long case_image;
14682 #endif
14683
14684     /* Allow an exception to bring Perl into the VMS debugger */
14685     vms_debug_on_exception = 0;
14686     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
14687     if ($VMS_STATUS_SUCCESS(status)) {
14688        val_str[0] = _toupper(val_str[0]);
14689        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14690          vms_debug_on_exception = 1;
14691        else
14692          vms_debug_on_exception = 0;
14693     }
14694
14695     /* Debug unix/vms file translation routines */
14696     vms_debug_fileify = 0;
14697     status = sys_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
14698     if ($VMS_STATUS_SUCCESS(status)) {
14699         val_str[0] = _toupper(val_str[0]);
14700         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14701             vms_debug_fileify = 1;
14702         else
14703             vms_debug_fileify = 0;
14704     }
14705
14706
14707     /* Historically PERL has been doing vmsify / stat differently than */
14708     /* the CRTL.  In particular, under some conditions the CRTL will   */
14709     /* remove some illegal characters like spaces from filenames       */
14710     /* resulting in some differences.  The stat()/lstat() wrapper has  */
14711     /* been reporting such file names as invalid and fails to stat them */
14712     /* fixing this bug so that stat()/lstat() accept these like the     */
14713     /* CRTL does will result in several tests failing.                  */
14714     /* This should really be fixed, but for now, set up a feature to    */
14715     /* enable it so that the impact can be studied.                     */
14716     vms_bug_stat_filename = 0;
14717     status = sys_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
14718     if ($VMS_STATUS_SUCCESS(status)) {
14719         val_str[0] = _toupper(val_str[0]);
14720         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14721             vms_bug_stat_filename = 1;
14722         else
14723             vms_bug_stat_filename = 0;
14724     }
14725
14726
14727     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
14728     vms_vtf7_filenames = 0;
14729     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
14730     if ($VMS_STATUS_SUCCESS(status)) {
14731        val_str[0] = _toupper(val_str[0]);
14732        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14733          vms_vtf7_filenames = 1;
14734        else
14735          vms_vtf7_filenames = 0;
14736     }
14737
14738     /* unlink all versions on unlink() or rename() */
14739     vms_unlink_all_versions = 0;
14740     status = sys_trnlnm
14741         ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
14742     if ($VMS_STATUS_SUCCESS(status)) {
14743        val_str[0] = _toupper(val_str[0]);
14744        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14745          vms_unlink_all_versions = 1;
14746        else
14747          vms_unlink_all_versions = 0;
14748     }
14749
14750     /* Dectect running under GNV Bash or other UNIX like shell */
14751 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14752     gnv_unix_shell = 0;
14753     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
14754     if ($VMS_STATUS_SUCCESS(status)) {
14755          gnv_unix_shell = 1;
14756          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
14757          set_feature_default("DECC$EFS_CHARSET", 1);
14758          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
14759          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
14760          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
14761          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
14762          vms_unlink_all_versions = 1;
14763          vms_posix_exit = 1;
14764     }
14765 #endif
14766
14767     /* hacks to see if known bugs are still present for testing */
14768
14769     /* PCP mode requires creating /dev/null special device file */
14770     decc_bug_devnull = 0;
14771     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14772     if ($VMS_STATUS_SUCCESS(status)) {
14773        val_str[0] = _toupper(val_str[0]);
14774        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14775           decc_bug_devnull = 1;
14776        else
14777           decc_bug_devnull = 0;
14778     }
14779
14780     /* UNIX directory names with no paths are broken in a lot of places */
14781     decc_dir_barename = 1;
14782     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
14783     if ($VMS_STATUS_SUCCESS(status)) {
14784       val_str[0] = _toupper(val_str[0]);
14785       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14786         decc_dir_barename = 1;
14787       else
14788         decc_dir_barename = 0;
14789     }
14790
14791 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14792     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14793     if (s >= 0) {
14794         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14795         if (decc_disable_to_vms_logname_translation < 0)
14796             decc_disable_to_vms_logname_translation = 0;
14797     }
14798
14799     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14800     if (s >= 0) {
14801         decc_efs_case_preserve = decc$feature_get_value(s, 1);
14802         if (decc_efs_case_preserve < 0)
14803             decc_efs_case_preserve = 0;
14804     }
14805
14806     s = decc$feature_get_index("DECC$EFS_CHARSET");
14807     decc_efs_charset_index = s;
14808     if (s >= 0) {
14809         decc_efs_charset = decc$feature_get_value(s, 1);
14810         if (decc_efs_charset < 0)
14811             decc_efs_charset = 0;
14812     }
14813
14814     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14815     if (s >= 0) {
14816         decc_filename_unix_report = decc$feature_get_value(s, 1);
14817         if (decc_filename_unix_report > 0) {
14818             decc_filename_unix_report = 1;
14819             vms_posix_exit = 1;
14820         }
14821         else
14822             decc_filename_unix_report = 0;
14823     }
14824
14825     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14826     if (s >= 0) {
14827         decc_filename_unix_only = decc$feature_get_value(s, 1);
14828         if (decc_filename_unix_only > 0) {
14829             decc_filename_unix_only = 1;
14830         }
14831         else {
14832             decc_filename_unix_only = 0;
14833         }
14834     }
14835
14836     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14837     if (s >= 0) {
14838         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14839         if (decc_filename_unix_no_version < 0)
14840             decc_filename_unix_no_version = 0;
14841     }
14842
14843     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14844     if (s >= 0) {
14845         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14846         if (decc_readdir_dropdotnotype < 0)
14847             decc_readdir_dropdotnotype = 0;
14848     }
14849
14850 #if __CRTL_VER >= 80200000
14851     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14852     if (s >= 0) {
14853         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14854         if (decc_posix_compliant_pathnames < 0)
14855             decc_posix_compliant_pathnames = 0;
14856         if (decc_posix_compliant_pathnames > 4)
14857             decc_posix_compliant_pathnames = 0;
14858     }
14859
14860 #endif
14861 #else
14862     status = sys_trnlnm
14863         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
14864     if ($VMS_STATUS_SUCCESS(status)) {
14865         val_str[0] = _toupper(val_str[0]);
14866         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14867            decc_disable_to_vms_logname_translation = 1;
14868         }
14869     }
14870
14871 #ifndef __VAX
14872     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
14873     if ($VMS_STATUS_SUCCESS(status)) {
14874         val_str[0] = _toupper(val_str[0]);
14875         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14876            decc_efs_case_preserve = 1;
14877         }
14878     }
14879 #endif
14880
14881     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14882     if ($VMS_STATUS_SUCCESS(status)) {
14883         val_str[0] = _toupper(val_str[0]);
14884         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14885            decc_filename_unix_report = 1;
14886         }
14887     }
14888     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14889     if ($VMS_STATUS_SUCCESS(status)) {
14890         val_str[0] = _toupper(val_str[0]);
14891         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14892            decc_filename_unix_only = 1;
14893            decc_filename_unix_report = 1;
14894         }
14895     }
14896     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14897     if ($VMS_STATUS_SUCCESS(status)) {
14898         val_str[0] = _toupper(val_str[0]);
14899         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14900            decc_filename_unix_no_version = 1;
14901         }
14902     }
14903     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
14904     if ($VMS_STATUS_SUCCESS(status)) {
14905         val_str[0] = _toupper(val_str[0]);
14906         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14907            decc_readdir_dropdotnotype = 1;
14908         }
14909     }
14910 #endif
14911
14912 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
14913
14914      /* Report true case tolerance */
14915     /*----------------------------*/
14916     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14917     if (!$VMS_STATUS_SUCCESS(status))
14918         case_perm = PPROP$K_CASE_BLIND;
14919     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14920     if (!$VMS_STATUS_SUCCESS(status))
14921         case_image = PPROP$K_CASE_BLIND;
14922     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14923         (case_image == PPROP$K_CASE_SENSITIVE))
14924         vms_process_case_tolerant = 0;
14925
14926 #endif
14927
14928     /* USE POSIX/DCL Exit codes - Recommended, but needs to default to  */
14929     /* for strict backward compatibilty */
14930     status = sys_trnlnm
14931         ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14932     if ($VMS_STATUS_SUCCESS(status)) {
14933        val_str[0] = _toupper(val_str[0]);
14934        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14935          vms_posix_exit = 1;
14936        else
14937          vms_posix_exit = 0;
14938     }
14939
14940
14941     /* CRTL can be initialized past this point, but not before. */
14942 /*    DECC$CRTL_INIT(); */
14943
14944     return SS$_NORMAL;
14945 }
14946
14947 #ifdef __DECC
14948 #pragma nostandard
14949 #pragma extern_model save
14950 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
14951         const __align (LONGWORD) int spare[8] = {0};
14952
14953 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
14954 #if __DECC_VER >= 60560002
14955 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
14956 #else
14957 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
14958 #endif
14959 #endif /* __DECC */
14960
14961 const long vms_cc_features = (const long)set_features;
14962
14963 /*
14964 ** Force a reference to LIB$INITIALIZE to ensure it
14965 ** exists in the image.
14966 */
14967 int lib$initialize(void);
14968 #ifdef __DECC
14969 #pragma extern_model strict_refdef
14970 #endif
14971     int lib_init_ref = (int) lib$initialize;
14972
14973 #ifdef __DECC
14974 #pragma extern_model restore
14975 #pragma standard
14976 #endif
14977
14978 /*  End of vms.c */