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 #include <acedef.h>
  15 #include <acldef.h>
  16 #include <armdef.h>
  17 #include <atrdef.h>
  18 #include <chpdef.h>
  19 #include <clidef.h>
  20 #include <climsgdef.h>
  21 #include <dcdef.h>
  22 #include <descrip.h>
  23 #include <devdef.h>
  24 #include <dvidef.h>
  25 #include <fibdef.h>
  26 #include <float.h>
  27 #include <fscndef.h>
  28 #include <iodef.h>
  29 #include <jpidef.h>
  30 #include <kgbdef.h>
  31 #include <libclidef.h>
  32 #include <libdef.h>
  33 #include <lib$routines.h>
  34 #include <lnmdef.h>
  35 #include <msgdef.h>
  36 #include <ossdef.h>
  37 #if __CRTL_VER >= 70301000 && !defined(__VAX)
  38 #include <ppropdef.h>
  39 #endif
  40 #include <prvdef.h>
  41 #include <psldef.h>
  42 #include <rms.h>
  43 #include <shrdef.h>
  44 #include <ssdef.h>
  45 #include <starlet.h>
  46 #include <strdef.h>
  47 #include <str$routines.h>
  48 #include <syidef.h>
  49 #include <uaidef.h>
  50 #include <uicdef.h>
  51 #include <stsdef.h>
  52 #include <rmsdef.h>
  53 #include <smgdef.h>
  54 #if __CRTL_VER >= 70000000 /* FIXME to earliest version */
  55 #include <efndef.h>
  56 #define NO_EFN EFN$C_ENF
  57 #else
  58 #define NO_EFN 0;
  59 #endif
  60
  61 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  62 int   decc$feature_get_index(const char *name);
  63 char* decc$feature_get_name(int index);
  64 int   decc$feature_get_value(int index, int mode);
  65 int   decc$feature_set_value(int index, int mode, int value);
  66 #else
  67 #include <unixlib.h>
  68 #endif
  69
  70 #pragma member_alignment save
  71 #pragma nomember_alignment longword
  72 struct item_list_3 {
  73         unsigned short len;
  74         unsigned short code;
  75         void * bufadr;
  76         unsigned short * retadr;
  77 };
  78 #pragma member_alignment restore
  79
  80 /* More specific prototype than in starlet_c.h makes programming errors
  81    more visible.
  82  */
  83 #ifdef sys$getdviw
  84 #undef sys$getdviw
  85 int sys$getdviw
  86        (unsigned long efn,
  87         unsigned short chan,
  88         const struct dsc$descriptor_s * devnam,
  89         const struct item_list_3 * itmlst,
  90         void * iosb,
  91         void * (astadr)(unsigned long),
  92         void * astprm,
  93         void * nullarg);
  94 #endif
  95
  96 #ifdef sys$get_security
  97 #undef sys$get_security
  98 int sys$get_security
  99        (const struct dsc$descriptor_s * clsnam,
 100         const struct dsc$descriptor_s * objnam,
 101         const unsigned int *objhan,
 102         unsigned int flags,
 103         const struct item_list_3 * itmlst,
 104         unsigned int * contxt,
 105         const unsigned int * acmode);
 106 #endif
 107
 108 #ifdef sys$set_security
 109 #undef sys$set_security
 110 int sys$set_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 lib$find_image_symbol
 121 #undef lib$find_image_symbol
 122 int lib$find_image_symbol
 123        (const struct dsc$descriptor_s * imgname,
 124         const struct dsc$descriptor_s * symname,
 125         void * symval,
 126         const struct dsc$descriptor_s * defspec,
 127         unsigned long flag);
 128 #endif
 129
 130 #ifdef lib$rename_file
 131 #undef lib$rename_file
 132 int lib$rename_file
 133        (const struct dsc$descriptor_s * old_file_dsc,
 134         const struct dsc$descriptor_s * new_file_dsc,
 135         const struct dsc$descriptor_s * default_file_dsc,
 136         const struct dsc$descriptor_s * related_file_dsc,
 137         const unsigned long * flags,
 138         void * (success)(const struct dsc$descriptor_s * old_dsc,
 139                          const struct dsc$descriptor_s * new_dsc,
 140                          const void *),
 141         void * (error)(const struct dsc$descriptor_s * old_dsc,
 142                        const struct dsc$descriptor_s * new_dsc,
 143                        const int * rms_sts,
 144                        const int * rms_stv,
 145                        const int * error_src,
 146                        const void * usr_arg),
 147         int (confirm)(const struct dsc$descriptor_s * old_dsc,
 148                       const struct dsc$descriptor_s * new_dsc,
 149                       const void * old_fab,
 150                       const void * usr_arg),
 151         void * user_arg,
 152         struct dsc$descriptor_s * old_result_name_dsc,
 153         struct dsc$descriptor_s * new_result_name_dsc,
 154         unsigned long * file_scan_context);
 155 #endif
 156
 157 #if __CRTL_VER >= 70300000 && !defined(__VAX)
 158
 159 static int set_feature_default(const char *name, int value)
 160 {
 161     int status;
 162     int index;
 163
 164     index = decc$feature_get_index(name);
 165
 166     status = decc$feature_set_value(index, 1, value);
 167     if (index == -1 || (status == -1)) {
 168       return -1;
 169     }
 170
 171     status = decc$feature_get_value(index, 1);
 172     if (status != value) {
 173       return -1;
 174     }
 175
 176 return 0;
 177 }
 178 #endif
 179
 180 /* Older versions of ssdef.h don't have these */
 181 #ifndef SS$_INVFILFOROP
 182 #  define SS$_INVFILFOROP 3930
 183 #endif
 184 #ifndef SS$_NOSUCHOBJECT
 185 #  define SS$_NOSUCHOBJECT 2696
 186 #endif
 187
 188 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
 189 #define PERLIO_NOT_STDIO 0
 190
 191 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
 192  * code below needs to get to the underlying CRTL routines. */
 193 #define DONT_MASK_RTL_CALLS
 194 #include "EXTERN.h"
 195 #include "perl.h"
 196 #include "XSUB.h"
 197 /* Anticipating future expansion in lexical warnings . . . */
 198 #ifndef WARN_INTERNAL
 199 #  define WARN_INTERNAL WARN_MISC
 200 #endif
 201
 202 #ifdef VMS_LONGNAME_SUPPORT
 203 #include <libfildef.h>
 204 #endif
 205
 206 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
 207 #  define RTL_USES_UTC 1
 208 #endif
 209
 210 /* Routine to create a decterm for use with the Perl debugger */
 211 /* No headers, this information was found in the Programming Concepts Manual */
 212
 213 static int (*decw_term_port)
 214    (const struct dsc$descriptor_s * display,
 215     const struct dsc$descriptor_s * setup_file,
 216     const struct dsc$descriptor_s * customization,
 217     struct dsc$descriptor_s * result_device_name,
 218     unsigned short * result_device_name_length,
 219     void * controller,
 220     void * char_buffer,
 221     void * char_change_buffer) = 0;
 222
 223 /* gcc's header files don't #define direct access macros
 224  * corresponding to VAXC's variant structs */
 225 #ifdef __GNUC__
 226 #  define uic$v_format uic$r_uic_form.uic$v_format
 227 #  define uic$v_group uic$r_uic_form.uic$v_group
 228 #  define uic$v_member uic$r_uic_form.uic$v_member
 229 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 230 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 231 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 232 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 233 #endif
 234
 235 #if defined(NEED_AN_H_ERRNO)
 236 dEXT int h_errno;
 237 #endif
 238
 239 #ifdef __DECC
 240 #pragma message disable pragma
 241 #pragma member_alignment save
 242 #pragma nomember_alignment longword
 243 #pragma message save
 244 #pragma message disable misalgndmem
 245 #endif
 246 struct itmlst_3 {
 247   unsigned short int buflen;
 248   unsigned short int itmcode;
 249   void *bufadr;
 250   unsigned short int *retlen;
 251 };
 252
 253 struct filescan_itmlst_2 {
 254     unsigned short length;
 255     unsigned short itmcode;
 256     char * component;
 257 };
 258
 259 struct vs_str_st {
 260     unsigned short length;
 261     char str[65536];
 262 };
 263
 264 #ifdef __DECC
 265 #pragma message restore
 266 #pragma member_alignment restore
 267 #endif
 268
 269 #define do_fileify_dirspec(a,b,c,d)     mp_do_fileify_dirspec(aTHX_ a,b,c,d)
 270 #define do_pathify_dirspec(a,b,c,d)     mp_do_pathify_dirspec(aTHX_ a,b,c,d)
 271 #define do_tovmsspec(a,b,c,d)           mp_do_tovmsspec(aTHX_ a,b,c,0,d)
 272 #define do_tovmspath(a,b,c,d)           mp_do_tovmspath(aTHX_ a,b,c,d)
 273 #define do_rmsexpand(a,b,c,d,e,f,g)     mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
 274 #define do_vms_realpath(a,b,c)          mp_do_vms_realpath(aTHX_ a,b,c)
 275 #define do_tounixspec(a,b,c,d)          mp_do_tounixspec(aTHX_ a,b,c,d)
 276 #define do_tounixpath(a,b,c,d)          mp_do_tounixpath(aTHX_ a,b,c,d)
 277 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 278 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 279 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 280
 281 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
 282 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
 283 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
 284 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
 285
 286 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 287 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 288
 289 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 290  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 291  * the Perl facility.
 292  */
 293 #define PERL_LNM_MAX_ITER 10
 294
 295   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 296 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 297 #define MAX_DCL_SYMBOL          (8192)
 298 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 299 #else
 300 #define MAX_DCL_SYMBOL          (1024)
 301 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 302 #endif
 303
 304 static char *__mystrtolower(char *str)
 305 {
 306   if (str) for (; *str; ++str) *str= tolower(*str);
 307   return str;
 308 }
 309
 310 static struct dsc$descriptor_s fildevdsc =
 311   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 312 static struct dsc$descriptor_s crtlenvdsc =
 313   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 314 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 315 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 316 static struct dsc$descriptor_s **env_tables = defenv;
 317 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 318
 319 /* True if we shouldn't treat barewords as logicals during directory */
 320 /* munching */
 321 static int no_translate_barewords;
 322
 323 #ifndef RTL_USES_UTC
 324 static int tz_updated = 1;
 325 #endif
 326
 327 /* DECC Features that may need to affect how Perl interprets
 328  * displays filename information
 329  */
 330 static int decc_disable_to_vms_logname_translation = 1;
 331 static int decc_disable_posix_root = 1;
 332 int decc_efs_case_preserve = 0;
 333 static int decc_efs_charset = 0;
 334 static int decc_filename_unix_no_version = 0;
 335 static int decc_filename_unix_only = 0;
 336 int decc_filename_unix_report = 0;
 337 int decc_posix_compliant_pathnames = 0;
 338 int decc_readdir_dropdotnotype = 0;
 339 static int vms_process_case_tolerant = 1;
 340 int vms_vtf7_filenames = 0;
 341 int gnv_unix_shell = 0;
 342 static int vms_unlink_all_versions = 0;
 343
 344 /* bug workarounds if needed */
 345 int decc_bug_readdir_efs1 = 0;
 346 int decc_bug_devnull = 1;
 347 int decc_bug_fgetname = 0;
 348 int decc_dir_barename = 0;
 349
 350 static int vms_debug_on_exception = 0;
 351
 352 /* Is this a UNIX file specification?
 353  *   No longer a simple check with EFS file specs
 354  *   For now, not a full check, but need to
 355  *   handle POSIX ^UP^ specifications
 356  *   Fixing to handle ^/ cases would require
 357  *   changes to many other conversion routines.
 358  */
 359
 360 static int is_unix_filespec(const char *path)
 361 {
 362 int ret_val;
 363 const char * pch1;
 364
 365     ret_val = 0;
 366     if (strncmp(path,"\"^UP^",5) != 0) {
 367         pch1 = strchr(path, '/');
 368         if (pch1 != NULL)
 369             ret_val = 1;
 370         else {
 371
 372             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 373             if (decc_filename_unix_report || decc_filename_unix_only) {
 374             if (strcmp(path,".") == 0)
 375                 ret_val = 1;
 376             }
 377         }
 378     }
 379     return ret_val;
 380 }
 381
 382 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 383  */
 384
 385 static void ucs2_to_vtf7
 386    (char *outspec,
 387     unsigned long ucs2_char,
 388     int * output_cnt)
 389 {
 390 unsigned char * ucs_ptr;
 391 int hex;
 392
 393     ucs_ptr = (unsigned char *)&ucs2_char;
 394
 395     outspec[0] = '^';
 396     outspec[1] = 'U';
 397     hex = (ucs_ptr[1] >> 4) & 0xf;
 398     if (hex < 0xA)
 399         outspec[2] = hex + '0';
 400     else
 401         outspec[2] = (hex - 9) + 'A';
 402     hex = ucs_ptr[1] & 0xF;
 403     if (hex < 0xA)
 404         outspec[3] = hex + '0';
 405     else {
 406         outspec[3] = (hex - 9) + 'A';
 407     }
 408     hex = (ucs_ptr[0] >> 4) & 0xf;
 409     if (hex < 0xA)
 410         outspec[4] = hex + '0';
 411     else
 412         outspec[4] = (hex - 9) + 'A';
 413     hex = ucs_ptr[1] & 0xF;
 414     if (hex < 0xA)
 415         outspec[5] = hex + '0';
 416     else {
 417         outspec[5] = (hex - 9) + 'A';
 418     }
 419     *output_cnt = 6;
 420 }
 421
 422
 423 /* This handles the conversion of a UNIX extended character set to a ^
 424  * escaped VMS character.
 425  * in a UNIX file specification.
 426  *
 427  * The output count variable contains the number of characters added
 428  * to the output string.
 429  *
 430  * The return value is the number of characters read from the input string
 431  */
 432 static int copy_expand_unix_filename_escape
 433   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 434 {
 435 int count;
 436 int scnt;
 437 int utf8_flag;
 438
 439     utf8_flag = 0;
 440     if (utf8_fl)
 441       utf8_flag = *utf8_fl;
 442
 443     count = 0;
 444     *output_cnt = 0;
 445     if (*inspec >= 0x80) {
 446         if (utf8_fl && vms_vtf7_filenames) {
 447         unsigned long ucs_char;
 448
 449             ucs_char = 0;
 450
 451             if ((*inspec & 0xE0) == 0xC0) {
 452                 /* 2 byte Unicode */
 453                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 454                 if (ucs_char >= 0x80) {
 455                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 456                     return 2;
 457                 }
 458             } else if ((*inspec & 0xF0) == 0xE0) {
 459                 /* 3 byte Unicode */
 460                 ucs_char = ((inspec[0] & 0xF) << 12) +
 461                    ((inspec[1] & 0x3f) << 6) +
 462                    (inspec[2] & 0x3f);
 463                 if (ucs_char >= 0x800) {
 464                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 465                     return 3;
 466                 }
 467
 468 #if 0 /* I do not see longer sequences supported by OpenVMS */
 469       /* Maybe some one can fix this later */
 470             } else if ((*inspec & 0xF8) == 0xF0) {
 471                 /* 4 byte Unicode */
 472                 /* UCS-4 to UCS-2 */
 473             } else if ((*inspec & 0xFC) == 0xF8) {
 474                 /* 5 byte Unicode */
 475                 /* UCS-4 to UCS-2 */
 476             } else if ((*inspec & 0xFE) == 0xFC) {
 477                 /* 6 byte Unicode */
 478                 /* UCS-4 to UCS-2 */
 479 #endif
 480             }
 481         }
 482
 483         /* High bit set, but not a Unicode character! */
 484
 485         /* Non printing DECMCS or ISO Latin-1 character? */
 486         if (*inspec <= 0x9F) {
 487         int hex;
 488             outspec[0] = '^';
 489             outspec++;
 490             hex = (*inspec >> 4) & 0xF;
 491             if (hex < 0xA)
 492                 outspec[1] = hex + '0';
 493             else {
 494                 outspec[1] = (hex - 9) + 'A';
 495             }
 496             hex = *inspec & 0xF;
 497             if (hex < 0xA)
 498                 outspec[2] = hex + '0';
 499             else {
 500                 outspec[2] = (hex - 9) + 'A';
 501             }
 502             *output_cnt = 3;
 503             return 1;
 504         } else if (*inspec == 0xA0) {
 505             outspec[0] = '^';
 506             outspec[1] = 'A';
 507             outspec[2] = '0';
 508             *output_cnt = 3;
 509             return 1;
 510         } else if (*inspec == 0xFF) {
 511             outspec[0] = '^';
 512             outspec[1] = 'F';
 513             outspec[2] = 'F';
 514             *output_cnt = 3;
 515             return 1;
 516         }
 517         *outspec = *inspec;
 518         *output_cnt = 1;
 519         return 1;
 520     }
 521
 522     /* Is this a macro that needs to be passed through?
 523      * Macros start with $( and an alpha character, followed
 524      * by a string of alpha numeric characters ending with a )
 525      * If this does not match, then encode it as ODS-5.
 526      */
 527     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 528     int tcnt;
 529
 530         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 531             tcnt = 3;
 532             outspec[0] = inspec[0];
 533             outspec[1] = inspec[1];
 534             outspec[2] = inspec[2];
 535
 536             while(isalnum(inspec[tcnt]) ||
 537                   (inspec[2] == '.') || (inspec[2] == '_')) {
 538                 outspec[tcnt] = inspec[tcnt];
 539                 tcnt++;
 540             }
 541             if (inspec[tcnt] == ')') {
 542                 outspec[tcnt] = inspec[tcnt];
 543                 tcnt++;
 544                 *output_cnt = tcnt;
 545                 return tcnt;
 546             }
 547         }
 548     }
 549
 550     switch (*inspec) {
 551     case 0x7f:
 552         outspec[0] = '^';
 553         outspec[1] = '7';
 554         outspec[2] = 'F';
 555         *output_cnt = 3;
 556         return 1;
 557         break;
 558     case '?':
 559         if (decc_efs_charset == 0)
 560           outspec[0] = '%';
 561         else
 562           outspec[0] = '?';
 563         *output_cnt = 1;
 564         return 1;
 565         break;
 566     case '.':
 567     case '~':
 568     case '!':
 569     case '#':
 570     case '&':
 571     case '\'':
 572     case '`':
 573     case '(':
 574     case ')':
 575     case '+':
 576     case '@':
 577     case '{':
 578     case '}':
 579     case ',':
 580     case ';':
 581     case '[':
 582     case ']':
 583     case '%':
 584     case '^':
 585         /* Don't escape again if following character is
 586          * already something we escape.
 587          */
 588         if (strchr(".~!#&\'`()+@{},;[]%^=_", *(inspec+1))) {
 589             *outspec = *inspec;
 590             *output_cnt = 1;
 591             return 1;
 592             break;
 593         }
 594         /* But otherwise fall through and escape it. */
 595     case '=':
 596         /* Assume that this is to be escaped */
 597         outspec[0] = '^';
 598         outspec[1] = *inspec;
 599         *output_cnt = 2;
 600         return 1;
 601         break;
 602     case ' ': /* space */
 603         /* Assume that this is to be escaped */
 604         outspec[0] = '^';
 605         outspec[1] = '_';
 606         *output_cnt = 2;
 607         return 1;
 608         break;
 609     default:
 610         *outspec = *inspec;
 611         *output_cnt = 1;
 612         return 1;
 613         break;
 614     }
 615 }
 616
 617
 618 /* This handles the expansion of a '^' prefix to the proper character
 619  * in a UNIX file specification.
 620  *
 621  * The output count variable contains the number of characters added
 622  * to the output string.
 623  *
 624  * The return value is the number of characters read from the input
 625  * string
 626  */
 627 static int copy_expand_vms_filename_escape
 628   (char *outspec, const char *inspec, int *output_cnt)
 629 {
 630 int count;
 631 int scnt;
 632
 633     count = 0;
 634     *output_cnt = 0;
 635     if (*inspec == '^') {
 636         inspec++;
 637         switch (*inspec) {
 638         /* Spaces and non-trailing dots should just be passed through,
 639          * but eat the escape character.
 640          */
 641         case '.':
 642             *outspec = *inspec;
 643             count += 2;
 644             (*output_cnt)++;
 645             break;
 646         case '_': /* space */
 647             *outspec = ' ';
 648             count += 2;
 649             (*output_cnt)++;
 650             break;
 651         case '^':
 652             /* Hmm.  Better leave the escape escaped. */
 653             outspec[0] = '^';
 654             outspec[1] = '^';
 655             count += 2;
 656             (*output_cnt) += 2;
 657             break;
 658         case 'U': /* Unicode - FIX-ME this is wrong. */
 659             inspec++;
 660             count++;
 661             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 662             if (scnt == 4) {
 663                 unsigned int c1, c2;
 664                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 665                 outspec[0] == c1 & 0xff;
 666                 outspec[1] == c2 & 0xff;
 667                 if (scnt > 1) {
 668                     (*output_cnt) += 2;
 669                     count += 4;
 670                 }
 671             }
 672             else {
 673                 /* Error - do best we can to continue */
 674                 *outspec = 'U';
 675                 outspec++;
 676                 (*output_cnt++);
 677                 *outspec = *inspec;
 678                 count++;
 679                 (*output_cnt++);
 680             }
 681             break;
 682         default:
 683             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 684             if (scnt == 2) {
 685                 /* Hex encoded */
 686                 unsigned int c1;
 687                 scnt = sscanf(inspec, "%2x", &c1);
 688                 outspec[0] = c1 & 0xff;
 689                 if (scnt > 0) {
 690                     (*output_cnt++);
 691                     count += 2;
 692                 }
 693             }
 694             else {
 695                 *outspec = *inspec;
 696                 count++;
 697                 (*output_cnt++);
 698             }
 699         }
 700     }
 701     else {
 702         *outspec = *inspec;
 703         count++;
 704         (*output_cnt)++;
 705     }
 706     return count;
 707 }
 708
 709 #ifdef sys$filescan
 710 #undef sys$filescan
 711 int sys$filescan
 712    (const struct dsc$descriptor_s * srcstr,
 713     struct filescan_itmlst_2 * valuelist,
 714     unsigned long * fldflags,
 715     struct dsc$descriptor_s *auxout,
 716     unsigned short * retlen);
 717 #endif
 718
 719 /* vms_split_path - Verify that the input file specification is a
 720  * VMS format file specification, and provide pointers to the components of
 721  * it.  With EFS format filenames, this is virtually the only way to
 722  * parse a VMS path specification into components.
 723  *
 724  * If the sum of the components do not add up to the length of the
 725  * string, then the passed file specification is probably a UNIX style
 726  * path.
 727  */
 728 static int vms_split_path
 729    (const char * path,
 730     char * * volume,
 731     int * vol_len,
 732     char * * root,
 733     int * root_len,
 734     char * * dir,
 735     int * dir_len,
 736     char * * name,
 737     int * name_len,
 738     char * * ext,
 739     int * ext_len,
 740     char * * version,
 741     int * ver_len)
 742 {
 743 struct dsc$descriptor path_desc;
 744 int status;
 745 unsigned long flags;
 746 int ret_stat;
 747 struct filescan_itmlst_2 item_list[9];
 748 const int filespec = 0;
 749 const int nodespec = 1;
 750 const int devspec = 2;
 751 const int rootspec = 3;
 752 const int dirspec = 4;
 753 const int namespec = 5;
 754 const int typespec = 6;
 755 const int verspec = 7;
 756
 757     /* Assume the worst for an easy exit */
 758     ret_stat = -1;
 759     *volume = NULL;
 760     *vol_len = 0;
 761     *root = NULL;
 762     *root_len = 0;
 763     *dir = NULL;
 764     *dir_len;
 765     *name = NULL;
 766     *name_len = 0;
 767     *ext = NULL;
 768     *ext_len = 0;
 769     *version = NULL;
 770     *ver_len = 0;
 771
 772     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 773     path_desc.dsc$w_length = strlen(path);
 774     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 775     path_desc.dsc$b_class = DSC$K_CLASS_S;
 776
 777     /* Get the total length, if it is shorter than the string passed
 778      * then this was probably not a VMS formatted file specification
 779      */
 780     item_list[filespec].itmcode = FSCN$_FILESPEC;
 781     item_list[filespec].length = 0;
 782     item_list[filespec].component = NULL;
 783
 784     /* If the node is present, then it gets considered as part of the
 785      * volume name to hopefully make things simple.
 786      */
 787     item_list[nodespec].itmcode = FSCN$_NODE;
 788     item_list[nodespec].length = 0;
 789     item_list[nodespec].component = NULL;
 790
 791     item_list[devspec].itmcode = FSCN$_DEVICE;
 792     item_list[devspec].length = 0;
 793     item_list[devspec].component = NULL;
 794
 795     /* root is a special case,  adding it to either the directory or
 796      * the device components will probalby complicate things for the
 797      * callers of this routine, so leave it separate.
 798      */
 799     item_list[rootspec].itmcode = FSCN$_ROOT;
 800     item_list[rootspec].length = 0;
 801     item_list[rootspec].component = NULL;
 802
 803     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 804     item_list[dirspec].length = 0;
 805     item_list[dirspec].component = NULL;
 806
 807     item_list[namespec].itmcode = FSCN$_NAME;
 808     item_list[namespec].length = 0;
 809     item_list[namespec].component = NULL;
 810
 811     item_list[typespec].itmcode = FSCN$_TYPE;
 812     item_list[typespec].length = 0;
 813     item_list[typespec].component = NULL;
 814
 815     item_list[verspec].itmcode = FSCN$_VERSION;
 816     item_list[verspec].length = 0;
 817     item_list[verspec].component = NULL;
 818
 819     item_list[8].itmcode = 0;
 820     item_list[8].length = 0;
 821     item_list[8].component = NULL;
 822
 823     status = sys$filescan
 824        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 825         &flags, NULL, NULL);
 826     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 827
 828     /* If we parsed it successfully these two lengths should be the same */
 829     if (path_desc.dsc$w_length != item_list[filespec].length)
 830         return ret_stat;
 831
 832     /* If we got here, then it is a VMS file specification */
 833     ret_stat = 0;
 834
 835     /* set the volume name */
 836     if (item_list[nodespec].length > 0) {
 837         *volume = item_list[nodespec].component;
 838         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 839     }
 840     else {
 841         *volume = item_list[devspec].component;
 842         *vol_len = item_list[devspec].length;
 843     }
 844
 845     *root = item_list[rootspec].component;
 846     *root_len = item_list[rootspec].length;
 847
 848     *dir = item_list[dirspec].component;
 849     *dir_len = item_list[dirspec].length;
 850
 851     /* Now fun with versions and EFS file specifications
 852      * The parser can not tell the difference when a "." is a version
 853      * delimiter or a part of the file specification.
 854      */
 855     if ((decc_efs_charset) &&
 856         (item_list[verspec].length > 0) &&
 857         (item_list[verspec].component[0] == '.')) {
 858         *name = item_list[namespec].component;
 859         *name_len = item_list[namespec].length + item_list[typespec].length;
 860         *ext = item_list[verspec].component;
 861         *ext_len = item_list[verspec].length;
 862         *version = NULL;
 863         *ver_len = 0;
 864     }
 865     else {
 866         *name = item_list[namespec].component;
 867         *name_len = item_list[namespec].length;
 868         *ext = item_list[typespec].component;
 869         *ext_len = item_list[typespec].length;
 870         *version = item_list[verspec].component;
 871         *ver_len = item_list[verspec].length;
 872     }
 873     return ret_stat;
 874 }
 875
 876
 877 /* my_maxidx
 878  * Routine to retrieve the maximum equivalence index for an input
 879  * logical name.  Some calls to this routine have no knowledge if
 880  * the variable is a logical or not.  So on error we return a max
 881  * index of zero.
 882  */
 883 /*{{{int my_maxidx(const char *lnm) */
 884 static int
 885 my_maxidx(const char *lnm)
 886 {
 887     int status;
 888     int midx;
 889     int attr = LNM$M_CASE_BLIND;
 890     struct dsc$descriptor lnmdsc;
 891     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 892                                 {0, 0, 0, 0}};
 893
 894     lnmdsc.dsc$w_length = strlen(lnm);
 895     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 896     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 897     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 898
 899     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 900     if ((status & 1) == 0)
 901        midx = 0;
 902
 903     return (midx);
 904 }
 905 /*}}}*/
 906
 907 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 908 int
 909 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 910   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 911 {
 912     const char *cp1;
 913     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 914     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 915     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 916     int midx;
 917     unsigned char acmode;
 918     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 919                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 920     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 921                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 922                                  {0, 0, 0, 0}};
 923     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 924 #if defined(PERL_IMPLICIT_CONTEXT)
 925     pTHX = NULL;
 926     if (PL_curinterp) {
 927       aTHX = PERL_GET_INTERP;
 928     } else {
 929       aTHX = NULL;
 930     }
 931 #endif
 932
 933     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 934       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 935     }
 936     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 937       *cp2 = _toupper(*cp1);
 938       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 939         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 940         return 0;
 941       }
 942     }
 943     lnmdsc.dsc$w_length = cp1 - lnm;
 944     lnmdsc.dsc$a_pointer = uplnm;
 945     uplnm[lnmdsc.dsc$w_length] = '\0';
 946     secure = flags & PERL__TRNENV_SECURE;
 947     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 948     if (!tabvec || !*tabvec) tabvec = env_tables;
 949
 950     for (curtab = 0; tabvec[curtab]; curtab++) {
 951       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 952         if (!ivenv && !secure) {
 953           char *eq, *end;
 954           int i;
 955           if (!environ) {
 956             ivenv = 1;
 957             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 958             continue;
 959           }
 960           retsts = SS$_NOLOGNAM;
 961           for (i = 0; environ[i]; i++) {
 962             if ((eq = strchr(environ[i],'=')) &&
 963                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 964                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 965               eq++;
 966               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 967               if (!eqvlen) continue;
 968               retsts = SS$_NORMAL;
 969               break;
 970             }
 971           }
 972           if (retsts != SS$_NOLOGNAM) break;
 973         }
 974       }
 975       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 976                !str$case_blind_compare(&tmpdsc,&clisym)) {
 977         if (!ivsym && !secure) {
 978           unsigned short int deflen = LNM$C_NAMLENGTH;
 979           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 980           /* dynamic dsc to accomodate possible long value */
 981           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 982           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 983           if (retsts & 1) {
 984             if (eqvlen > MAX_DCL_SYMBOL) {
 985               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 986               eqvlen = MAX_DCL_SYMBOL;
 987               /* Special hack--we might be called before the interpreter's */
 988               /* fully initialized, in which case either thr or PL_curcop */
 989               /* might be bogus. We have to check, since ckWARN needs them */
 990               /* both to be valid if running threaded */
 991                 if (ckWARN(WARN_MISC)) {
 992                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 993                 }
 994             }
 995             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 996           }
 997           _ckvmssts(lib$sfree1_dd(&eqvdsc));
 998           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 999           if (retsts == LIB$_NOSUCHSYM) continue;
1000           break;
1001         }
1002       }
1003       else if (!ivlnm) {
1004         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
1005           midx = my_maxidx(lnm);
1006           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1007             lnmlst[1].bufadr = cp2;
1008             eqvlen = 0;
1009             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1010             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1011             if (retsts == SS$_NOLOGNAM) break;
1012             /* PPFs have a prefix */
1013             if (
1014 #if INTSIZE == 4
1015                  *((int *)uplnm) == *((int *)"SYS$")                    &&
1016 #endif
1017                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
1018                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
1019                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
1020                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
1021                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
1022               memmove(eqv,eqv+4,eqvlen-4);
1023               eqvlen -= 4;
1024             }
1025             cp2 += eqvlen;
1026             *cp2 = '\0';
1027           }
1028           if ((retsts == SS$_IVLOGNAM) ||
1029               (retsts == SS$_NOLOGNAM)) { continue; }
1030         }
1031         else {
1032           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1033           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1034           if (retsts == SS$_NOLOGNAM) continue;
1035           eqv[eqvlen] = '\0';
1036         }
1037         eqvlen = strlen(eqv);
1038         break;
1039       }
1040     }
1041     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1042     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1043              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
1044              retsts == SS$_NOLOGNAM) {
1045       set_errno(EINVAL);  set_vaxc_errno(retsts);
1046     }
1047     else _ckvmssts(retsts);
1048     return 0;
1049 }  /* end of vmstrnenv */
1050 /*}}}*/
1051
1052 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1053 /* Define as a function so we can access statics. */
1054 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1055 {
1056   return vmstrnenv(lnm,eqv,idx,fildev,
1057 #ifdef SECURE_INTERNAL_GETENV
1058                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
1059 #else
1060                    0
1061 #endif
1062                                                                               );
1063 }
1064 /*}}}*/
1065
1066 /* my_getenv
1067  * Note: Uses Perl temp to store result so char * can be returned to
1068  * caller; this pointer will be invalidated at next Perl statement
1069  * transition.
1070  * We define this as a function rather than a macro in terms of my_getenv_len()
1071  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1072  * allocate SVs).
1073  */
1074 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1075 char *
1076 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1077 {
1078     const char *cp1;
1079     static char *__my_getenv_eqv = NULL;
1080     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1081     unsigned long int idx = 0;
1082     int trnsuccess, success, secure, saverr, savvmserr;
1083     int midx, flags;
1084     SV *tmpsv;
1085
1086     midx = my_maxidx(lnm) + 1;
1087
1088     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1089       /* Set up a temporary buffer for the return value; Perl will
1090        * clean it up at the next statement transition */
1091       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1092       if (!tmpsv) return NULL;
1093       eqv = SvPVX(tmpsv);
1094     }
1095     else {
1096       /* Assume no interpreter ==> single thread */
1097       if (__my_getenv_eqv != NULL) {
1098         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1099       }
1100       else {
1101         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1102       }
1103       eqv = __my_getenv_eqv;
1104     }
1105
1106     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1107     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1108       int len;
1109       getcwd(eqv,LNM$C_NAMLENGTH);
1110
1111       len = strlen(eqv);
1112
1113       /* Get rid of "000000/ in rooted filespecs */
1114       if (len > 7) {
1115         char * zeros;
1116         zeros = strstr(eqv, "/000000/");
1117         if (zeros != NULL) {
1118           int mlen;
1119           mlen = len - (zeros - eqv) - 7;
1120           memmove(zeros, &zeros[7], mlen);
1121           len = len - 7;
1122           eqv[len] = '\0';
1123         }
1124       }
1125       return eqv;
1126     }
1127     else {
1128       /* Impose security constraints only if tainting */
1129       if (sys) {
1130         /* Impose security constraints only if tainting */
1131         secure = PL_curinterp ? PL_tainting : will_taint;
1132         saverr = errno;  savvmserr = vaxc$errno;
1133       }
1134       else {
1135         secure = 0;
1136       }
1137
1138       flags =
1139 #ifdef SECURE_INTERNAL_GETENV
1140               secure ? PERL__TRNENV_SECURE : 0
1141 #else
1142               0
1143 #endif
1144       ;
1145
1146       /* For the getenv interface we combine all the equivalence names
1147        * of a search list logical into one value to acquire a maximum
1148        * value length of 255*128 (assuming %ENV is using logicals).
1149        */
1150       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1151
1152       /* If the name contains a semicolon-delimited index, parse it
1153        * off and make sure we only retrieve the equivalence name for
1154        * that index.  */
1155       if ((cp2 = strchr(lnm,';')) != NULL) {
1156         strcpy(uplnm,lnm);
1157         uplnm[cp2-lnm] = '\0';
1158         idx = strtoul(cp2+1,NULL,0);
1159         lnm = uplnm;
1160         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1161       }
1162
1163       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1164
1165       /* Discard NOLOGNAM on internal calls since we're often looking
1166        * for an optional name, and this "error" often shows up as the
1167        * (bogus) exit status for a die() call later on.  */
1168       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1169       return success ? eqv : Nullch;
1170     }
1171
1172 }  /* end of my_getenv() */
1173 /*}}}*/
1174
1175
1176 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1177 char *
1178 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1179 {
1180     const char *cp1;
1181     char *buf, *cp2;
1182     unsigned long idx = 0;
1183     int midx, flags;
1184     static char *__my_getenv_len_eqv = NULL;
1185     int secure, saverr, savvmserr;
1186     SV *tmpsv;
1187
1188     midx = my_maxidx(lnm) + 1;
1189
1190     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1191       /* Set up a temporary buffer for the return value; Perl will
1192        * clean it up at the next statement transition */
1193       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1194       if (!tmpsv) return NULL;
1195       buf = SvPVX(tmpsv);
1196     }
1197     else {
1198       /* Assume no interpreter ==> single thread */
1199       if (__my_getenv_len_eqv != NULL) {
1200         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1201       }
1202       else {
1203         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1204       }
1205       buf = __my_getenv_len_eqv;
1206     }
1207
1208     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1209     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1210     char * zeros;
1211
1212       getcwd(buf,LNM$C_NAMLENGTH);
1213       *len = strlen(buf);
1214
1215       /* Get rid of "000000/ in rooted filespecs */
1216       if (*len > 7) {
1217       zeros = strstr(buf, "/000000/");
1218       if (zeros != NULL) {
1219         int mlen;
1220         mlen = *len - (zeros - buf) - 7;
1221         memmove(zeros, &zeros[7], mlen);
1222         *len = *len - 7;
1223         buf[*len] = '\0';
1224         }
1225       }
1226       return buf;
1227     }
1228     else {
1229       if (sys) {
1230         /* Impose security constraints only if tainting */
1231         secure = PL_curinterp ? PL_tainting : will_taint;
1232         saverr = errno;  savvmserr = vaxc$errno;
1233       }
1234       else {
1235         secure = 0;
1236       }
1237
1238       flags =
1239 #ifdef SECURE_INTERNAL_GETENV
1240               secure ? PERL__TRNENV_SECURE : 0
1241 #else
1242               0
1243 #endif
1244       ;
1245
1246       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1247
1248       if ((cp2 = strchr(lnm,';')) != NULL) {
1249         strcpy(buf,lnm);
1250         buf[cp2-lnm] = '\0';
1251         idx = strtoul(cp2+1,NULL,0);
1252         lnm = buf;
1253         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1254       }
1255
1256       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1257
1258       /* Get rid of "000000/ in rooted filespecs */
1259       if (*len > 7) {
1260       char * zeros;
1261         zeros = strstr(buf, "/000000/");
1262         if (zeros != NULL) {
1263           int mlen;
1264           mlen = *len - (zeros - buf) - 7;
1265           memmove(zeros, &zeros[7], mlen);
1266           *len = *len - 7;
1267           buf[*len] = '\0';
1268         }
1269       }
1270
1271       /* Discard NOLOGNAM on internal calls since we're often looking
1272        * for an optional name, and this "error" often shows up as the
1273        * (bogus) exit status for a die() call later on.  */
1274       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1275       return *len ? buf : Nullch;
1276     }
1277
1278 }  /* end of my_getenv_len() */
1279 /*}}}*/
1280
1281 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
1282
1283 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1284
1285 /*{{{ void prime_env_iter() */
1286 void
1287 prime_env_iter(void)
1288 /* Fill the %ENV associative array with all logical names we can
1289  * find, in preparation for iterating over it.
1290  */
1291 {
1292   static int primed = 0;
1293   HV *seenhv = NULL, *envhv;
1294   SV *sv = NULL;
1295   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
1296   unsigned short int chan;
1297 #ifndef CLI$M_TRUSTED
1298 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1299 #endif
1300   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1301   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1302   long int i;
1303   bool have_sym = FALSE, have_lnm = FALSE;
1304   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1305   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1306   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1307   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1308   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1309 #if defined(PERL_IMPLICIT_CONTEXT)
1310   pTHX;
1311 #endif
1312 #if defined(USE_ITHREADS)
1313   static perl_mutex primenv_mutex;
1314   MUTEX_INIT(&primenv_mutex);
1315 #endif
1316
1317 #if defined(PERL_IMPLICIT_CONTEXT)
1318     /* We jump through these hoops because we can be called at */
1319     /* platform-specific initialization time, which is before anything is */
1320     /* set up--we can't even do a plain dTHX since that relies on the */
1321     /* interpreter structure to be initialized */
1322     if (PL_curinterp) {
1323       aTHX = PERL_GET_INTERP;
1324     } else {
1325       aTHX = NULL;
1326     }
1327 #endif
1328
1329   if (primed || !PL_envgv) return;
1330   MUTEX_LOCK(&primenv_mutex);
1331   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1332   envhv = GvHVn(PL_envgv);
1333   /* Perform a dummy fetch as an lval to insure that the hash table is
1334    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1335   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1336
1337   for (i = 0; env_tables[i]; i++) {
1338      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1339          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1340      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1341   }
1342   if (have_sym || have_lnm) {
1343     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1344     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1345     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1346     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1347   }
1348
1349   for (i--; i >= 0; i--) {
1350     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1351       char *start;
1352       int j;
1353       for (j = 0; environ[j]; j++) {
1354         if (!(start = strchr(environ[j],'='))) {
1355           if (ckWARN(WARN_INTERNAL))
1356             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1357         }
1358         else {
1359           start++;
1360           sv = newSVpv(start,0);
1361           SvTAINTED_on(sv);
1362           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1363         }
1364       }
1365       continue;
1366     }
1367     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1368              !str$case_blind_compare(&tmpdsc,&clisym)) {
1369       strcpy(cmd,"Show Symbol/Global *");
1370       cmddsc.dsc$w_length = 20;
1371       if (env_tables[i]->dsc$w_length == 12 &&
1372           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1373           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1374       flags = defflags | CLI$M_NOLOGNAM;
1375     }
1376     else {
1377       strcpy(cmd,"Show Logical *");
1378       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1379         strcat(cmd," /Table=");
1380         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1381         cmddsc.dsc$w_length = strlen(cmd);
1382       }
1383       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1384       flags = defflags | CLI$M_NOCLISYM;
1385     }
1386
1387     /* Create a new subprocess to execute each command, to exclude the
1388      * remote possibility that someone could subvert a mbx or file used
1389      * to write multiple commands to a single subprocess.
1390      */
1391     do {
1392       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1393                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1394       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1395       defflags &= ~CLI$M_TRUSTED;
1396     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1397     _ckvmssts(retsts);
1398     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1399     if (seenhv) SvREFCNT_dec(seenhv);
1400     seenhv = newHV();
1401     while (1) {
1402       char *cp1, *cp2, *key;
1403       unsigned long int sts, iosb[2], retlen, keylen;
1404       register U32 hash;
1405
1406       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1407       if (sts & 1) sts = iosb[0] & 0xffff;
1408       if (sts == SS$_ENDOFFILE) {
1409         int wakect = 0;
1410         while (substs == 0) { sys$hiber(); wakect++;}
1411         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1412         _ckvmssts(substs);
1413         break;
1414       }
1415       _ckvmssts(sts);
1416       retlen = iosb[0] >> 16;
1417       if (!retlen) continue;  /* blank line */
1418       buf[retlen] = '\0';
1419       if (iosb[1] != subpid) {
1420         if (iosb[1]) {
1421           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1422         }
1423         continue;
1424       }
1425       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1426         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1427
1428       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1429       if (*cp1 == '(' || /* Logical name table name */
1430           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1431       if (*cp1 == '"') cp1++;
1432       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1433       key = cp1;  keylen = cp2 - cp1;
1434       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1435       while (*cp2 && *cp2 != '=') cp2++;
1436       while (*cp2 && *cp2 == '=') cp2++;
1437       while (*cp2 && *cp2 == ' ') cp2++;
1438       if (*cp2 == '"') {  /* String translation; may embed "" */
1439         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1440         cp2++;  cp1--; /* Skip "" surrounding translation */
1441       }
1442       else {  /* Numeric translation */
1443         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1444         cp1--;  /* stop on last non-space char */
1445       }
1446       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1447         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1448         continue;
1449       }
1450       PERL_HASH(hash,key,keylen);
1451
1452       if (cp1 == cp2 && *cp2 == '.') {
1453         /* A single dot usually means an unprintable character, such as a null
1454          * to indicate a zero-length value.  Get the actual value to make sure.
1455          */
1456         char lnm[LNM$C_NAMLENGTH+1];
1457         char eqv[MAX_DCL_SYMBOL+1];
1458         int trnlen;
1459         strncpy(lnm, key, keylen);
1460         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1461         sv = newSVpvn(eqv, strlen(eqv));
1462       }
1463       else {
1464         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1465       }
1466
1467       SvTAINTED_on(sv);
1468       hv_store(envhv,key,keylen,sv,hash);
1469       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1470     }
1471     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1472       /* get the PPFs for this process, not the subprocess */
1473       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1474       char eqv[LNM$C_NAMLENGTH+1];
1475       int trnlen, i;
1476       for (i = 0; ppfs[i]; i++) {
1477         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1478         sv = newSVpv(eqv,trnlen);
1479         SvTAINTED_on(sv);
1480         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1481       }
1482     }
1483   }
1484   primed = 1;
1485   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1486   if (buf) Safefree(buf);
1487   if (seenhv) SvREFCNT_dec(seenhv);
1488   MUTEX_UNLOCK(&primenv_mutex);
1489   return;
1490
1491 }  /* end of prime_env_iter */
1492 /*}}}*/
1493
1494
1495 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1496 /* Define or delete an element in the same "environment" as
1497  * vmstrnenv().  If an element is to be deleted, it's removed from
1498  * the first place it's found.  If it's to be set, it's set in the
1499  * place designated by the first element of the table vector.
1500  * Like setenv() returns 0 for success, non-zero on error.
1501  */
1502 int
1503 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1504 {
1505     const char *cp1;
1506     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1507     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1508     int nseg = 0, j;
1509     unsigned long int retsts, usermode = PSL$C_USER;
1510     struct itmlst_3 *ile, *ilist;
1511     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1512                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1513                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1514     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1515     $DESCRIPTOR(local,"_LOCAL");
1516
1517     if (!lnm) {
1518         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1519         return SS$_IVLOGNAM;
1520     }
1521
1522     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1523       *cp2 = _toupper(*cp1);
1524       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1525         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1526         return SS$_IVLOGNAM;
1527       }
1528     }
1529     lnmdsc.dsc$w_length = cp1 - lnm;
1530     if (!tabvec || !*tabvec) tabvec = env_tables;
1531
1532     if (!eqv) {  /* we're deleting n element */
1533       for (curtab = 0; tabvec[curtab]; curtab++) {
1534         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1535         int i;
1536           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1537             if ((cp1 = strchr(environ[i],'=')) &&
1538                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1539                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1540 #ifdef HAS_SETENV
1541               return setenv(lnm,"",1) ? vaxc$errno : 0;
1542             }
1543           }
1544           ivenv = 1; retsts = SS$_NOLOGNAM;
1545 #else
1546               if (ckWARN(WARN_INTERNAL))
1547                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1548               ivenv = 1; retsts = SS$_NOSUCHPGM;
1549               break;
1550             }
1551           }
1552 #endif
1553         }
1554         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1555                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1556           unsigned int symtype;
1557           if (tabvec[curtab]->dsc$w_length == 12 &&
1558               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1559               !str$case_blind_compare(&tmpdsc,&local))
1560             symtype = LIB$K_CLI_LOCAL_SYM;
1561           else symtype = LIB$K_CLI_GLOBAL_SYM;
1562           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1563           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1564           if (retsts == LIB$_NOSUCHSYM) continue;
1565           break;
1566         }
1567         else if (!ivlnm) {
1568           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1569           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1570           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1571           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1572           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1573         }
1574       }
1575     }
1576     else {  /* we're defining a value */
1577       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1578 #ifdef HAS_SETENV
1579         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1580 #else
1581         if (ckWARN(WARN_INTERNAL))
1582           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1583         retsts = SS$_NOSUCHPGM;
1584 #endif
1585       }
1586       else {
1587         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1588         eqvdsc.dsc$w_length  = strlen(eqv);
1589         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1590             !str$case_blind_compare(&tmpdsc,&clisym)) {
1591           unsigned int symtype;
1592           if (tabvec[0]->dsc$w_length == 12 &&
1593               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1594                !str$case_blind_compare(&tmpdsc,&local))
1595             symtype = LIB$K_CLI_LOCAL_SYM;
1596           else symtype = LIB$K_CLI_GLOBAL_SYM;
1597           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1598         }
1599         else {
1600           if (!*eqv) eqvdsc.dsc$w_length = 1;
1601           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1602
1603             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1604             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1605               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1606                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1607               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1608               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1609             }
1610
1611             Newx(ilist,nseg+1,struct itmlst_3);
1612             ile = ilist;
1613             if (!ile) {
1614               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1615               return SS$_INSFMEM;
1616             }
1617             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1618
1619             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1620               ile->itmcode = LNM$_STRING;
1621               ile->bufadr = c;
1622               if ((j+1) == nseg) {
1623                 ile->buflen = strlen(c);
1624                 /* in case we are truncating one that's too long */
1625                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1626               }
1627               else {
1628                 ile->buflen = LNM$C_NAMLENGTH;
1629               }
1630             }
1631
1632             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1633             Safefree (ilist);
1634           }
1635           else {
1636             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1637           }
1638         }
1639       }
1640     }
1641     if (!(retsts & 1)) {
1642       switch (retsts) {
1643         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1644         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1645           set_errno(EVMSERR); break;
1646         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1647         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1648           set_errno(EINVAL); break;
1649         case SS$_NOPRIV:
1650           set_errno(EACCES); break;
1651         default:
1652           _ckvmssts(retsts);
1653           set_errno(EVMSERR);
1654        }
1655        set_vaxc_errno(retsts);
1656        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1657     }
1658     else {
1659       /* We reset error values on success because Perl does an hv_fetch()
1660        * before each hv_store(), and if the thing we're setting didn't
1661        * previously exist, we've got a leftover error message.  (Of course,
1662        * this fails in the face of
1663        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1664        * in that the error reported in $! isn't spurious,
1665        * but it's right more often than not.)
1666        */
1667       set_errno(0); set_vaxc_errno(retsts);
1668       return 0;
1669     }
1670
1671 }  /* end of vmssetenv() */
1672 /*}}}*/
1673
1674 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1675 /* This has to be a function since there's a prototype for it in proto.h */
1676 void
1677 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1678 {
1679     if (lnm && *lnm) {
1680       int len = strlen(lnm);
1681       if  (len == 7) {
1682         char uplnm[8];
1683         int i;
1684         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1685         if (!strcmp(uplnm,"DEFAULT")) {
1686           if (eqv && *eqv) my_chdir(eqv);
1687           return;
1688         }
1689     }
1690 #ifndef RTL_USES_UTC
1691     if (len == 6 || len == 2) {
1692       char uplnm[7];
1693       int i;
1694       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1695       uplnm[len] = '\0';
1696       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1697       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1698     }
1699 #endif
1700   }
1701   (void) vmssetenv(lnm,eqv,NULL);
1702 }
1703 /*}}}*/
1704
1705 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1706 /*  vmssetuserlnm
1707  *  sets a user-mode logical in the process logical name table
1708  *  used for redirection of sys$error
1709  */
1710 void
1711 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1712 {
1713     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1714     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1715     unsigned long int iss, attr = LNM$M_CONFINE;
1716     unsigned char acmode = PSL$C_USER;
1717     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1718                                  {0, 0, 0, 0}};
1719     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1720     d_name.dsc$w_length = strlen(name);
1721
1722     lnmlst[0].buflen = strlen(eqv);
1723     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1724
1725     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1726     if (!(iss&1)) lib$signal(iss);
1727 }
1728 /*}}}*/
1729
1730
1731 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1732 /* my_crypt - VMS password hashing
1733  * my_crypt() provides an interface compatible with the Unix crypt()
1734  * C library function, and uses sys$hash_password() to perform VMS
1735  * password hashing.  The quadword hashed password value is returned
1736  * as a NUL-terminated 8 character string.  my_crypt() does not change
1737  * the case of its string arguments; in order to match the behavior
1738  * of LOGINOUT et al., alphabetic characters in both arguments must
1739  *  be upcased by the caller.
1740  *
1741  * - fix me to call ACM services when available
1742  */
1743 char *
1744 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1745 {
1746 #   ifndef UAI$C_PREFERRED_ALGORITHM
1747 #     define UAI$C_PREFERRED_ALGORITHM 127
1748 #   endif
1749     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1750     unsigned short int salt = 0;
1751     unsigned long int sts;
1752     struct const_dsc {
1753         unsigned short int dsc$w_length;
1754         unsigned char      dsc$b_type;
1755         unsigned char      dsc$b_class;
1756         const char *       dsc$a_pointer;
1757     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1758        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1759     struct itmlst_3 uailst[3] = {
1760         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1761         { sizeof salt, UAI$_SALT,    &salt, 0},
1762         { 0,           0,            NULL,  NULL}};
1763     static char hash[9];
1764
1765     usrdsc.dsc$w_length = strlen(usrname);
1766     usrdsc.dsc$a_pointer = usrname;
1767     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1768       switch (sts) {
1769         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1770           set_errno(EACCES);
1771           break;
1772         case RMS$_RNF:
1773           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1774           break;
1775         default:
1776           set_errno(EVMSERR);
1777       }
1778       set_vaxc_errno(sts);
1779       if (sts != RMS$_RNF) return NULL;
1780     }
1781
1782     txtdsc.dsc$w_length = strlen(textpasswd);
1783     txtdsc.dsc$a_pointer = textpasswd;
1784     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1785       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1786     }
1787
1788     return (char *) hash;
1789
1790 }  /* end of my_crypt() */
1791 /*}}}*/
1792
1793
1794 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1795 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1796 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1797
1798 /* fixup barenames that are directories for internal use.
1799  * There have been problems with the consistent handling of UNIX
1800  * style directory names when routines are presented with a name that
1801  * has no directory delimitors at all.  So this routine will eventually
1802  * fix the issue.
1803  */
1804 static char * fixup_bare_dirnames(const char * name)
1805 {
1806   if (decc_disable_to_vms_logname_translation) {
1807 /* fix me */
1808   }
1809   return NULL;
1810 }
1811
1812 /* 8.3, remove() is now broken on symbolic links */
1813 static int rms_erase(const char * vmsname);
1814
1815
1816 /* mp_do_kill_file
1817  * A little hack to get around a bug in some implemenation of remove()
1818  * that do not know how to delete a directory
1819  *
1820  * Delete any file to which user has control access, regardless of whether
1821  * delete access is explicitly allowed.
1822  * Limitations: User must have write access to parent directory.
1823  *              Does not block signals or ASTs; if interrupted in midstream
1824  *              may leave file with an altered ACL.
1825  * HANDLE WITH CARE!
1826  */
1827 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1828 static int
1829 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1830 {
1831     char *vmsname;
1832     char *rslt;
1833     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1834     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1835     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1836     struct myacedef {
1837       unsigned char myace$b_length;
1838       unsigned char myace$b_type;
1839       unsigned short int myace$w_flags;
1840       unsigned long int myace$l_access;
1841       unsigned long int myace$l_ident;
1842     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1843                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1844       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1845      struct itmlst_3
1846        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1847                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1848        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1849        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1850        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1851        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1852
1853     /* Expand the input spec using RMS, since the CRTL remove() and
1854      * system services won't do this by themselves, so we may miss
1855      * a file "hiding" behind a logical name or search list. */
1856     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1857     if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1858
1859     rslt = do_rmsexpand(name,
1860                         vmsname,
1861                         0,
1862                         NULL,
1863                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
1864                         NULL,
1865                         NULL);
1866     if (rslt == NULL) {
1867         PerlMem_free(vmsname);
1868         return -1;
1869       }
1870
1871     /* Erase the file */
1872     rmsts = rms_erase(vmsname);
1873
1874     /* Did it succeed */
1875     if ($VMS_STATUS_SUCCESS(rmsts)) {
1876         PerlMem_free(vmsname);
1877         return 0;
1878       }
1879
1880     /* If not, can changing protections help? */
1881     if (rmsts != RMS$_PRV) {
1882       set_vaxc_errno(rmsts);
1883       PerlMem_free(vmsname);
1884       return -1;
1885     }
1886
1887     /* No, so we get our own UIC to use as a rights identifier,
1888      * and the insert an ACE at the head of the ACL which allows us
1889      * to delete the file.
1890      */
1891     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1892     fildsc.dsc$w_length = strlen(vmsname);
1893     fildsc.dsc$a_pointer = vmsname;
1894     cxt = 0;
1895     newace.myace$l_ident = oldace.myace$l_ident;
1896     rmsts = -1;
1897     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1898       switch (aclsts) {
1899         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1900           set_errno(ENOENT); break;
1901         case RMS$_DIR:
1902           set_errno(ENOTDIR); break;
1903         case RMS$_DEV:
1904           set_errno(ENODEV); break;
1905         case RMS$_SYN: case SS$_INVFILFOROP:
1906           set_errno(EINVAL); break;
1907         case RMS$_PRV:
1908           set_errno(EACCES); break;
1909         default:
1910           _ckvmssts(aclsts);
1911       }
1912       set_vaxc_errno(aclsts);
1913       PerlMem_free(vmsname);
1914       return -1;
1915     }
1916     /* Grab any existing ACEs with this identifier in case we fail */
1917     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1918     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1919                     || fndsts == SS$_NOMOREACE ) {
1920       /* Add the new ACE . . . */
1921       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1922         goto yourroom;
1923
1924       rmsts = rms_erase(vmsname);
1925       if ($VMS_STATUS_SUCCESS(rmsts)) {
1926         rmsts = 0;
1927         }
1928         else {
1929         rmsts = -1;
1930         /* We blew it - dir with files in it, no write priv for
1931          * parent directory, etc.  Put things back the way they were. */
1932         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1933           goto yourroom;
1934         if (fndsts & 1) {
1935           addlst[0].bufadr = &oldace;
1936           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1937             goto yourroom;
1938         }
1939       }
1940     }
1941
1942     yourroom:
1943     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1944     /* We just deleted it, so of course it's not there.  Some versions of
1945      * VMS seem to return success on the unlock operation anyhow (after all
1946      * the unlock is successful), but others don't.
1947      */
1948     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1949     if (aclsts & 1) aclsts = fndsts;
1950     if (!(aclsts & 1)) {
1951       set_errno(EVMSERR);
1952       set_vaxc_errno(aclsts);
1953     }
1954
1955     PerlMem_free(vmsname);
1956     return rmsts;
1957
1958 }  /* end of kill_file() */
1959 /*}}}*/
1960
1961
1962 /*{{{int do_rmdir(char *name)*/
1963 int
1964 Perl_do_rmdir(pTHX_ const char *name)
1965 {
1966     char * dirfile;
1967     int retval;
1968     Stat_t st;
1969
1970     dirfile = PerlMem_malloc(VMS_MAXRSS + 1);
1971     if (dirfile == NULL)
1972         _ckvmssts(SS$_INSFMEM);
1973
1974     /* Force to a directory specification */
1975     if (do_fileify_dirspec(name, dirfile, 0, NULL) == NULL) {
1976         PerlMem_free(dirfile);
1977         return -1;
1978     }
1979     if (Perl_flex_lstat(aTHX_ dirfile, &st) || !S_ISDIR(st.st_mode)) {
1980         errno = ENOTDIR;
1981         retval = -1;
1982     }
1983     else
1984         retval = mp_do_kill_file(aTHX_ dirfile, 1);
1985
1986     PerlMem_free(dirfile);
1987     return retval;
1988
1989 }  /* end of do_rmdir */
1990 /*}}}*/
1991
1992 /* kill_file
1993  * Delete any file to which user has control access, regardless of whether
1994  * delete access is explicitly allowed.
1995  * Limitations: User must have write access to parent directory.
1996  *              Does not block signals or ASTs; if interrupted in midstream
1997  *              may leave file with an altered ACL.
1998  * HANDLE WITH CARE!
1999  */
2000 /*{{{int kill_file(char *name)*/
2001 int
2002 Perl_kill_file(pTHX_ const char *name)
2003 {
2004     char rspec[NAM$C_MAXRSS+1];
2005     char *tspec;
2006     Stat_t st;
2007     int rmsts;
2008
2009    /* Remove() is allowed to delete directories, according to the X/Open
2010     * specifications.
2011     * This may need special handling to work with the ACL hacks.
2012      */
2013    if ((flex_lstat(name, &st) == 0) && S_ISDIR(st.st_mode)) {
2014         rmsts = Perl_do_rmdir(aTHX_ name);
2015         return rmsts;
2016     }
2017
2018    rmsts = mp_do_kill_file(aTHX_ name, 0);
2019
2020     return rmsts;
2021
2022 }  /* end of kill_file() */
2023 /*}}}*/
2024
2025
2026 /*{{{int my_mkdir(char *,Mode_t)*/
2027 int
2028 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2029 {
2030   STRLEN dirlen = strlen(dir);
2031
2032   /* zero length string sometimes gives ACCVIO */
2033   if (dirlen == 0) return -1;
2034
2035   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2036    * null file name/type.  However, it's commonplace under Unix,
2037    * so we'll allow it for a gain in portability.
2038    */
2039   if (dir[dirlen-1] == '/') {
2040     char *newdir = savepvn(dir,dirlen-1);
2041     int ret = mkdir(newdir,mode);
2042     Safefree(newdir);
2043     return ret;
2044   }
2045   else return mkdir(dir,mode);
2046 }  /* end of my_mkdir */
2047 /*}}}*/
2048
2049 /*{{{int my_chdir(char *)*/
2050 int
2051 Perl_my_chdir(pTHX_ const char *dir)
2052 {
2053   STRLEN dirlen = strlen(dir);
2054
2055   /* zero length string sometimes gives ACCVIO */
2056   if (dirlen == 0) return -1;
2057   const char *dir1;
2058
2059   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2060    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2061    * so that existing scripts do not need to be changed.
2062    */
2063   dir1 = dir;
2064   while ((dirlen > 0) && (*dir1 == ' ')) {
2065     dir1++;
2066     dirlen--;
2067   }
2068
2069   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2070    * that implies
2071    * null file name/type.  However, it's commonplace under Unix,
2072    * so we'll allow it for a gain in portability.
2073    *
2074    * - Preview- '/' will be valid soon on VMS
2075    */
2076   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2077     char *newdir = savepvn(dir1,dirlen-1);
2078     int ret = chdir(newdir);
2079     Safefree(newdir);
2080     return ret;
2081   }
2082   else return chdir(dir1);
2083 }  /* end of my_chdir */
2084 /*}}}*/
2085
2086
2087 /*{{{int my_chmod(char *, mode_t)*/
2088 int
2089 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2090 {
2091   STRLEN speclen = strlen(file_spec);
2092
2093   /* zero length string sometimes gives ACCVIO */
2094   if (speclen == 0) return -1;
2095
2096   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2097    * that implies null file name/type.  However, it's commonplace under Unix,
2098    * so we'll allow it for a gain in portability.
2099    *
2100    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2101    * in VMS file.dir notation.
2102    */
2103   if ((speclen > 1) && (file_spec[speclen-1] == '/')) {
2104     char *vms_src, *vms_dir, *rslt;
2105     int ret = -1;
2106     errno = EIO;
2107
2108     /* First convert this to a VMS format specification */
2109     vms_src = PerlMem_malloc(VMS_MAXRSS);
2110     if (vms_src == NULL)
2111         _ckvmssts(SS$_INSFMEM);
2112
2113     rslt = do_tovmsspec(file_spec, vms_src, 0, NULL);
2114     if (rslt == NULL) {
2115         /* If we fail, then not a file specification */
2116         PerlMem_free(vms_src);
2117         errno = EIO;
2118         return -1;
2119     }
2120
2121     /* Now make it a directory spec so chmod is happy */
2122     vms_dir = PerlMem_malloc(VMS_MAXRSS + 1);
2123     if (vms_dir == NULL)
2124         _ckvmssts(SS$_INSFMEM);
2125     rslt = do_fileify_dirspec(vms_src, vms_dir, 0, NULL);
2126     PerlMem_free(vms_src);
2127
2128     /* Now do it */
2129     if (rslt != NULL) {
2130         ret = chmod(vms_dir, mode);
2131     } else {
2132         errno = EIO;
2133     }
2134     PerlMem_free(vms_dir);
2135     return ret;
2136   }
2137   else return chmod(file_spec, mode);
2138 }  /* end of my_chmod */
2139 /*}}}*/
2140
2141
2142 /*{{{FILE *my_tmpfile()*/
2143 FILE *
2144 my_tmpfile(void)
2145 {
2146   FILE *fp;
2147   char *cp;
2148
2149   if ((fp = tmpfile())) return fp;
2150
2151   cp = PerlMem_malloc(L_tmpnam+24);
2152   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2153
2154   if (decc_filename_unix_only == 0)
2155     strcpy(cp,"Sys$Scratch:");
2156   else
2157     strcpy(cp,"/tmp/");
2158   tmpnam(cp+strlen(cp));
2159   strcat(cp,".Perltmp");
2160   fp = fopen(cp,"w+","fop=dlt");
2161   PerlMem_free(cp);
2162   return fp;
2163 }
2164 /*}}}*/
2165
2166
2167 #ifndef HOMEGROWN_POSIX_SIGNALS
2168 /*
2169  * The C RTL's sigaction fails to check for invalid signal numbers so we
2170  * help it out a bit.  The docs are correct, but the actual routine doesn't
2171  * do what the docs say it will.
2172  */
2173 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2174 int
2175 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2176                    struct sigaction* oact)
2177 {
2178   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2179         SETERRNO(EINVAL, SS$_INVARG);
2180         return -1;
2181   }
2182   return sigaction(sig, act, oact);
2183 }
2184 /*}}}*/
2185 #endif
2186
2187 #ifdef KILL_BY_SIGPRC
2188 #include <errnodef.h>
2189
2190 /* We implement our own kill() using the undocumented system service
2191    sys$sigprc for one of two reasons:
2192
2193    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2194    target process to do a sys$exit, which usually can't be handled
2195    gracefully...certainly not by Perl and the %SIG{} mechanism.
2196
2197    2.) If the kill() in the CRTL can't be called from a signal
2198    handler without disappearing into the ether, i.e., the signal
2199    it purportedly sends is never trapped. Still true as of VMS 7.3.
2200
2201    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2202    in the target process rather than calling sys$exit.
2203
2204    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2205    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2206    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2207    with condition codes C$_SIG0+nsig*8, catching the exception on the
2208    target process and resignaling with appropriate arguments.
2209
2210    But we don't have that VMS 7.0+ exception handler, so if you
2211    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2212
2213    Also note that SIGTERM is listed in the docs as being "unimplemented",
2214    yet always seems to be signaled with a VMS condition code of 4 (and
2215    correctly handled for that code).  So we hardwire it in.
2216
2217    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2218    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2219    than signalling with an unrecognized (and unhandled by CRTL) code.
2220 */
2221
2222 #define _MY_SIG_MAX 28
2223
2224 static unsigned int
2225 Perl_sig_to_vmscondition_int(int sig)
2226 {
2227     static unsigned int sig_code[_MY_SIG_MAX+1] =
2228     {
2229         0,                  /*  0 ZERO     */
2230         SS$_HANGUP,         /*  1 SIGHUP   */
2231         SS$_CONTROLC,       /*  2 SIGINT   */
2232         SS$_CONTROLY,       /*  3 SIGQUIT  */
2233         SS$_RADRMOD,        /*  4 SIGILL   */
2234         SS$_BREAK,          /*  5 SIGTRAP  */
2235         SS$_OPCCUS,         /*  6 SIGABRT  */
2236         SS$_COMPAT,         /*  7 SIGEMT   */
2237 #ifdef __VAX
2238         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2239 #else
2240         SS$_HPARITH,        /*  8 SIGFPE AXP */
2241 #endif
2242         SS$_ABORT,          /*  9 SIGKILL  */
2243         SS$_ACCVIO,         /* 10 SIGBUS   */
2244         SS$_ACCVIO,         /* 11 SIGSEGV  */
2245         SS$_BADPARAM,       /* 12 SIGSYS   */
2246         SS$_NOMBX,          /* 13 SIGPIPE  */
2247         SS$_ASTFLT,         /* 14 SIGALRM  */
2248         4,                  /* 15 SIGTERM  */
2249         0,                  /* 16 SIGUSR1  */
2250         0,                  /* 17 SIGUSR2  */
2251         0,                  /* 18 */
2252         0,                  /* 19 */
2253         0,                  /* 20 SIGCHLD  */
2254         0,                  /* 21 SIGCONT  */
2255         0,                  /* 22 SIGSTOP  */
2256         0,                  /* 23 SIGTSTP  */
2257         0,                  /* 24 SIGTTIN  */
2258         0,                  /* 25 SIGTTOU  */
2259         0,                  /* 26 */
2260         0,                  /* 27 */
2261         0                   /* 28 SIGWINCH  */
2262     };
2263
2264 #if __VMS_VER >= 60200000
2265     static int initted = 0;
2266     if (!initted) {
2267         initted = 1;
2268         sig_code[16] = C$_SIGUSR1;
2269         sig_code[17] = C$_SIGUSR2;
2270 #if __CRTL_VER >= 70000000
2271         sig_code[20] = C$_SIGCHLD;
2272 #endif
2273 #if __CRTL_VER >= 70300000
2274         sig_code[28] = C$_SIGWINCH;
2275 #endif
2276     }
2277 #endif
2278
2279     if (sig < _SIG_MIN) return 0;
2280     if (sig > _MY_SIG_MAX) return 0;
2281     return sig_code[sig];
2282 }
2283
2284 unsigned int
2285 Perl_sig_to_vmscondition(int sig)
2286 {
2287 #ifdef SS$_DEBUG
2288     if (vms_debug_on_exception != 0)
2289         lib$signal(SS$_DEBUG);
2290 #endif
2291     return Perl_sig_to_vmscondition_int(sig);
2292 }
2293
2294
2295 int
2296 Perl_my_kill(int pid, int sig)
2297 {
2298     dTHX;
2299     int iss;
2300     unsigned int code;
2301     int sys$sigprc(unsigned int *pidadr,
2302                      struct dsc$descriptor_s *prcname,
2303                      unsigned int code);
2304
2305      /* sig 0 means validate the PID */
2306     /*------------------------------*/
2307     if (sig == 0) {
2308         const unsigned long int jpicode = JPI$_PID;
2309         pid_t ret_pid;
2310         int status;
2311         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2312         if ($VMS_STATUS_SUCCESS(status))
2313            return 0;
2314         switch (status) {
2315         case SS$_NOSUCHNODE:
2316         case SS$_UNREACHABLE:
2317         case SS$_NONEXPR:
2318            errno = ESRCH;
2319            break;
2320         case SS$_NOPRIV:
2321            errno = EPERM;
2322            break;
2323         default:
2324            errno = EVMSERR;
2325         }
2326         vaxc$errno=status;
2327         return -1;
2328     }
2329
2330     code = Perl_sig_to_vmscondition_int(sig);
2331
2332     if (!code) {
2333         SETERRNO(EINVAL, SS$_BADPARAM);
2334         return -1;
2335     }
2336
2337     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2338      * signals are to be sent to multiple processes.
2339      *  pid = 0 - all processes in group except ones that the system exempts
2340      *  pid = -1 - all processes except ones that the system exempts
2341      *  pid = -n - all processes in group (abs(n)) except ...
2342      * For now, just report as not supported.
2343      */
2344
2345     if (pid <= 0) {
2346         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2347         return -1;
2348     }
2349
2350     iss = sys$sigprc((unsigned int *)&pid,0,code);
2351     if (iss&1) return 0;
2352
2353     switch (iss) {
2354       case SS$_NOPRIV:
2355         set_errno(EPERM);  break;
2356       case SS$_NONEXPR:
2357       case SS$_NOSUCHNODE:
2358       case SS$_UNREACHABLE:
2359         set_errno(ESRCH);  break;
2360       case SS$_INSFMEM:
2361         set_errno(ENOMEM); break;
2362       default:
2363         _ckvmssts(iss);
2364         set_errno(EVMSERR);
2365     }
2366     set_vaxc_errno(iss);
2367
2368     return -1;
2369 }
2370 #endif
2371
2372 /* Routine to convert a VMS status code to a UNIX status code.
2373 ** More tricky than it appears because of conflicting conventions with
2374 ** existing code.
2375 **
2376 ** VMS status codes are a bit mask, with the least significant bit set for
2377 ** success.
2378 **
2379 ** Special UNIX status of EVMSERR indicates that no translation is currently
2380 ** available, and programs should check the VMS status code.
2381 **
2382 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2383 ** decoding.
2384 */
2385
2386 #ifndef C_FACILITY_NO
2387 #define C_FACILITY_NO 0x350000
2388 #endif
2389 #ifndef DCL_IVVERB
2390 #define DCL_IVVERB 0x38090
2391 #endif
2392
2393 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2394 {
2395 int facility;
2396 int fac_sp;
2397 int msg_no;
2398 int msg_status;
2399 int unix_status;
2400
2401   /* Assume the best or the worst */
2402   if (vms_status & STS$M_SUCCESS)
2403     unix_status = 0;
2404   else
2405     unix_status = EVMSERR;
2406
2407   msg_status = vms_status & ~STS$M_CONTROL;
2408
2409   facility = vms_status & STS$M_FAC_NO;
2410   fac_sp = vms_status & STS$M_FAC_SP;
2411   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2412
2413   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2414     switch(msg_no) {
2415     case SS$_NORMAL:
2416         unix_status = 0;
2417         break;
2418     case SS$_ACCVIO:
2419         unix_status = EFAULT;
2420         break;
2421     case SS$_DEVOFFLINE:
2422         unix_status = EBUSY;
2423         break;
2424     case SS$_CLEARED:
2425         unix_status = ENOTCONN;
2426         break;
2427     case SS$_IVCHAN:
2428     case SS$_IVLOGNAM:
2429     case SS$_BADPARAM:
2430     case SS$_IVLOGTAB:
2431     case SS$_NOLOGNAM:
2432     case SS$_NOLOGTAB:
2433     case SS$_INVFILFOROP:
2434     case SS$_INVARG:
2435     case SS$_NOSUCHID:
2436     case SS$_IVIDENT:
2437         unix_status = EINVAL;
2438         break;
2439     case SS$_UNSUPPORTED:
2440         unix_status = ENOTSUP;
2441         break;
2442     case SS$_FILACCERR:
2443     case SS$_NOGRPPRV:
2444     case SS$_NOSYSPRV:
2445         unix_status = EACCES;
2446         break;
2447     case SS$_DEVICEFULL:
2448         unix_status = ENOSPC;
2449         break;
2450     case SS$_NOSUCHDEV:
2451         unix_status = ENODEV;
2452         break;
2453     case SS$_NOSUCHFILE:
2454     case SS$_NOSUCHOBJECT:
2455         unix_status = ENOENT;
2456         break;
2457     case SS$_ABORT:                                 /* Fatal case */
2458     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2459     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2460         unix_status = EINTR;
2461         break;
2462     case SS$_BUFFEROVF:
2463         unix_status = E2BIG;
2464         break;
2465     case SS$_INSFMEM:
2466         unix_status = ENOMEM;
2467         break;
2468     case SS$_NOPRIV:
2469         unix_status = EPERM;
2470         break;
2471     case SS$_NOSUCHNODE:
2472     case SS$_UNREACHABLE:
2473         unix_status = ESRCH;
2474         break;
2475     case SS$_NONEXPR:
2476         unix_status = ECHILD;
2477         break;
2478     default:
2479         if ((facility == 0) && (msg_no < 8)) {
2480           /* These are not real VMS status codes so assume that they are
2481           ** already UNIX status codes
2482           */
2483           unix_status = msg_no;
2484           break;
2485         }
2486     }
2487   }
2488   else {
2489     /* Translate a POSIX exit code to a UNIX exit code */
2490     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2491         unix_status = (msg_no & 0x07F8) >> 3;
2492     }
2493     else {
2494
2495          /* Documented traditional behavior for handling VMS child exits */
2496         /*--------------------------------------------------------------*/
2497         if (child_flag != 0) {
2498
2499              /* Success / Informational return 0 */
2500             /*----------------------------------*/
2501             if (msg_no & STS$K_SUCCESS)
2502                 return 0;
2503
2504              /* Warning returns 1 */
2505             /*-------------------*/
2506             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2507                 return 1;
2508
2509              /* Everything else pass through the severity bits */
2510             /*------------------------------------------------*/
2511             return (msg_no & STS$M_SEVERITY);
2512         }
2513
2514          /* Normal VMS status to ERRNO mapping attempt */
2515         /*--------------------------------------------*/
2516         switch(msg_status) {
2517         /* case RMS$_EOF: */ /* End of File */
2518         case RMS$_FNF:  /* File Not Found */
2519         case RMS$_DNF:  /* Dir Not Found */
2520                 unix_status = ENOENT;
2521                 break;
2522         case RMS$_RNF:  /* Record Not Found */
2523                 unix_status = ESRCH;
2524                 break;
2525         case RMS$_DIR:
2526                 unix_status = ENOTDIR;
2527                 break;
2528         case RMS$_DEV:
2529                 unix_status = ENODEV;
2530                 break;
2531         case RMS$_IFI:
2532         case RMS$_FAC:
2533         case RMS$_ISI:
2534                 unix_status = EBADF;
2535                 break;
2536         case RMS$_FEX:
2537                 unix_status = EEXIST;
2538                 break;
2539         case RMS$_SYN:
2540         case RMS$_FNM:
2541         case LIB$_INVSTRDES:
2542         case LIB$_INVARG:
2543         case LIB$_NOSUCHSYM:
2544         case LIB$_INVSYMNAM:
2545         case DCL_IVVERB:
2546                 unix_status = EINVAL;
2547                 break;
2548         case CLI$_BUFOVF:
2549         case RMS$_RTB:
2550         case CLI$_TKNOVF:
2551         case CLI$_RSLOVF:
2552                 unix_status = E2BIG;
2553                 break;
2554         case RMS$_PRV:  /* No privilege */
2555         case RMS$_ACC:  /* ACP file access failed */
2556         case RMS$_WLK:  /* Device write locked */
2557                 unix_status = EACCES;
2558                 break;
2559         /* case RMS$_NMF: */  /* No more files */
2560         }
2561     }
2562   }
2563
2564   return unix_status;
2565 }
2566
2567 /* Try to guess at what VMS error status should go with a UNIX errno
2568  * value.  This is hard to do as there could be many possible VMS
2569  * error statuses that caused the errno value to be set.
2570  */
2571
2572 int Perl_unix_status_to_vms(int unix_status)
2573 {
2574 int test_unix_status;
2575
2576      /* Trivial cases first */
2577     /*---------------------*/
2578     if (unix_status == EVMSERR)
2579         return vaxc$errno;
2580
2581      /* Is vaxc$errno sane? */
2582     /*---------------------*/
2583     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2584     if (test_unix_status == unix_status)
2585         return vaxc$errno;
2586
2587      /* If way out of range, must be VMS code already */
2588     /*-----------------------------------------------*/
2589     if (unix_status > EVMSERR)
2590         return unix_status;
2591
2592      /* If out of range, punt */
2593     /*-----------------------*/
2594     if (unix_status > __ERRNO_MAX)
2595         return SS$_ABORT;
2596
2597
2598      /* Ok, now we have to do it the hard way. */
2599     /*----------------------------------------*/
2600     switch(unix_status) {
2601     case 0:     return SS$_NORMAL;
2602     case EPERM: return SS$_NOPRIV;
2603     case ENOENT: return SS$_NOSUCHOBJECT;
2604     case ESRCH: return SS$_UNREACHABLE;
2605     case EINTR: return SS$_ABORT;
2606     /* case EIO: */
2607     /* case ENXIO:  */
2608     case E2BIG: return SS$_BUFFEROVF;
2609     /* case ENOEXEC */
2610     case EBADF: return RMS$_IFI;
2611     case ECHILD: return SS$_NONEXPR;
2612     /* case EAGAIN */
2613     case ENOMEM: return SS$_INSFMEM;
2614     case EACCES: return SS$_FILACCERR;
2615     case EFAULT: return SS$_ACCVIO;
2616     /* case ENOTBLK */
2617     case EBUSY: return SS$_DEVOFFLINE;
2618     case EEXIST: return RMS$_FEX;
2619     /* case EXDEV */
2620     case ENODEV: return SS$_NOSUCHDEV;
2621     case ENOTDIR: return RMS$_DIR;
2622     /* case EISDIR */
2623     case EINVAL: return SS$_INVARG;
2624     /* case ENFILE */
2625     /* case EMFILE */
2626     /* case ENOTTY */
2627     /* case ETXTBSY */
2628     /* case EFBIG */
2629     case ENOSPC: return SS$_DEVICEFULL;
2630     case ESPIPE: return LIB$_INVARG;
2631     /* case EROFS: */
2632     /* case EMLINK: */
2633     /* case EPIPE: */
2634     /* case EDOM */
2635     case ERANGE: return LIB$_INVARG;
2636     /* case EWOULDBLOCK */
2637     /* case EINPROGRESS */
2638     /* case EALREADY */
2639     /* case ENOTSOCK */
2640     /* case EDESTADDRREQ */
2641     /* case EMSGSIZE */
2642     /* case EPROTOTYPE */
2643     /* case ENOPROTOOPT */
2644     /* case EPROTONOSUPPORT */
2645     /* case ESOCKTNOSUPPORT */
2646     /* case EOPNOTSUPP */
2647     /* case EPFNOSUPPORT */
2648     /* case EAFNOSUPPORT */
2649     /* case EADDRINUSE */
2650     /* case EADDRNOTAVAIL */
2651     /* case ENETDOWN */
2652     /* case ENETUNREACH */
2653     /* case ENETRESET */
2654     /* case ECONNABORTED */
2655     /* case ECONNRESET */
2656     /* case ENOBUFS */
2657     /* case EISCONN */
2658     case ENOTCONN: return SS$_CLEARED;
2659     /* case ESHUTDOWN */
2660     /* case ETOOMANYREFS */
2661     /* case ETIMEDOUT */
2662     /* case ECONNREFUSED */
2663     /* case ELOOP */
2664     /* case ENAMETOOLONG */
2665     /* case EHOSTDOWN */
2666     /* case EHOSTUNREACH */
2667     /* case ENOTEMPTY */
2668     /* case EPROCLIM */
2669     /* case EUSERS  */
2670     /* case EDQUOT  */
2671     /* case ENOMSG  */
2672     /* case EIDRM */
2673     /* case EALIGN */
2674     /* case ESTALE */
2675     /* case EREMOTE */
2676     /* case ENOLCK */
2677     /* case ENOSYS */
2678     /* case EFTYPE */
2679     /* case ECANCELED */
2680     /* case EFAIL */
2681     /* case EINPROG */
2682     case ENOTSUP:
2683         return SS$_UNSUPPORTED;
2684     /* case EDEADLK */
2685     /* case ENWAIT */
2686     /* case EILSEQ */
2687     /* case EBADCAT */
2688     /* case EBADMSG */
2689     /* case EABANDONED */
2690     default:
2691         return SS$_ABORT; /* punt */
2692     }
2693
2694   return SS$_ABORT; /* Should not get here */
2695 }
2696
2697
2698 /* default piping mailbox size */
2699 #define PERL_BUFSIZ        512
2700
2701
2702 static void
2703 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2704 {
2705   unsigned long int mbxbufsiz;
2706   static unsigned long int syssize = 0;
2707   unsigned long int dviitm = DVI$_DEVNAM;
2708   char csize[LNM$C_NAMLENGTH+1];
2709   int sts;
2710
2711   if (!syssize) {
2712     unsigned long syiitm = SYI$_MAXBUF;
2713     /*
2714      * Get the SYSGEN parameter MAXBUF
2715      *
2716      * If the logical 'PERL_MBX_SIZE' is defined
2717      * use the value of the logical instead of PERL_BUFSIZ, but
2718      * keep the size between 128 and MAXBUF.
2719      *
2720      */
2721     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2722   }
2723
2724   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2725       mbxbufsiz = atoi(csize);
2726   } else {
2727       mbxbufsiz = PERL_BUFSIZ;
2728   }
2729   if (mbxbufsiz < 128) mbxbufsiz = 128;
2730   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2731
2732   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2733
2734   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2735   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2736
2737 }  /* end of create_mbx() */
2738
2739
2740 /*{{{  my_popen and my_pclose*/
2741
2742 typedef struct _iosb           IOSB;
2743 typedef struct _iosb*         pIOSB;
2744 typedef struct _pipe           Pipe;
2745 typedef struct _pipe*         pPipe;
2746 typedef struct pipe_details    Info;
2747 typedef struct pipe_details*  pInfo;
2748 typedef struct _srqp            RQE;
2749 typedef struct _srqp*          pRQE;
2750 typedef struct _tochildbuf      CBuf;
2751 typedef struct _tochildbuf*    pCBuf;
2752
2753 struct _iosb {
2754     unsigned short status;
2755     unsigned short count;
2756     unsigned long  dvispec;
2757 };
2758
2759 #pragma member_alignment save
2760 #pragma nomember_alignment quadword
2761 struct _srqp {          /* VMS self-relative queue entry */
2762     unsigned long qptr[2];
2763 };
2764 #pragma member_alignment restore
2765 static RQE  RQE_ZERO = {0,0};
2766
2767 struct _tochildbuf {
2768     RQE             q;
2769     int             eof;
2770     unsigned short  size;
2771     char            *buf;
2772 };
2773
2774 struct _pipe {
2775     RQE            free;
2776     RQE            wait;
2777     int            fd_out;
2778     unsigned short chan_in;
2779     unsigned short chan_out;
2780     char          *buf;
2781     unsigned int   bufsize;
2782     IOSB           iosb;
2783     IOSB           iosb2;
2784     int           *pipe_done;
2785     int            retry;
2786     int            type;
2787     int            shut_on_empty;
2788     int            need_wake;
2789     pPipe         *home;
2790     pInfo          info;
2791     pCBuf          curr;
2792     pCBuf          curr2;
2793 #if defined(PERL_IMPLICIT_CONTEXT)
2794     void            *thx;           /* Either a thread or an interpreter */
2795                                     /* pointer, depending on how we're built */
2796 #endif
2797 };
2798
2799
2800 struct pipe_details
2801 {
2802     pInfo           next;
2803     PerlIO *fp;  /* file pointer to pipe mailbox */
2804     int useFILE; /* using stdio, not perlio */
2805     int pid;   /* PID of subprocess */
2806     int mode;  /* == 'r' if pipe open for reading */
2807     int done;  /* subprocess has completed */
2808     int waiting; /* waiting for completion/closure */
2809     int             closing;        /* my_pclose is closing this pipe */
2810     unsigned long   completion;     /* termination status of subprocess */
2811     pPipe           in;             /* pipe in to sub */
2812     pPipe           out;            /* pipe out of sub */
2813     pPipe           err;            /* pipe of sub's sys$error */
2814     int             in_done;        /* true when in pipe finished */
2815     int             out_done;
2816     int             err_done;
2817     unsigned short  xchan;          /* channel to debug xterm */
2818     unsigned short  xchan_valid;    /* channel is assigned */
2819 };
2820
2821 struct exit_control_block
2822 {
2823     struct exit_control_block *flink;
2824     unsigned long int   (*exit_routine)();
2825     unsigned long int arg_count;
2826     unsigned long int *status_address;
2827     unsigned long int exit_status;
2828 };
2829
2830 typedef struct _closed_pipes    Xpipe;
2831 typedef struct _closed_pipes*  pXpipe;
2832
2833 struct _closed_pipes {
2834     int             pid;            /* PID of subprocess */
2835     unsigned long   completion;     /* termination status of subprocess */
2836 };
2837 #define NKEEPCLOSED 50
2838 static Xpipe closed_list[NKEEPCLOSED];
2839 static int   closed_index = 0;
2840 static int   closed_num = 0;
2841
2842 #define RETRY_DELAY     "0 ::0.20"
2843 #define MAX_RETRY              50
2844
2845 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2846 static unsigned long mypid;
2847 static unsigned long delaytime[2];
2848
2849 static pInfo open_pipes = NULL;
2850 static $DESCRIPTOR(nl_desc, "NL:");
2851
2852 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2853
2854
2855
2856 static unsigned long int
2857 pipe_exit_routine(pTHX)
2858 {
2859     pInfo info;
2860     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2861     int sts, did_stuff, need_eof, j;
2862
2863    /*
2864     * Flush any pending i/o, but since we are in process run-down, be
2865     * careful about referencing PerlIO structures that may already have
2866     * been deallocated.  We may not even have an interpreter anymore.
2867     */
2868     info = open_pipes;
2869     while (info) {
2870         if (info->fp) {
2871            if (!info->useFILE
2872 #if defined(USE_ITHREADS)
2873              && my_perl
2874 #endif
2875              && PL_perlio_fd_refcnt)
2876                PerlIO_flush(info->fp);
2877            else
2878                fflush((FILE *)info->fp);
2879         }
2880         info = info->next;
2881     }
2882
2883     /*
2884      next we try sending an EOF...ignore if doesn't work, make sure we
2885      don't hang
2886     */
2887     did_stuff = 0;
2888     info = open_pipes;
2889
2890     while (info) {
2891       int need_eof;
2892       _ckvmssts_noperl(sys$setast(0));
2893       if (info->in && !info->in->shut_on_empty) {
2894         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2895                           0, 0, 0, 0, 0, 0));
2896         info->waiting = 1;
2897         did_stuff = 1;
2898       }
2899       _ckvmssts_noperl(sys$setast(1));
2900       info = info->next;
2901     }
2902
2903     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2904
2905     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2906         int nwait = 0;
2907
2908         info = open_pipes;
2909         while (info) {
2910           _ckvmssts_noperl(sys$setast(0));
2911           if (info->waiting && info->done)
2912                 info->waiting = 0;
2913           nwait += info->waiting;
2914           _ckvmssts_noperl(sys$setast(1));
2915           info = info->next;
2916         }
2917         if (!nwait) break;
2918         sleep(1);
2919     }
2920
2921     did_stuff = 0;
2922     info = open_pipes;
2923     while (info) {
2924       _ckvmssts_noperl(sys$setast(0));
2925       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2926         sts = sys$forcex(&info->pid,0,&abort);
2927         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2928         did_stuff = 1;
2929       }
2930       _ckvmssts_noperl(sys$setast(1));
2931       info = info->next;
2932     }
2933
2934     /* again, wait for effect */
2935
2936     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2937         int nwait = 0;
2938
2939         info = open_pipes;
2940         while (info) {
2941           _ckvmssts_noperl(sys$setast(0));
2942           if (info->waiting && info->done)
2943                 info->waiting = 0;
2944           nwait += info->waiting;
2945           _ckvmssts_noperl(sys$setast(1));
2946           info = info->next;
2947         }
2948         if (!nwait) break;
2949         sleep(1);
2950     }
2951
2952     info = open_pipes;
2953     while (info) {
2954       _ckvmssts_noperl(sys$setast(0));
2955       if (!info->done) {  /* We tried to be nice . . . */
2956         sts = sys$delprc(&info->pid,0);
2957         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2958         info->done = 1;  /* sys$delprc is as done as we're going to get. */
2959       }
2960       _ckvmssts_noperl(sys$setast(1));
2961       info = info->next;
2962     }
2963
2964     while(open_pipes) {
2965       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2966       else if (!(sts & 1)) retsts = sts;
2967     }
2968     return retsts;
2969 }
2970
2971 static struct exit_control_block pipe_exitblock =
2972        {(struct exit_control_block *) 0,
2973         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2974
2975 static void pipe_mbxtofd_ast(pPipe p);
2976 static void pipe_tochild1_ast(pPipe p);
2977 static void pipe_tochild2_ast(pPipe p);
2978
2979 static void
2980 popen_completion_ast(pInfo info)
2981 {
2982   pInfo i = open_pipes;
2983   int iss;
2984   int sts;
2985   pXpipe x;
2986
2987   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2988   closed_list[closed_index].pid = info->pid;
2989   closed_list[closed_index].completion = info->completion;
2990   closed_index++;
2991   if (closed_index == NKEEPCLOSED)
2992     closed_index = 0;
2993   closed_num++;
2994
2995   while (i) {
2996     if (i == info) break;
2997     i = i->next;
2998   }
2999   if (!i) return;       /* unlinked, probably freed too */
3000
3001   info->done = TRUE;
3002
3003 /*
3004     Writing to subprocess ...
3005             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3006
3007             chan_out may be waiting for "done" flag, or hung waiting
3008             for i/o completion to child...cancel the i/o.  This will
3009             put it into "snarf mode" (done but no EOF yet) that discards
3010             input.
3011
3012     Output from subprocess (stdout, stderr) needs to be flushed and
3013     shut down.   We try sending an EOF, but if the mbx is full the pipe
3014     routine should still catch the "shut_on_empty" flag, telling it to
3015     use immediate-style reads so that "mbx empty" -> EOF.
3016
3017
3018 */
3019   if (info->in && !info->in_done) {               /* only for mode=w */
3020         if (info->in->shut_on_empty && info->in->need_wake) {
3021             info->in->need_wake = FALSE;
3022             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3023         } else {
3024             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3025         }
3026   }
3027
3028   if (info->out && !info->out_done) {             /* were we also piping output? */
3029       info->out->shut_on_empty = TRUE;
3030       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3031       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3032       _ckvmssts_noperl(iss);
3033   }
3034
3035   if (info->err && !info->err_done) {        /* we were piping stderr */
3036         info->err->shut_on_empty = TRUE;
3037         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3038         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3039         _ckvmssts_noperl(iss);
3040   }
3041   _ckvmssts_noperl(sys$setef(pipe_ef));
3042
3043 }
3044
3045 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3046 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3047
3048 /*
3049     we actually differ from vmstrnenv since we use this to
3050     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3051     are pointing to the same thing
3052 */
3053
3054 static unsigned short
3055 popen_translate(pTHX_ char *logical, char *result)
3056 {
3057     int iss;
3058     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3059     $DESCRIPTOR(d_log,"");
3060     struct _il3 {
3061         unsigned short length;
3062         unsigned short code;
3063         char *         buffer_addr;
3064         unsigned short *retlenaddr;
3065     } itmlst[2];
3066     unsigned short l, ifi;
3067
3068     d_log.dsc$a_pointer = logical;
3069     d_log.dsc$w_length  = strlen(logical);
3070
3071     itmlst[0].code = LNM$_STRING;
3072     itmlst[0].length = 255;
3073     itmlst[0].buffer_addr = result;
3074     itmlst[0].retlenaddr = &l;
3075
3076     itmlst[1].code = 0;
3077     itmlst[1].length = 0;
3078     itmlst[1].buffer_addr = 0;
3079     itmlst[1].retlenaddr = 0;
3080
3081     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3082     if (iss == SS$_NOLOGNAM) {
3083         iss = SS$_NORMAL;
3084         l = 0;
3085     }
3086     if (!(iss&1)) lib$signal(iss);
3087     result[l] = '\0';
3088 /*
3089     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
3090     strip it off and return the ifi, if any
3091 */
3092     ifi  = 0;
3093     if (result[0] == 0x1b && result[1] == 0x00) {
3094         memmove(&ifi,result+2,2);
3095         strcpy(result,result+4);
3096     }
3097     return ifi;     /* this is the RMS internal file id */
3098 }
3099
3100 static void pipe_infromchild_ast(pPipe p);
3101
3102 /*
3103     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3104     inside an AST routine without worrying about reentrancy and which Perl
3105     memory allocator is being used.
3106
3107     We read data and queue up the buffers, then spit them out one at a
3108     time to the output mailbox when the output mailbox is ready for one.
3109
3110 */
3111 #define INITIAL_TOCHILDQUEUE  2
3112
3113 static pPipe
3114 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3115 {
3116     pPipe p;
3117     pCBuf b;
3118     char mbx1[64], mbx2[64];
3119     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3120                                       DSC$K_CLASS_S, mbx1},
3121                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3122                                       DSC$K_CLASS_S, mbx2};
3123     unsigned int dviitm = DVI$_DEVBUFSIZ;
3124     int j, n;
3125
3126     n = sizeof(Pipe);
3127     _ckvmssts(lib$get_vm(&n, &p));
3128
3129     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3130     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3131     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3132
3133     p->buf           = 0;
3134     p->shut_on_empty = FALSE;
3135     p->need_wake     = FALSE;
3136     p->type          = 0;
3137     p->retry         = 0;
3138     p->iosb.status   = SS$_NORMAL;
3139     p->iosb2.status  = SS$_NORMAL;
3140     p->free          = RQE_ZERO;
3141     p->wait          = RQE_ZERO;
3142     p->curr          = 0;
3143     p->curr2         = 0;
3144     p->info          = 0;
3145 #ifdef PERL_IMPLICIT_CONTEXT
3146     p->thx           = aTHX;
3147 #endif
3148
3149     n = sizeof(CBuf) + p->bufsize;
3150
3151     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3152         _ckvmssts(lib$get_vm(&n, &b));
3153         b->buf = (char *) b + sizeof(CBuf);
3154         _ckvmssts(lib$insqhi(b, &p->free));
3155     }
3156
3157     pipe_tochild2_ast(p);
3158     pipe_tochild1_ast(p);
3159     strcpy(wmbx, mbx1);
3160     strcpy(rmbx, mbx2);
3161     return p;
3162 }
3163
3164 /*  reads the MBX Perl is writing, and queues */
3165
3166 static void
3167 pipe_tochild1_ast(pPipe p)
3168 {
3169     pCBuf b = p->curr;
3170     int iss = p->iosb.status;
3171     int eof = (iss == SS$_ENDOFFILE);
3172     int sts;
3173 #ifdef PERL_IMPLICIT_CONTEXT
3174     pTHX = p->thx;
3175 #endif
3176
3177     if (p->retry) {
3178         if (eof) {
3179             p->shut_on_empty = TRUE;
3180             b->eof     = TRUE;
3181             _ckvmssts(sys$dassgn(p->chan_in));
3182         } else  {
3183             _ckvmssts(iss);
3184         }
3185
3186         b->eof  = eof;
3187         b->size = p->iosb.count;
3188         _ckvmssts(sts = lib$insqhi(b, &p->wait));
3189         if (p->need_wake) {
3190             p->need_wake = FALSE;
3191             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3192         }
3193     } else {
3194         p->retry = 1;   /* initial call */
3195     }
3196
3197     if (eof) {                  /* flush the free queue, return when done */
3198         int n = sizeof(CBuf) + p->bufsize;
3199         while (1) {
3200             iss = lib$remqti(&p->free, &b);
3201             if (iss == LIB$_QUEWASEMP) return;
3202             _ckvmssts(iss);
3203             _ckvmssts(lib$free_vm(&n, &b));
3204         }
3205     }
3206
3207     iss = lib$remqti(&p->free, &b);
3208     if (iss == LIB$_QUEWASEMP) {
3209         int n = sizeof(CBuf) + p->bufsize;
3210         _ckvmssts(lib$get_vm(&n, &b));
3211         b->buf = (char *) b + sizeof(CBuf);
3212     } else {
3213        _ckvmssts(iss);
3214     }
3215
3216     p->curr = b;
3217     iss = sys$qio(0,p->chan_in,
3218              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3219              &p->iosb,
3220              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3221     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3222     _ckvmssts(iss);
3223 }
3224
3225
3226 /* writes queued buffers to output, waits for each to complete before
3227    doing the next */
3228
3229 static void
3230 pipe_tochild2_ast(pPipe p)
3231 {
3232     pCBuf b = p->curr2;
3233     int iss = p->iosb2.status;
3234     int n = sizeof(CBuf) + p->bufsize;
3235     int done = (p->info && p->info->done) ||
3236               iss == SS$_CANCEL || iss == SS$_ABORT;
3237 #if defined(PERL_IMPLICIT_CONTEXT)
3238     pTHX = p->thx;
3239 #endif
3240
3241     do {
3242         if (p->type) {         /* type=1 has old buffer, dispose */
3243             if (p->shut_on_empty) {
3244                 _ckvmssts(lib$free_vm(&n, &b));
3245             } else {
3246                 _ckvmssts(lib$insqhi(b, &p->free));
3247             }
3248             p->type = 0;
3249         }
3250
3251         iss = lib$remqti(&p->wait, &b);
3252         if (iss == LIB$_QUEWASEMP) {
3253             if (p->shut_on_empty) {
3254                 if (done) {
3255                     _ckvmssts(sys$dassgn(p->chan_out));
3256                     *p->pipe_done = TRUE;
3257                     _ckvmssts(sys$setef(pipe_ef));
3258                 } else {
3259                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3260                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3261                 }
3262                 return;
3263             }
3264             p->need_wake = TRUE;
3265             return;
3266         }
3267         _ckvmssts(iss);
3268         p->type = 1;
3269     } while (done);
3270
3271
3272     p->curr2 = b;
3273     if (b->eof) {
3274         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3275             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3276     } else {
3277         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3278             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3279     }
3280
3281     return;
3282
3283 }
3284
3285
3286 static pPipe
3287 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3288 {
3289     pPipe p;
3290     char mbx1[64], mbx2[64];
3291     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3292                                       DSC$K_CLASS_S, mbx1},
3293                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3294                                       DSC$K_CLASS_S, mbx2};
3295     unsigned int dviitm = DVI$_DEVBUFSIZ;
3296
3297     int n = sizeof(Pipe);
3298     _ckvmssts(lib$get_vm(&n, &p));
3299     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3300     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3301
3302     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3303     n = p->bufsize * sizeof(char);
3304     _ckvmssts(lib$get_vm(&n, &p->buf));
3305     p->shut_on_empty = FALSE;
3306     p->info   = 0;
3307     p->type   = 0;
3308     p->iosb.status = SS$_NORMAL;
3309 #if defined(PERL_IMPLICIT_CONTEXT)
3310     p->thx = aTHX;
3311 #endif
3312     pipe_infromchild_ast(p);
3313
3314     strcpy(wmbx, mbx1);
3315     strcpy(rmbx, mbx2);
3316     return p;
3317 }
3318
3319 static void
3320 pipe_infromchild_ast(pPipe p)
3321 {
3322     int iss = p->iosb.status;
3323     int eof = (iss == SS$_ENDOFFILE);
3324     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3325     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3326 #if defined(PERL_IMPLICIT_CONTEXT)
3327     pTHX = p->thx;
3328 #endif
3329
3330     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3331         _ckvmssts(sys$dassgn(p->chan_out));
3332         p->chan_out = 0;
3333     }
3334
3335     /* read completed:
3336             input shutdown if EOF from self (done or shut_on_empty)
3337             output shutdown if closing flag set (my_pclose)
3338             send data/eof from child or eof from self
3339             otherwise, re-read (snarf of data from child)
3340     */
3341
3342     if (p->type == 1) {
3343         p->type = 0;
3344         if (myeof && p->chan_in) {                  /* input shutdown */
3345             _ckvmssts(sys$dassgn(p->chan_in));
3346             p->chan_in = 0;
3347         }
3348
3349         if (p->chan_out) {
3350             if (myeof || kideof) {      /* pass EOF to parent */
3351                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3352                               pipe_infromchild_ast, p,
3353                               0, 0, 0, 0, 0, 0));
3354                 return;
3355             } else if (eof) {       /* eat EOF --- fall through to read*/
3356
3357             } else {                /* transmit data */
3358                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3359                               pipe_infromchild_ast,p,
3360                               p->buf, p->iosb.count, 0, 0, 0, 0));
3361                 return;
3362             }
3363         }
3364     }
3365
3366     /*  everything shut? flag as done */
3367
3368     if (!p->chan_in && !p->chan_out) {
3369         *p->pipe_done = TRUE;
3370         _ckvmssts(sys$setef(pipe_ef));
3371         return;
3372     }
3373
3374     /* write completed (or read, if snarfing from child)
3375             if still have input active,
3376                queue read...immediate mode if shut_on_empty so we get EOF if empty
3377             otherwise,
3378                check if Perl reading, generate EOFs as needed
3379     */
3380
3381     if (p->type == 0) {
3382         p->type = 1;
3383         if (p->chan_in) {
3384             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3385                           pipe_infromchild_ast,p,
3386                           p->buf, p->bufsize, 0, 0, 0, 0);
3387             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3388             _ckvmssts(iss);
3389         } else {           /* send EOFs for extra reads */
3390             p->iosb.status = SS$_ENDOFFILE;
3391             p->iosb.dvispec = 0;
3392             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3393                       0, 0, 0,
3394                       pipe_infromchild_ast, p, 0, 0, 0, 0));
3395         }
3396     }
3397 }
3398
3399 static pPipe
3400 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3401 {
3402     pPipe p;
3403     char mbx[64];
3404     unsigned long dviitm = DVI$_DEVBUFSIZ;
3405     struct stat s;
3406     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3407                                       DSC$K_CLASS_S, mbx};
3408     int n = sizeof(Pipe);
3409
3410     /* things like terminals and mbx's don't need this filter */
3411     if (fd && fstat(fd,&s) == 0) {
3412         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3413         char device[65];
3414         unsigned short dev_len;
3415         struct dsc$descriptor_s d_dev;
3416         char * cptr;
3417         struct item_list_3 items[3];
3418         int status;
3419         unsigned short dvi_iosb[4];
3420
3421         cptr = getname(fd, out, 1);
3422         if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3423         d_dev.dsc$a_pointer = out;
3424         d_dev.dsc$w_length = strlen(out);
3425         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3426         d_dev.dsc$b_class = DSC$K_CLASS_S;
3427
3428         items[0].len = 4;
3429         items[0].code = DVI$_DEVCHAR;
3430         items[0].bufadr = &devchar;
3431         items[0].retadr = NULL;
3432         items[1].len = 64;
3433         items[1].code = DVI$_FULLDEVNAM;
3434         items[1].bufadr = device;
3435         items[1].retadr = &dev_len;
3436         items[2].len = 0;
3437         items[2].code = 0;
3438
3439         status = sys$getdviw
3440                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3441         _ckvmssts(status);
3442         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3443             device[dev_len] = 0;
3444
3445             if (!(devchar & DEV$M_DIR)) {
3446                 strcpy(out, device);
3447                 return 0;
3448             }
3449         }
3450     }
3451
3452     _ckvmssts(lib$get_vm(&n, &p));
3453     p->fd_out = dup(fd);
3454     create_mbx(aTHX_ &p->chan_in, &d_mbx);
3455     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3456     n = (p->bufsize+1) * sizeof(char);
3457     _ckvmssts(lib$get_vm(&n, &p->buf));
3458     p->shut_on_empty = FALSE;
3459     p->retry = 0;
3460     p->info  = 0;
3461     strcpy(out, mbx);
3462
3463     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3464                   pipe_mbxtofd_ast, p,
3465                   p->buf, p->bufsize, 0, 0, 0, 0));
3466
3467     return p;
3468 }
3469
3470 static void
3471 pipe_mbxtofd_ast(pPipe p)
3472 {
3473     int iss = p->iosb.status;
3474     int done = p->info->done;
3475     int iss2;
3476     int eof = (iss == SS$_ENDOFFILE);
3477     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3478     int err = !(iss&1) && !eof;
3479 #if defined(PERL_IMPLICIT_CONTEXT)
3480     pTHX = p->thx;
3481 #endif
3482
3483     if (done && myeof) {               /* end piping */
3484         close(p->fd_out);
3485         sys$dassgn(p->chan_in);
3486         *p->pipe_done = TRUE;
3487         _ckvmssts(sys$setef(pipe_ef));
3488         return;
3489     }
3490
3491     if (!err && !eof) {             /* good data to send to file */
3492         p->buf[p->iosb.count] = '\n';
3493         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3494         if (iss2 < 0) {
3495             p->retry++;
3496             if (p->retry < MAX_RETRY) {
3497                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3498                 return;
3499             }
3500         }
3501         p->retry = 0;
3502     } else if (err) {
3503         _ckvmssts(iss);
3504     }
3505
3506
3507     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3508           pipe_mbxtofd_ast, p,
3509           p->buf, p->bufsize, 0, 0, 0, 0);
3510     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3511     _ckvmssts(iss);
3512 }
3513
3514
3515 typedef struct _pipeloc     PLOC;
3516 typedef struct _pipeloc*   pPLOC;
3517
3518 struct _pipeloc {
3519     pPLOC   next;
3520     char    dir[NAM$C_MAXRSS+1];
3521 };
3522 static pPLOC  head_PLOC = 0;
3523
3524 void
3525 free_pipelocs(pTHX_ void *head)
3526 {
3527     pPLOC p, pnext;
3528     pPLOC *pHead = (pPLOC *)head;
3529
3530     p = *pHead;
3531     while (p) {
3532         pnext = p->next;
3533         PerlMem_free(p);
3534         p = pnext;
3535     }
3536     *pHead = 0;
3537 }
3538
3539 static void
3540 store_pipelocs(pTHX)
3541 {
3542     int    i;
3543     pPLOC  p;
3544     AV    *av = 0;
3545     SV    *dirsv;
3546     GV    *gv;
3547     char  *dir, *x;
3548     char  *unixdir;
3549     char  temp[NAM$C_MAXRSS+1];
3550     STRLEN n_a;
3551
3552     if (head_PLOC)
3553         free_pipelocs(aTHX_ &head_PLOC);
3554
3555 /*  the . directory from @INC comes last */
3556
3557     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3558     if (p == NULL) _ckvmssts(SS$_INSFMEM);
3559     p->next = head_PLOC;
3560     head_PLOC = p;
3561     strcpy(p->dir,"./");
3562
3563 /*  get the directory from $^X */
3564
3565     unixdir = PerlMem_malloc(VMS_MAXRSS);
3566     if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3567
3568 #ifdef PERL_IMPLICIT_CONTEXT
3569     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3570 #else
3571     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3572 #endif
3573         strcpy(temp, PL_origargv[0]);
3574         x = strrchr(temp,']');
3575         if (x == NULL) {
3576         x = strrchr(temp,'>');
3577           if (x == NULL) {
3578             /* It could be a UNIX path */
3579             x = strrchr(temp,'/');
3580           }
3581         }
3582         if (x)
3583           x[1] = '\0';
3584         else {
3585           /* Got a bare name, so use default directory */
3586           temp[0] = '.';
3587           temp[1] = '\0';
3588         }
3589
3590         if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
3591             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3592             if (p == NULL) _ckvmssts(SS$_INSFMEM);
3593             p->next = head_PLOC;
3594             head_PLOC = p;
3595             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3596             p->dir[NAM$C_MAXRSS] = '\0';
3597         }
3598     }
3599
3600 /*  reverse order of @INC entries, skip "." since entered above */
3601
3602 #ifdef PERL_IMPLICIT_CONTEXT
3603     if (aTHX)
3604 #endif
3605     if (PL_incgv) av = GvAVn(PL_incgv);
3606
3607     for (i = 0; av && i <= AvFILL(av); i++) {
3608         dirsv = *av_fetch(av,i,TRUE);
3609
3610         if (SvROK(dirsv)) continue;
3611         dir = SvPVx(dirsv,n_a);
3612         if (strcmp(dir,".") == 0) continue;
3613         if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
3614             continue;
3615
3616         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3617         p->next = head_PLOC;
3618         head_PLOC = p;
3619         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3620         p->dir[NAM$C_MAXRSS] = '\0';
3621     }
3622
3623 /* most likely spot (ARCHLIB) put first in the list */
3624
3625 #ifdef ARCHLIB_EXP
3626     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
3627         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3628         if (p == NULL) _ckvmssts(SS$_INSFMEM);
3629         p->next = head_PLOC;
3630         head_PLOC = p;
3631         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3632         p->dir[NAM$C_MAXRSS] = '\0';
3633     }
3634 #endif
3635     PerlMem_free(unixdir);
3636 }
3637
3638 static I32
3639 Perl_cando_by_name_int
3640    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3641 #if !defined(PERL_IMPLICIT_CONTEXT)
3642 #define cando_by_name_int               Perl_cando_by_name_int
3643 #else
3644 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3645 #endif
3646
3647 static char *
3648 find_vmspipe(pTHX)
3649 {
3650     static int   vmspipe_file_status = 0;
3651     static char  vmspipe_file[NAM$C_MAXRSS+1];
3652
3653     /* already found? Check and use ... need read+execute permission */
3654
3655     if (vmspipe_file_status == 1) {
3656         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3657          && cando_by_name_int
3658            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3659             return vmspipe_file;
3660         }
3661         vmspipe_file_status = 0;
3662     }
3663
3664     /* scan through stored @INC, $^X */
3665
3666     if (vmspipe_file_status == 0) {
3667         char file[NAM$C_MAXRSS+1];
3668         pPLOC  p = head_PLOC;
3669
3670         while (p) {
3671             char * exp_res;
3672             int dirlen;
3673             strcpy(file, p->dir);
3674             dirlen = strlen(file);
3675             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3676             file[NAM$C_MAXRSS] = '\0';
3677             p = p->next;
3678
3679             exp_res = do_rmsexpand
3680                 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3681             if (!exp_res) continue;
3682
3683             if (cando_by_name_int
3684                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3685              && cando_by_name_int
3686                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3687                 vmspipe_file_status = 1;
3688                 return vmspipe_file;
3689             }
3690         }
3691         vmspipe_file_status = -1;   /* failed, use tempfiles */
3692     }
3693
3694     return 0;
3695 }
3696
3697 static FILE *
3698 vmspipe_tempfile(pTHX)
3699 {
3700     char file[NAM$C_MAXRSS+1];
3701     FILE *fp;
3702     static int index = 0;
3703     Stat_t s0, s1;
3704     int cmp_result;
3705
3706     /* create a tempfile */
3707
3708     /* we can't go from   W, shr=get to  R, shr=get without
3709        an intermediate vulnerable state, so don't bother trying...
3710
3711        and lib$spawn doesn't shr=put, so have to close the write
3712
3713        So... match up the creation date/time and the FID to
3714        make sure we're dealing with the same file
3715
3716     */
3717
3718     index++;
3719     if (!decc_filename_unix_only) {
3720       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3721       fp = fopen(file,"w");
3722       if (!fp) {
3723         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3724         fp = fopen(file,"w");
3725         if (!fp) {
3726             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3727             fp = fopen(file,"w");
3728         }
3729       }
3730      }
3731      else {
3732       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3733       fp = fopen(file,"w");
3734       if (!fp) {
3735         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3736         fp = fopen(file,"w");
3737         if (!fp) {
3738           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3739           fp = fopen(file,"w");
3740         }
3741       }
3742     }
3743     if (!fp) return 0;  /* we're hosed */
3744
3745     fprintf(fp,"$! 'f$verify(0)'\n");
3746     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3747     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3748     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3749     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3750     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3751     fprintf(fp,"$ perl_del    = \"delete\"\n");
3752     fprintf(fp,"$ pif         = \"if\"\n");
3753     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3754     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3755     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3756     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3757     fprintf(fp,"$!  --- build command line to get max possible length\n");
3758     fprintf(fp,"$c=perl_popen_cmd0\n");
3759     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3760     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3761     fprintf(fp,"$x=perl_popen_cmd3\n");
3762     fprintf(fp,"$c=c+x\n");
3763     fprintf(fp,"$ perl_on\n");
3764     fprintf(fp,"$ 'c'\n");
3765     fprintf(fp,"$ perl_status = $STATUS\n");
3766     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3767     fprintf(fp,"$ perl_exit 'perl_status'\n");
3768     fsync(fileno(fp));
3769
3770     fgetname(fp, file, 1);
3771     fstat(fileno(fp), (struct stat *)&s0);
3772     fclose(fp);
3773
3774     if (decc_filename_unix_only)
3775         do_tounixspec(file, file, 0, NULL);
3776     fp = fopen(file,"r","shr=get");
3777     if (!fp) return 0;
3778     fstat(fileno(fp), (struct stat *)&s1);
3779
3780     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3781     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3782         fclose(fp);
3783         return 0;
3784     }
3785
3786     return fp;
3787 }
3788
3789
3790 static int vms_is_syscommand_xterm(void)
3791 {
3792     const static struct dsc$descriptor_s syscommand_dsc =
3793       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3794
3795     const static struct dsc$descriptor_s decwdisplay_dsc =
3796       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3797
3798     struct item_list_3 items[2];
3799     unsigned short dvi_iosb[4];
3800     unsigned long devchar;
3801     unsigned long devclass;
3802     int status;
3803
3804     /* Very simple check to guess if sys$command is a decterm? */
3805     /* First see if the DECW$DISPLAY: device exists */
3806     items[0].len = 4;
3807     items[0].code = DVI$_DEVCHAR;
3808     items[0].bufadr = &devchar;
3809     items[0].retadr = NULL;
3810     items[1].len = 0;
3811     items[1].code = 0;
3812
3813     status = sys$getdviw
3814         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3815
3816     if ($VMS_STATUS_SUCCESS(status)) {
3817         status = dvi_iosb[0];
3818     }
3819
3820     if (!$VMS_STATUS_SUCCESS(status)) {
3821         SETERRNO(EVMSERR, status);
3822         return -1;
3823     }
3824
3825     /* If it does, then for now assume that we are on a workstation */
3826     /* Now verify that SYS$COMMAND is a terminal */
3827     /* for creating the debugger DECTerm */
3828
3829     items[0].len = 4;
3830     items[0].code = DVI$_DEVCLASS;
3831     items[0].bufadr = &devclass;
3832     items[0].retadr = NULL;
3833     items[1].len = 0;
3834     items[1].code = 0;
3835
3836     status = sys$getdviw
3837         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3838
3839     if ($VMS_STATUS_SUCCESS(status)) {
3840         status = dvi_iosb[0];
3841     }
3842
3843     if (!$VMS_STATUS_SUCCESS(status)) {
3844         SETERRNO(EVMSERR, status);
3845         return -1;
3846     }
3847     else {
3848         if (devclass == DC$_TERM) {
3849             return 0;
3850         }
3851     }
3852     return -1;
3853 }
3854
3855 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3856 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3857 {
3858     int status;
3859     int ret_stat;
3860     char * ret_char;
3861     char device_name[65];
3862     unsigned short device_name_len;
3863     struct dsc$descriptor_s customization_dsc;
3864     struct dsc$descriptor_s device_name_dsc;
3865     const char * cptr;
3866     char * tptr;
3867     char customization[200];
3868     char title[40];
3869     pInfo info = NULL;
3870     char mbx1[64];
3871     unsigned short p_chan;
3872     int n;
3873     unsigned short iosb[4];
3874     struct item_list_3 items[2];
3875     const char * cust_str =
3876         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3877     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3878                                           DSC$K_CLASS_S, mbx1};
3879
3880      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3881     /*---------------------------------------*/
3882     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
3883
3884
3885     /* Make sure that this is from the Perl debugger */
3886     ret_char = strstr(cmd," xterm ");
3887     if (ret_char == NULL)
3888         return NULL;
3889     cptr = ret_char + 7;
3890     ret_char = strstr(cmd,"tty");
3891     if (ret_char == NULL)
3892         return NULL;
3893     ret_char = strstr(cmd,"sleep");
3894     if (ret_char == NULL)
3895         return NULL;
3896
3897     if (decw_term_port == 0) {
3898         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3899         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3900         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3901
3902        status = lib$find_image_symbol
3903                                (&filename1_dsc,
3904                                 &decw_term_port_dsc,
3905                                 (void *)&decw_term_port,
3906                                 NULL,
3907                                 0);
3908
3909         /* Try again with the other image name */
3910         if (!$VMS_STATUS_SUCCESS(status)) {
3911
3912            status = lib$find_image_symbol
3913                                (&filename2_dsc,
3914                                 &decw_term_port_dsc,
3915                                 (void *)&decw_term_port,
3916                                 NULL,
3917                                 0);
3918
3919         }
3920
3921     }
3922
3923
3924     /* No decw$term_port, give it up */
3925     if (!$VMS_STATUS_SUCCESS(status))
3926         return NULL;
3927
3928     /* Are we on a workstation? */
3929     /* to do: capture the rows / columns and pass their properties */
3930     ret_stat = vms_is_syscommand_xterm();
3931     if (ret_stat < 0)
3932         return NULL;
3933
3934     /* Make the title: */
3935     ret_char = strstr(cptr,"-title");
3936     if (ret_char != NULL) {
3937         while ((*cptr != 0) && (*cptr != '\"')) {
3938             cptr++;
3939         }
3940         if (*cptr == '\"')
3941             cptr++;
3942         n = 0;
3943         while ((*cptr != 0) && (*cptr != '\"')) {
3944             title[n] = *cptr;
3945             n++;
3946             if (n == 39) {
3947                 title[39] == 0;
3948                 break;
3949             }
3950             cptr++;
3951         }
3952         title[n] = 0;
3953     }
3954     else {
3955             /* Default title */
3956             strcpy(title,"Perl Debug DECTerm");
3957     }
3958     sprintf(customization, cust_str, title);
3959
3960     customization_dsc.dsc$a_pointer = customization;
3961     customization_dsc.dsc$w_length = strlen(customization);
3962     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3963     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3964
3965     device_name_dsc.dsc$a_pointer = device_name;
3966     device_name_dsc.dsc$w_length = sizeof device_name -1;
3967     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3968     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3969
3970     device_name_len = 0;
3971
3972     /* Try to create the window */
3973      status = (*decw_term_port)
3974        (NULL,
3975         NULL,
3976         &customization_dsc,
3977         &device_name_dsc,
3978         &device_name_len,
3979         NULL,
3980         NULL,
3981         NULL);
3982     if (!$VMS_STATUS_SUCCESS(status)) {
3983         SETERRNO(EVMSERR, status);
3984         return NULL;
3985     }
3986
3987     device_name[device_name_len] = '\0';
3988
3989     /* Need to set this up to look like a pipe for cleanup */
3990     n = sizeof(Info);
3991     status = lib$get_vm(&n, &info);
3992     if (!$VMS_STATUS_SUCCESS(status)) {
3993         SETERRNO(ENOMEM, status);
3994         return NULL;
3995     }
3996
3997     info->mode = *mode;
3998     info->done = FALSE;
3999     info->completion = 0;
4000     info->closing    = FALSE;
4001     info->in         = 0;
4002     info->out        = 0;
4003     info->err        = 0;
4004     info->fp         = Nullfp;
4005     info->useFILE    = 0;
4006     info->waiting    = 0;
4007     info->in_done    = TRUE;
4008     info->out_done   = TRUE;
4009     info->err_done   = TRUE;
4010
4011     /* Assign a channel on this so that it will persist, and not login */
4012     /* We stash this channel in the info structure for reference. */
4013     /* The created xterm self destructs when the last channel is removed */
4014     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4015     /* So leave this assigned. */
4016     device_name_dsc.dsc$w_length = device_name_len;
4017     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4018     if (!$VMS_STATUS_SUCCESS(status)) {
4019         SETERRNO(EVMSERR, status);
4020         return NULL;
4021     }
4022     info->xchan_valid = 1;
4023
4024     /* Now create a mailbox to be read by the application */
4025
4026     create_mbx(aTHX_ &p_chan, &d_mbx1);
4027
4028     /* write the name of the created terminal to the mailbox */
4029     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4030             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4031
4032     if (!$VMS_STATUS_SUCCESS(status)) {
4033         SETERRNO(EVMSERR, status);
4034         return NULL;
4035     }
4036
4037     info->fp  = PerlIO_open(mbx1, mode);
4038
4039     /* Done with this channel */
4040     sys$dassgn(p_chan);
4041
4042     /* If any errors, then clean up */
4043     if (!info->fp) {
4044         n = sizeof(Info);
4045         _ckvmssts(lib$free_vm(&n, &info));
4046         return NULL;
4047         }
4048
4049     /* All done */
4050     return info->fp;
4051 }
4052
4053 static PerlIO *
4054 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4055 {
4056     static int handler_set_up = FALSE;
4057     unsigned long int sts, flags = CLI$M_NOWAIT;
4058     /* The use of a GLOBAL table (as was done previously) rendered
4059      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4060      * environment.  Hence we've switched to LOCAL symbol table.
4061      */
4062     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4063     int j, wait = 0, n;
4064     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4065     char *in, *out, *err, mbx[512];
4066     FILE *tpipe = 0;
4067     char tfilebuf[NAM$C_MAXRSS+1];
4068     pInfo info = NULL;
4069     char cmd_sym_name[20];
4070     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4071                                       DSC$K_CLASS_S, symbol};
4072     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4073                                       DSC$K_CLASS_S, 0};
4074     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4075                                       DSC$K_CLASS_S, cmd_sym_name};
4076     struct dsc$descriptor_s *vmscmd;
4077     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4078     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4079     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4080
4081     /* Check here for Xterm create request.  This means looking for
4082      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4083      *  is possible to create an xterm.
4084      */
4085     if (*in_mode == 'r') {
4086         PerlIO * xterm_fd;
4087
4088         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4089         if (xterm_fd != Nullfp)
4090             return xterm_fd;
4091     }
4092
4093     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4094
4095     /* once-per-program initialization...
4096        note that the SETAST calls and the dual test of pipe_ef
4097        makes sure that only the FIRST thread through here does
4098        the initialization...all other threads wait until it's
4099        done.
4100
4101        Yeah, uglier than a pthread call, it's got all the stuff inline
4102        rather than in a separate routine.
4103     */
4104
4105     if (!pipe_ef) {
4106         _ckvmssts(sys$setast(0));
4107         if (!pipe_ef) {
4108             unsigned long int pidcode = JPI$_PID;
4109             $DESCRIPTOR(d_delay, RETRY_DELAY);
4110             _ckvmssts(lib$get_ef(&pipe_ef));
4111             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4112             _ckvmssts(sys$bintim(&d_delay, delaytime));
4113         }
4114         if (!handler_set_up) {
4115           _ckvmssts(sys$dclexh(&pipe_exitblock));
4116           handler_set_up = TRUE;
4117         }
4118         _ckvmssts(sys$setast(1));
4119     }
4120
4121     /* see if we can find a VMSPIPE.COM */
4122
4123     tfilebuf[0] = '@';
4124     vmspipe = find_vmspipe(aTHX);
4125     if (vmspipe) {
4126         strcpy(tfilebuf+1,vmspipe);
4127     } else {        /* uh, oh...we're in tempfile hell */
4128         tpipe = vmspipe_tempfile(aTHX);
4129         if (!tpipe) {       /* a fish popular in Boston */
4130             if (ckWARN(WARN_PIPE)) {
4131                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4132             }
4133         return Nullfp;
4134         }
4135         fgetname(tpipe,tfilebuf+1,1);
4136     }
4137     vmspipedsc.dsc$a_pointer = tfilebuf;
4138     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4139
4140     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4141     if (!(sts & 1)) {
4142       switch (sts) {
4143         case RMS$_FNF:  case RMS$_DNF:
4144           set_errno(ENOENT); break;
4145         case RMS$_DIR:
4146           set_errno(ENOTDIR); break;
4147         case RMS$_DEV:
4148           set_errno(ENODEV); break;
4149         case RMS$_PRV:
4150           set_errno(EACCES); break;
4151         case RMS$_SYN:
4152           set_errno(EINVAL); break;
4153         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4154           set_errno(E2BIG); break;
4155         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4156           _ckvmssts(sts); /* fall through */
4157         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4158           set_errno(EVMSERR);
4159       }
4160       set_vaxc_errno(sts);
4161       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4162         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4163       }
4164       *psts = sts;
4165       return Nullfp;
4166     }
4167     n = sizeof(Info);
4168     _ckvmssts(lib$get_vm(&n, &info));
4169
4170     strcpy(mode,in_mode);
4171     info->mode = *mode;
4172     info->done = FALSE;
4173     info->completion = 0;
4174     info->closing    = FALSE;
4175     info->in         = 0;
4176     info->out        = 0;
4177     info->err        = 0;
4178     info->fp         = Nullfp;
4179     info->useFILE    = 0;
4180     info->waiting    = 0;
4181     info->in_done    = TRUE;
4182     info->out_done   = TRUE;
4183     info->err_done   = TRUE;
4184     info->xchan      = 0;
4185     info->xchan_valid = 0;
4186
4187     in = PerlMem_malloc(VMS_MAXRSS);
4188     if (in == NULL) _ckvmssts(SS$_INSFMEM);
4189     out = PerlMem_malloc(VMS_MAXRSS);
4190     if (out == NULL) _ckvmssts(SS$_INSFMEM);
4191     err = PerlMem_malloc(VMS_MAXRSS);
4192     if (err == NULL) _ckvmssts(SS$_INSFMEM);
4193
4194     in[0] = out[0] = err[0] = '\0';
4195
4196     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4197         info->useFILE = 1;
4198         strcpy(p,p+1);
4199     }
4200     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4201         wait = 1;
4202         strcpy(p,p+1);
4203     }
4204
4205     if (*mode == 'r') {             /* piping from subroutine */
4206
4207         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4208         if (info->out) {
4209             info->out->pipe_done = &info->out_done;
4210             info->out_done = FALSE;
4211             info->out->info = info;
4212         }
4213         if (!info->useFILE) {
4214             info->fp  = PerlIO_open(mbx, mode);
4215         } else {
4216             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4217             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4218         }
4219
4220         if (!info->fp && info->out) {
4221             sys$cancel(info->out->chan_out);
4222
4223             while (!info->out_done) {
4224                 int done;
4225                 _ckvmssts(sys$setast(0));
4226                 done = info->out_done;
4227                 if (!done) _ckvmssts(sys$clref(pipe_ef));
4228                 _ckvmssts(sys$setast(1));
4229                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4230             }
4231
4232             if (info->out->buf) {
4233                 n = info->out->bufsize * sizeof(char);
4234                 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4235             }
4236             n = sizeof(Pipe);
4237             _ckvmssts(lib$free_vm(&n, &info->out));
4238             n = sizeof(Info);
4239             _ckvmssts(lib$free_vm(&n, &info));
4240             *psts = RMS$_FNF;
4241             return Nullfp;
4242         }
4243
4244         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4245         if (info->err) {
4246             info->err->pipe_done = &info->err_done;
4247             info->err_done = FALSE;
4248             info->err->info = info;
4249         }
4250
4251     } else if (*mode == 'w') {      /* piping to subroutine */
4252
4253         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4254         if (info->out) {
4255             info->out->pipe_done = &info->out_done;
4256             info->out_done = FALSE;
4257             info->out->info = info;
4258         }
4259
4260         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4261         if (info->err) {
4262             info->err->pipe_done = &info->err_done;
4263             info->err_done = FALSE;
4264             info->err->info = info;
4265         }
4266
4267         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4268         if (!info->useFILE) {
4269             info->fp  = PerlIO_open(mbx, mode);
4270         } else {
4271             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4272             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4273         }
4274
4275         if (info->in) {
4276             info->in->pipe_done = &info->in_done;
4277             info->in_done = FALSE;
4278             info->in->info = info;
4279         }
4280
4281         /* error cleanup */
4282         if (!info->fp && info->in) {
4283             info->done = TRUE;
4284             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4285                               0, 0, 0, 0, 0, 0, 0, 0));
4286
4287             while (!info->in_done) {
4288                 int done;
4289                 _ckvmssts(sys$setast(0));
4290                 done = info->in_done;
4291                 if (!done) _ckvmssts(sys$clref(pipe_ef));
4292                 _ckvmssts(sys$setast(1));
4293                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4294             }
4295
4296             if (info->in->buf) {
4297                 n = info->in->bufsize * sizeof(char);
4298                 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4299             }
4300             n = sizeof(Pipe);
4301             _ckvmssts(lib$free_vm(&n, &info->in));
4302             n = sizeof(Info);
4303             _ckvmssts(lib$free_vm(&n, &info));
4304             *psts = RMS$_FNF;
4305             return Nullfp;
4306         }
4307
4308
4309     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4310         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4311         if (info->out) {
4312             info->out->pipe_done = &info->out_done;
4313             info->out_done = FALSE;
4314             info->out->info = info;
4315         }
4316
4317         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4318         if (info->err) {
4319             info->err->pipe_done = &info->err_done;
4320             info->err_done = FALSE;
4321             info->err->info = info;
4322         }
4323     }
4324
4325     symbol[MAX_DCL_SYMBOL] = '\0';
4326
4327     strncpy(symbol, in, MAX_DCL_SYMBOL);
4328     d_symbol.dsc$w_length = strlen(symbol);
4329     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4330
4331     strncpy(symbol, err, MAX_DCL_SYMBOL);
4332     d_symbol.dsc$w_length = strlen(symbol);
4333     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4334
4335     strncpy(symbol, out, MAX_DCL_SYMBOL);
4336     d_symbol.dsc$w_length = strlen(symbol);
4337     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4338
4339     /* Done with the names for the pipes */
4340     PerlMem_free(err);
4341     PerlMem_free(out);
4342     PerlMem_free(in);
4343
4344     p = vmscmd->dsc$a_pointer;
4345     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4346     if (*p == '$') p++;                         /* remove leading $ */
4347     while (*p == ' ' || *p == '\t') p++;
4348
4349     for (j = 0; j < 4; j++) {
4350         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4351         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4352
4353     strncpy(symbol, p, MAX_DCL_SYMBOL);
4354     d_symbol.dsc$w_length = strlen(symbol);
4355     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4356
4357         if (strlen(p) > MAX_DCL_SYMBOL) {
4358             p += MAX_DCL_SYMBOL;
4359         } else {
4360             p += strlen(p);
4361         }
4362     }
4363     _ckvmssts(sys$setast(0));
4364     info->next=open_pipes;  /* prepend to list */
4365     open_pipes=info;
4366     _ckvmssts(sys$setast(1));
4367     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4368      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4369      * have SYS$COMMAND if we need it.
4370      */
4371     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4372                       0, &info->pid, &info->completion,
4373                       0, popen_completion_ast,info,0,0,0));
4374
4375     /* if we were using a tempfile, close it now */
4376
4377     if (tpipe) fclose(tpipe);
4378
4379     /* once the subprocess is spawned, it has copied the symbols and
4380        we can get rid of ours */
4381
4382     for (j = 0; j < 4; j++) {
4383         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4384         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4385     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4386     }
4387     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
4388     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4389     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4390     vms_execfree(vmscmd);
4391
4392 #ifdef PERL_IMPLICIT_CONTEXT
4393     if (aTHX)
4394 #endif
4395     PL_forkprocess = info->pid;
4396
4397     if (wait) {
4398          int done = 0;
4399          while (!done) {
4400              _ckvmssts(sys$setast(0));
4401              done = info->done;
4402              if (!done) _ckvmssts(sys$clref(pipe_ef));
4403              _ckvmssts(sys$setast(1));
4404              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4405          }
4406         *psts = info->completion;
4407 /* Caller thinks it is open and tries to close it. */
4408 /* This causes some problems, as it changes the error status */
4409 /*        my_pclose(info->fp); */
4410     } else {
4411         *psts = info->pid;
4412     }
4413     return info->fp;
4414 }  /* end of safe_popen */
4415
4416
4417 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4418 PerlIO *
4419 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4420 {
4421     int sts;
4422     TAINT_ENV();
4423     TAINT_PROPER("popen");
4424     PERL_FLUSHALL_FOR_CHILD;
4425     return safe_popen(aTHX_ cmd,mode,&sts);
4426 }
4427
4428 /*}}}*/
4429
4430 /*{{{  I32 my_pclose(PerlIO *fp)*/
4431 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4432 {
4433     pInfo info, last = NULL;
4434     unsigned long int retsts;
4435     int done, iss, n;
4436     int status;
4437
4438     for (info = open_pipes; info != NULL; last = info, info = info->next)
4439         if (info->fp == fp) break;
4440
4441     if (info == NULL) {  /* no such pipe open */
4442       set_errno(ECHILD); /* quoth POSIX */
4443       set_vaxc_errno(SS$_NONEXPR);
4444       return -1;
4445     }
4446
4447     /* If we were writing to a subprocess, insure that someone reading from
4448      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4449      * produce an EOF record in the mailbox.
4450      *
4451      *  well, at least sometimes it *does*, so we have to watch out for
4452      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4453      */
4454      if (info->fp) {
4455         if (!info->useFILE
4456 #if defined(USE_ITHREADS)
4457           && my_perl
4458 #endif
4459           && PL_perlio_fd_refcnt)
4460             PerlIO_flush(info->fp);
4461         else
4462             fflush((FILE *)info->fp);
4463     }
4464
4465     _ckvmssts(sys$setast(0));
4466      info->closing = TRUE;
4467      done = info->done && info->in_done && info->out_done && info->err_done;
4468      /* hanging on write to Perl's input? cancel it */
4469      if (info->mode == 'r' && info->out && !info->out_done) {
4470         if (info->out->chan_out) {
4471             _ckvmssts(sys$cancel(info->out->chan_out));
4472             if (!info->out->chan_in) {   /* EOF generation, need AST */
4473                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4474             }
4475         }
4476      }
4477      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4478          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4479                            0, 0, 0, 0, 0, 0));
4480     _ckvmssts(sys$setast(1));
4481     if (info->fp) {
4482      if (!info->useFILE
4483 #if defined(USE_ITHREADS)
4484          && my_perl
4485 #endif
4486          && PL_perlio_fd_refcnt)
4487         PerlIO_close(info->fp);
4488      else
4489         fclose((FILE *)info->fp);
4490     }
4491      /*
4492         we have to wait until subprocess completes, but ALSO wait until all
4493         the i/o completes...otherwise we'll be freeing the "info" structure
4494         that the i/o ASTs could still be using...
4495      */
4496
4497      while (!done) {
4498          _ckvmssts(sys$setast(0));
4499          done = info->done && info->in_done && info->out_done && info->err_done;
4500          if (!done) _ckvmssts(sys$clref(pipe_ef));
4501          _ckvmssts(sys$setast(1));
4502          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4503      }
4504      retsts = info->completion;
4505
4506     /* remove from list of open pipes */
4507     _ckvmssts(sys$setast(0));
4508     if (last) last->next = info->next;
4509     else open_pipes = info->next;
4510     _ckvmssts(sys$setast(1));
4511
4512     /* free buffers and structures */
4513
4514     if (info->in) {
4515         if (info->in->buf) {
4516             n = info->in->bufsize * sizeof(char);
4517             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4518         }
4519         n = sizeof(Pipe);
4520         _ckvmssts(lib$free_vm(&n, &info->in));
4521     }
4522     if (info->out) {
4523         if (info->out->buf) {
4524             n = info->out->bufsize * sizeof(char);
4525             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4526         }
4527         n = sizeof(Pipe);
4528         _ckvmssts(lib$free_vm(&n, &info->out));
4529     }
4530     if (info->err) {
4531         if (info->err->buf) {
4532             n = info->err->bufsize * sizeof(char);
4533             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4534         }
4535         n = sizeof(Pipe);
4536         _ckvmssts(lib$free_vm(&n, &info->err));
4537     }
4538     n = sizeof(Info);
4539     _ckvmssts(lib$free_vm(&n, &info));
4540
4541     return retsts;
4542
4543 }  /* end of my_pclose() */
4544
4545 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4546   /* Roll our own prototype because we want this regardless of whether
4547    * _VMS_WAIT is defined.
4548    */
4549   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4550 #endif
4551 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4552    created with popen(); otherwise partially emulate waitpid() unless
4553    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4554    Also check processes not considered by the CRTL waitpid().
4555  */
4556 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4557 Pid_t
4558 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4559 {
4560     pInfo info;
4561     int done;
4562     int sts;
4563     int j;
4564
4565     if (statusp) *statusp = 0;
4566
4567     for (info = open_pipes; info != NULL; info = info->next)
4568         if (info->pid == pid) break;
4569
4570     if (info != NULL) {  /* we know about this child */
4571       while (!info->done) {
4572           _ckvmssts(sys$setast(0));
4573           done = info->done;
4574           if (!done) _ckvmssts(sys$clref(pipe_ef));
4575           _ckvmssts(sys$setast(1));
4576           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4577       }
4578
4579       if (statusp) *statusp = info->completion;
4580       return pid;
4581     }
4582
4583     /* child that already terminated? */
4584
4585     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4586         if (closed_list[j].pid == pid) {
4587             if (statusp) *statusp = closed_list[j].completion;
4588             return pid;
4589         }
4590     }
4591
4592     /* fall through if this child is not one of our own pipe children */
4593
4594 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4595
4596       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4597        * in 7.2 did we get a version that fills in the VMS completion
4598        * status as Perl has always tried to do.
4599        */
4600
4601       sts = __vms_waitpid( pid, statusp, flags );
4602
4603       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4604          return sts;
4605
4606       /* If the real waitpid tells us the child does not exist, we
4607        * fall through here to implement waiting for a child that
4608        * was created by some means other than exec() (say, spawned
4609        * from DCL) or to wait for a process that is not a subprocess
4610        * of the current process.
4611        */
4612
4613 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4614
4615     {
4616       $DESCRIPTOR(intdsc,"0 00:00:01");
4617       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4618       unsigned long int pidcode = JPI$_PID, mypid;
4619       unsigned long int interval[2];
4620       unsigned int jpi_iosb[2];
4621       struct itmlst_3 jpilist[2] = {
4622           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4623           {                      0,         0,                 0, 0}
4624       };
4625
4626       if (pid <= 0) {
4627         /* Sorry folks, we don't presently implement rooting around for
4628            the first child we can find, and we definitely don't want to
4629            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4630          */
4631         set_errno(ENOTSUP);
4632         return -1;
4633       }
4634
4635       /* Get the owner of the child so I can warn if it's not mine. If the
4636        * process doesn't exist or I don't have the privs to look at it,
4637        * I can go home early.
4638        */
4639       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4640       if (sts & 1) sts = jpi_iosb[0];
4641       if (!(sts & 1)) {
4642         switch (sts) {
4643             case SS$_NONEXPR:
4644                 set_errno(ECHILD);
4645                 break;
4646             case SS$_NOPRIV:
4647                 set_errno(EACCES);
4648                 break;
4649             default:
4650                 _ckvmssts(sts);
4651         }
4652         set_vaxc_errno(sts);
4653         return -1;
4654       }
4655
4656       if (ckWARN(WARN_EXEC)) {
4657         /* remind folks they are asking for non-standard waitpid behavior */
4658         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4659         if (ownerpid != mypid)
4660           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4661                       "waitpid: process %x is not a child of process %x",
4662                       pid,mypid);
4663       }
4664
4665       /* simply check on it once a second until it's not there anymore. */
4666
4667       _ckvmssts(sys$bintim(&intdsc,interval));
4668       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4669             _ckvmssts(sys$schdwk(0,0,interval,0));
4670             _ckvmssts(sys$hiber());
4671       }
4672       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4673
4674       _ckvmssts(sts);
4675       return pid;
4676     }
4677 }  /* end of waitpid() */
4678 /*}}}*/
4679 /*}}}*/
4680 /*}}}*/
4681
4682 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4683 char *
4684 my_gconvert(double val, int ndig, int trail, char *buf)
4685 {
4686   static char __gcvtbuf[DBL_DIG+1];
4687   char *loc;
4688
4689   loc = buf ? buf : __gcvtbuf;
4690
4691 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4692   if (val < 1) {
4693     sprintf(loc,"%.*g",ndig,val);
4694     return loc;
4695   }
4696 #endif
4697
4698   if (val) {
4699     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4700     return gcvt(val,ndig,loc);
4701   }
4702   else {
4703     loc[0] = '0'; loc[1] = '\0';
4704     return loc;
4705   }
4706
4707 }
4708 /*}}}*/
4709
4710 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4711 static int rms_free_search_context(struct FAB * fab)
4712 {
4713 struct NAM * nam;
4714
4715     nam = fab->fab$l_nam;
4716     nam->nam$b_nop |= NAM$M_SYNCHK;
4717     nam->nam$l_rlf = NULL;
4718     fab->fab$b_dns = 0;
4719     return sys$parse(fab, NULL, NULL);
4720 }
4721
4722 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4723 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4724 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4725 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4726 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4727 #define rms_nam_esll(nam) nam.nam$b_esl
4728 #define rms_nam_esl(nam) nam.nam$b_esl
4729 #define rms_nam_name(nam) nam.nam$l_name
4730 #define rms_nam_namel(nam) nam.nam$l_name
4731 #define rms_nam_type(nam) nam.nam$l_type
4732 #define rms_nam_typel(nam) nam.nam$l_type
4733 #define rms_nam_ver(nam) nam.nam$l_ver
4734 #define rms_nam_verl(nam) nam.nam$l_ver
4735 #define rms_nam_rsll(nam) nam.nam$b_rsl
4736 #define rms_nam_rsl(nam) nam.nam$b_rsl
4737 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4738 #define rms_set_fna(fab, nam, name, size) \
4739         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4740 #define rms_get_fna(fab, nam) fab.fab$l_fna
4741 #define rms_set_dna(fab, nam, name, size) \
4742         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4743 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4744 #define rms_set_esa(nam, name, size) \
4745         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4746 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4747         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4748 #define rms_set_rsa(nam, name, size) \
4749         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4750 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4751         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4752 #define rms_nam_name_type_l_size(nam) \
4753         (nam.nam$b_name + nam.nam$b_type)
4754 #else
4755 static int rms_free_search_context(struct FAB * fab)
4756 {
4757 struct NAML * nam;
4758
4759     nam = fab->fab$l_naml;
4760     nam->naml$b_nop |= NAM$M_SYNCHK;
4761     nam->naml$l_rlf = NULL;
4762     nam->naml$l_long_defname_size = 0;
4763
4764     fab->fab$b_dns = 0;
4765     return sys$parse(fab, NULL, NULL);
4766 }
4767
4768 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4769 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4770 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4771 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4772 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4773 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4774 #define rms_nam_esl(nam) nam.naml$b_esl
4775 #define rms_nam_name(nam) nam.naml$l_name
4776 #define rms_nam_namel(nam) nam.naml$l_long_name
4777 #define rms_nam_type(nam) nam.naml$l_type
4778 #define rms_nam_typel(nam) nam.naml$l_long_type
4779 #define rms_nam_ver(nam) nam.naml$l_ver
4780 #define rms_nam_verl(nam) nam.naml$l_long_ver
4781 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4782 #define rms_nam_rsl(nam) nam.naml$b_rsl
4783 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4784 #define rms_set_fna(fab, nam, name, size) \
4785         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4786         nam.naml$l_long_filename_size = size; \
4787         nam.naml$l_long_filename = name;}
4788 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4789 #define rms_set_dna(fab, nam, name, size) \
4790         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4791         nam.naml$l_long_defname_size = size; \
4792         nam.naml$l_long_defname = name; }
4793 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4794 #define rms_set_esa(nam, name, size) \
4795         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4796         nam.naml$l_long_expand_alloc = size; \
4797         nam.naml$l_long_expand = name; }
4798 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4799         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4800         nam.naml$l_long_expand = l_name; \
4801         nam.naml$l_long_expand_alloc = l_size; }
4802 #define rms_set_rsa(nam, name, size) \
4803         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4804         nam.naml$l_long_result = name; \
4805         nam.naml$l_long_result_alloc = size; }
4806 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4807         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4808         nam.naml$l_long_result = l_name; \
4809         nam.naml$l_long_result_alloc = l_size; }
4810 #define rms_nam_name_type_l_size(nam) \
4811         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4812 #endif
4813
4814
4815 /* rms_erase
4816  * The CRTL for 8.3 and later can create symbolic links in any mode,
4817  * however in 8.3 the unlink/remove/delete routines will only properly handle
4818  * them if one of the PCP modes is active.
4819  */
4820 static int rms_erase(const char * vmsname)
4821 {
4822   int status;
4823   struct FAB myfab = cc$rms_fab;
4824   rms_setup_nam(mynam);
4825
4826   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4827   rms_bind_fab_nam(myfab, mynam);
4828
4829   /* Are we removing all versions? */
4830   if (vms_unlink_all_versions == 1) {
4831     const char * defspec = ";*";
4832     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4833   }
4834
4835 #ifdef NAML$M_OPEN_SPECIAL
4836   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4837 #endif
4838
4839   status = sys$erase(&myfab, 0, 0);
4840
4841   return status;
4842 }
4843
4844
4845 static int
4846 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4847                     const struct dsc$descriptor_s * vms_dst_dsc,
4848                     unsigned long flags)
4849 {
4850     /*  VMS and UNIX handle file permissions differently and the
4851      * the same ACL trick may be needed for renaming files,
4852      * especially if they are directories.
4853      */
4854
4855    /* todo: get kill_file and rename to share common code */
4856    /* I can not find online documentation for $change_acl
4857     * it appears to be replaced by $set_security some time ago */
4858
4859 const unsigned int access_mode = 0;
4860 $DESCRIPTOR(obj_file_dsc,"FILE");
4861 char *vmsname;
4862 char *rslt;
4863 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
4864 int aclsts, fndsts, rnsts = -1;
4865 unsigned int ctx = 0;
4866 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4867 struct dsc$descriptor_s * clean_dsc;
4868
4869 struct myacedef {
4870     unsigned char myace$b_length;
4871     unsigned char myace$b_type;
4872     unsigned short int myace$w_flags;
4873     unsigned long int myace$l_access;
4874     unsigned long int myace$l_ident;
4875 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
4876              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
4877              0},
4878              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
4879
4880 struct item_list_3
4881         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
4882                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
4883                       {0,0,0,0}},
4884         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
4885         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
4886                      {0,0,0,0}};
4887
4888
4889     /* Expand the input spec using RMS, since we do not want to put
4890      * ACLs on the target of a symbolic link */
4891     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
4892     if (vmsname == NULL)
4893         return SS$_INSFMEM;
4894
4895     rslt = do_rmsexpand(vms_src_dsc->dsc$a_pointer,
4896                         vmsname,
4897                         0,
4898                         NULL,
4899                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
4900                         NULL,
4901                         NULL);
4902     if (rslt == NULL) {
4903         PerlMem_free(vmsname);
4904         return SS$_INSFMEM;
4905     }
4906
4907     /* So we get our own UIC to use as a rights identifier,
4908      * and the insert an ACE at the head of the ACL which allows us
4909      * to delete the file.
4910      */
4911     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
4912
4913     fildsc.dsc$w_length = strlen(vmsname);
4914     fildsc.dsc$a_pointer = vmsname;
4915     ctx = 0;
4916     newace.myace$l_ident = oldace.myace$l_ident;
4917     rnsts = SS$_ABORT;
4918
4919     /* Grab any existing ACEs with this identifier in case we fail */
4920     clean_dsc = &fildsc;
4921     aclsts = fndsts = sys$get_security(&obj_file_dsc,
4922                                &fildsc,
4923                                NULL,
4924                                OSS$M_WLOCK,
4925                                findlst,
4926                                &ctx,
4927                                &access_mode);
4928
4929     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
4930         /* Add the new ACE . . . */
4931
4932         /* if the sys$get_security succeeded, then ctx is valid, and the
4933          * object/file descriptors will be ignored.  But otherwise they
4934          * are needed
4935          */
4936         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
4937                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
4938         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4939             set_errno(EVMSERR);
4940             set_vaxc_errno(aclsts);
4941             PerlMem_free(vmsname);
4942             return aclsts;
4943         }
4944
4945         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
4946                                 NULL, NULL,
4947                                 &flags,
4948                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
4949
4950         if ($VMS_STATUS_SUCCESS(rnsts)) {
4951             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
4952         }
4953
4954         /* Put things back the way they were. */
4955         ctx = 0;
4956         aclsts = sys$get_security(&obj_file_dsc,
4957                                   clean_dsc,
4958                                   NULL,
4959                                   OSS$M_WLOCK,
4960                                   findlst,
4961                                   &ctx,
4962                                   &access_mode);
4963
4964         if ($VMS_STATUS_SUCCESS(aclsts)) {
4965         int sec_flags;
4966
4967             sec_flags = 0;
4968             if (!$VMS_STATUS_SUCCESS(fndsts))
4969                 sec_flags = OSS$M_RELCTX;
4970
4971             /* Get rid of the new ACE */
4972             aclsts = sys$set_security(NULL, NULL, NULL,
4973                                   sec_flags, dellst, &ctx, &access_mode);
4974
4975             /* If there was an old ACE, put it back */
4976             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
4977                 addlst[0].bufadr = &oldace;
4978                 aclsts = sys$set_security(NULL, NULL, NULL,
4979                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
4980                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4981                     set_errno(EVMSERR);
4982                     set_vaxc_errno(aclsts);
4983                     rnsts = aclsts;
4984                 }
4985             } else {
4986             int aclsts2;
4987
4988                 /* Try to clear the lock on the ACL list */
4989                 aclsts2 = sys$set_security(NULL, NULL, NULL,
4990                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
4991
4992                 /* Rename errors are most important */
4993                 if (!$VMS_STATUS_SUCCESS(rnsts))
4994                     aclsts = rnsts;
4995                 set_errno(EVMSERR);
4996                 set_vaxc_errno(aclsts);
4997                 rnsts = aclsts;
4998             }
4999         }
5000         else {
5001             if (aclsts != SS$_ACLEMPTY)
5002                 rnsts = aclsts;
5003         }
5004     }
5005     else
5006         rnsts = fndsts;
5007
5008     PerlMem_free(vmsname);
5009     return rnsts;
5010 }
5011
5012
5013 /*{{{int rename(const char *, const char * */
5014 /* Not exactly what X/Open says to do, but doing it absolutely right
5015  * and efficiently would require a lot more work.  This should be close
5016  * enough to pass all but the most strict X/Open compliance test.
5017  */
5018 int
5019 Perl_rename(pTHX_ const char *src, const char * dst)
5020 {
5021 int retval;
5022 int pre_delete = 0;
5023 int src_sts;
5024 int dst_sts;
5025 Stat_t src_st;
5026 Stat_t dst_st;
5027
5028     /* Validate the source file */
5029     src_sts = flex_lstat(src, &src_st);
5030     if (src_sts != 0) {
5031
5032         /* No source file or other problem */
5033         return src_sts;
5034     }
5035
5036     dst_sts = flex_lstat(dst, &dst_st);
5037     if (dst_sts == 0) {
5038
5039         if (dst_st.st_dev != src_st.st_dev) {
5040             /* Must be on the same device */
5041             errno = EXDEV;
5042             return -1;
5043         }
5044
5045         /* VMS_INO_T_COMPARE is true if the inodes are different
5046          * to match the output of memcmp
5047          */
5048
5049         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5050             /* That was easy, the files are the same! */
5051             return 0;
5052         }
5053
5054         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5055             /* If source is a directory, so must be dest */
5056                 errno = EISDIR;
5057                 return -1;
5058         }
5059
5060     }
5061
5062
5063     if ((dst_sts == 0) &&
5064         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5065
5066         /* We have issues here if vms_unlink_all_versions is set
5067          * If the destination exists, and is not a directory, then
5068          * we must delete in advance.
5069          *
5070          * If the src is a directory, then we must always pre-delete
5071          * the destination.
5072          *
5073          * If we successfully delete the dst in advance, and the rename fails
5074          * X/Open requires that errno be EIO.
5075          *
5076          */
5077
5078         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5079             int d_sts;
5080             d_sts = mp_do_kill_file(aTHX_ dst, S_ISDIR(dst_st.st_mode));
5081             if (d_sts != 0)
5082                 return d_sts;
5083
5084             /* We killed the destination, so only errno now is EIO */
5085             pre_delete = 1;
5086         }
5087     }
5088
5089     /* Originally the idea was to call the CRTL rename() and only
5090      * try the lib$rename_file if it failed.
5091      * It turns out that there are too many variants in what the
5092      * the CRTL rename might do, so only use lib$rename_file
5093      */
5094     retval = -1;
5095
5096     {
5097         /* Is the source and dest both in VMS format */
5098         /* if the source is a directory, then need to fileify */
5099         /*  and dest must be a directory or non-existant. */
5100
5101         char * vms_src;
5102         char * vms_dst;
5103         int sts;
5104         char * ret_str;
5105         unsigned long flags;
5106         struct dsc$descriptor_s old_file_dsc;
5107         struct dsc$descriptor_s new_file_dsc;
5108
5109         /* We need to modify the src and dst depending
5110          * on if one or more of them are directories.
5111          */
5112
5113         vms_src = PerlMem_malloc(VMS_MAXRSS);
5114         if (vms_src == NULL)
5115             _ckvmssts(SS$_INSFMEM);
5116
5117         /* Source is always a VMS format file */
5118         ret_str = do_tovmsspec(src, vms_src, 0, NULL);
5119         if (ret_str == NULL) {
5120             PerlMem_free(vms_src);
5121             errno = EIO;
5122             return -1;
5123         }
5124
5125         vms_dst = PerlMem_malloc(VMS_MAXRSS);
5126         if (vms_dst == NULL)
5127             _ckvmssts(SS$_INSFMEM);
5128
5129         if (S_ISDIR(src_st.st_mode)) {
5130         char * ret_str;
5131         char * vms_dir_file;
5132
5133             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5134             if (vms_dir_file == NULL)
5135                 _ckvmssts(SS$_INSFMEM);
5136
5137             /* The source must be a file specification */
5138             ret_str = do_fileify_dirspec(vms_src, vms_dir_file, 0, NULL);
5139             if (ret_str == NULL) {
5140                 PerlMem_free(vms_src);
5141                 PerlMem_free(vms_dst);
5142                 PerlMem_free(vms_dir_file);
5143                 errno = EIO;
5144                 return -1;
5145             }
5146             PerlMem_free(vms_src);
5147             vms_src = vms_dir_file;
5148
5149             /* If the dest is a directory, we must remove it
5150             if (dst_sts == 0) {
5151                 int d_sts;
5152                 d_sts = mp_do_kill_file(aTHX_ dst, 1);
5153                 if (d_sts != 0) {
5154                     PerlMem_free(vms_src);
5155                     PerlMem_free(vms_dst);
5156                     errno = EIO;
5157                     return sts;
5158                 }
5159
5160                 pre_delete = 1;
5161             }
5162
5163            /* The dest must be a VMS file specification */
5164            ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
5165            if (ret_str == NULL) {
5166                 PerlMem_free(vms_src);
5167                 PerlMem_free(vms_dst);
5168                 errno = EIO;
5169                 return -1;
5170            }
5171
5172             /* The source must be a file specification */
5173             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5174             if (vms_dir_file == NULL)
5175                 _ckvmssts(SS$_INSFMEM);
5176
5177             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5178             if (ret_str == NULL) {
5179                 PerlMem_free(vms_src);
5180                 PerlMem_free(vms_dst);
5181                 PerlMem_free(vms_dir_file);
5182                 errno = EIO;
5183                 return -1;
5184             }
5185             PerlMem_free(vms_dst);
5186             vms_dst = vms_dir_file;
5187
5188         } else {
5189             /* File to file or file to new dir */
5190
5191             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5192                 /* VMS pathify a dir target */
5193                 ret_str = do_tovmspath(dst, vms_dst, 0, NULL);
5194                 if (ret_str == NULL) {
5195                     PerlMem_free(vms_src);
5196                     PerlMem_free(vms_dst);
5197                     errno = EIO;
5198                     return -1;
5199                 }
5200             } else {
5201
5202                 /* fileify a target VMS file specification */
5203                 ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
5204                 if (ret_str == NULL) {
5205                     PerlMem_free(vms_src);
5206                     PerlMem_free(vms_dst);
5207                     errno = EIO;
5208                     return -1;
5209                 }
5210             }
5211         }
5212
5213         old_file_dsc.dsc$a_pointer = vms_src;
5214         old_file_dsc.dsc$w_length = strlen(vms_src);
5215         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5216         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5217
5218         new_file_dsc.dsc$a_pointer = vms_dst;
5219         new_file_dsc.dsc$w_length = strlen(vms_dst);
5220         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5221         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5222
5223         flags = 0;
5224 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5225         flags |= 2; /* LIB$M_FIL_LONG_NAMES */
5226 #endif
5227
5228         sts = lib$rename_file(&old_file_dsc,
5229                               &new_file_dsc,
5230                               NULL, NULL,
5231                               &flags,
5232                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5233         if (!$VMS_STATUS_SUCCESS(sts)) {
5234
5235            /* We could have failed because VMS style permissions do not
5236             * permit renames that UNIX will allow.  Just like the hack
5237             * in for kill_file.
5238             */
5239            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5240         }
5241
5242         PerlMem_free(vms_src);
5243         PerlMem_free(vms_dst);
5244         if (!$VMS_STATUS_SUCCESS(sts)) {
5245             errno = EIO;
5246             return -1;
5247         }
5248         retval = 0;
5249     }
5250
5251     if (vms_unlink_all_versions) {
5252         /* Now get rid of any previous versions of the source file that
5253          * might still exist
5254          */
5255         int save_errno;
5256         save_errno = errno;
5257         src_sts = mp_do_kill_file(aTHX_ src, S_ISDIR(src_st.st_mode));
5258         errno = save_errno;
5259     }
5260
5261     /* We deleted the destination, so must force the error to be EIO */
5262     if ((retval != 0) && (pre_delete != 0))
5263         errno = EIO;
5264
5265     return retval;
5266 }
5267 /*}}}*/
5268
5269
5270 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5271 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5272  * to expand file specification.  Allows for a single default file
5273  * specification and a simple mask of options.  If outbuf is non-NULL,
5274  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5275  * the resultant file specification is placed.  If outbuf is NULL, the
5276  * resultant file specification is placed into a static buffer.
5277  * The third argument, if non-NULL, is taken to be a default file
5278  * specification string.  The fourth argument is unused at present.
5279  * rmesexpand() returns the address of the resultant string if
5280  * successful, and NULL on error.
5281  *
5282  * New functionality for previously unused opts value:
5283  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5284  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5285  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5286  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5287  */
5288 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5289
5290 static char *
5291 mp_do_rmsexpand
5292    (pTHX_ const char *filespec,
5293     char *outbuf,
5294     int ts,
5295     const char *defspec,
5296     unsigned opts,
5297     int * fs_utf8,
5298     int * dfs_utf8)
5299 {
5300   static char __rmsexpand_retbuf[VMS_MAXRSS];
5301   char * vmsfspec, *tmpfspec;
5302   char * esa, *cp, *out = NULL;
5303   char * tbuf;
5304   char * esal = NULL;
5305   char * outbufl;
5306   struct FAB myfab = cc$rms_fab;
5307   rms_setup_nam(mynam);
5308   STRLEN speclen;
5309   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5310   int sts;
5311
5312   /* temp hack until UTF8 is actually implemented */
5313   if (fs_utf8 != NULL)
5314     *fs_utf8 = 0;
5315
5316   if (!filespec || !*filespec) {
5317     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5318     return NULL;
5319   }
5320   if (!outbuf) {
5321     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
5322     else    outbuf = __rmsexpand_retbuf;
5323   }
5324
5325   vmsfspec = NULL;
5326   tmpfspec = NULL;
5327   outbufl = NULL;
5328
5329   isunix = 0;
5330   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5331     isunix = is_unix_filespec(filespec);
5332     if (isunix) {
5333       vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5334       if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
5335       if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
5336         PerlMem_free(vmsfspec);
5337         if (out)
5338            Safefree(out);
5339         return NULL;
5340       }
5341       filespec = vmsfspec;
5342
5343       /* Unless we are forcing to VMS format, a UNIX input means
5344        * UNIX output, and that requires long names to be used
5345        */
5346       if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5347         opts |= PERL_RMSEXPAND_M_LONG;
5348       else {
5349         isunix = 0;
5350       }
5351     }
5352   }
5353
5354   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
5355   rms_bind_fab_nam(myfab, mynam);
5356
5357   if (defspec && *defspec) {
5358     int t_isunix;
5359     t_isunix = is_unix_filespec(defspec);
5360     if (t_isunix) {
5361       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5362       if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5363       if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
5364         PerlMem_free(tmpfspec);
5365         if (vmsfspec != NULL)
5366             PerlMem_free(vmsfspec);
5367         if (out)
5368            Safefree(out);
5369         return NULL;
5370       }
5371       defspec = tmpfspec;
5372     }
5373     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
5374   }
5375
5376   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5377   if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5378 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5379   esal = PerlMem_malloc(VMS_MAXRSS);
5380   if (esal == NULL) _ckvmssts(SS$_INSFMEM);
5381 #endif
5382   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5383
5384   /* If a NAML block is used RMS always writes to the long and short
5385    * addresses unless you suppress the short name.
5386    */
5387 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5388   outbufl = PerlMem_malloc(VMS_MAXRSS);
5389   if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
5390 #endif
5391    rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5392
5393 #ifdef NAM$M_NO_SHORT_UPCASE
5394   if (decc_efs_case_preserve)
5395     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5396 #endif
5397
5398    /* We may not want to follow symbolic links */
5399 #ifdef NAML$M_OPEN_SPECIAL
5400   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5401     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5402 #endif
5403
5404   /* First attempt to parse as an existing file */
5405   retsts = sys$parse(&myfab,0,0);
5406   if (!(retsts & STS$K_SUCCESS)) {
5407
5408     /* Could not find the file, try as syntax only if error is not fatal */
5409     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5410     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
5411       retsts = sys$parse(&myfab,0,0);
5412       if (retsts & STS$K_SUCCESS) goto expanded;
5413     }
5414
5415      /* Still could not parse the file specification */
5416     /*----------------------------------------------*/
5417     sts = rms_free_search_context(&myfab); /* Free search context */
5418     if (out) Safefree(out);
5419     if (tmpfspec != NULL)
5420         PerlMem_free(tmpfspec);
5421     if (vmsfspec != NULL)
5422         PerlMem_free(vmsfspec);
5423     if (outbufl != NULL)
5424         PerlMem_free(outbufl);
5425     PerlMem_free(esa);
5426     if (esal != NULL)
5427         PerlMem_free(esal);
5428     set_vaxc_errno(retsts);
5429     if      (retsts == RMS$_PRV) set_errno(EACCES);
5430     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5431     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5432     else                         set_errno(EVMSERR);
5433     return NULL;
5434   }
5435   retsts = sys$search(&myfab,0,0);
5436   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5437     sts = rms_free_search_context(&myfab); /* Free search context */
5438     if (out) Safefree(out);
5439     if (tmpfspec != NULL)
5440         PerlMem_free(tmpfspec);
5441     if (vmsfspec != NULL)
5442         PerlMem_free(vmsfspec);
5443     if (outbufl != NULL)
5444         PerlMem_free(outbufl);
5445     PerlMem_free(esa);
5446     if (esal != NULL)
5447         PerlMem_free(esal);
5448     set_vaxc_errno(retsts);
5449     if      (retsts == RMS$_PRV) set_errno(EACCES);
5450     else                         set_errno(EVMSERR);
5451     return NULL;
5452   }
5453
5454   /* If the input filespec contained any lowercase characters,
5455    * downcase the result for compatibility with Unix-minded code. */
5456   expanded:
5457   if (!decc_efs_case_preserve) {
5458     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5459       if (islower(*tbuf)) { haslower = 1; break; }
5460   }
5461
5462    /* Is a long or a short name expected */
5463   /*------------------------------------*/
5464   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5465     if (rms_nam_rsll(mynam)) {
5466         tbuf = outbufl;
5467         speclen = rms_nam_rsll(mynam);
5468     }
5469     else {
5470         tbuf = esal; /* Not esa */
5471         speclen = rms_nam_esll(mynam);
5472     }
5473   }
5474   else {
5475     if (rms_nam_rsl(mynam)) {
5476         tbuf = outbuf;
5477         speclen = rms_nam_rsl(mynam);
5478     }
5479     else {
5480         tbuf = esa; /* Not esal */
5481         speclen = rms_nam_esl(mynam);
5482     }
5483   }
5484   tbuf[speclen] = '\0';
5485
5486   /* Trim off null fields added by $PARSE
5487    * If type > 1 char, must have been specified in original or default spec
5488    * (not true for version; $SEARCH may have added version of existing file).
5489    */
5490   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5491   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5492     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5493              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5494   }
5495   else {
5496     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5497              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5498   }
5499   if (trimver || trimtype) {
5500     if (defspec && *defspec) {
5501       char *defesal = NULL;
5502       char *defesa = NULL;
5503       defesa = PerlMem_malloc(VMS_MAXRSS + 1);
5504       if (defesa != NULL) {
5505 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5506         defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5507         if (defesal == NULL) _ckvmssts(SS$_INSFMEM);
5508 #endif
5509         struct FAB deffab = cc$rms_fab;
5510         rms_setup_nam(defnam);
5511
5512         rms_bind_fab_nam(deffab, defnam);
5513
5514         /* Cast ok */
5515         rms_set_fna
5516             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5517
5518         /* RMS needs the esa/esal as a work area if wildcards are involved */
5519         rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5520
5521         rms_clear_nam_nop(defnam);
5522         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5523 #ifdef NAM$M_NO_SHORT_UPCASE
5524         if (decc_efs_case_preserve)
5525           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5526 #endif
5527 #ifdef NAML$M_OPEN_SPECIAL
5528         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5529           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5530 #endif
5531         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5532           if (trimver) {
5533              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5534           }
5535           if (trimtype) {
5536             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5537           }
5538         }
5539         if (defesal != NULL)
5540             PerlMem_free(defesal);
5541         PerlMem_free(defesa);
5542       }
5543     }
5544     if (trimver) {
5545       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5546         if (*(rms_nam_verl(mynam)) != '\"')
5547           speclen = rms_nam_verl(mynam) - tbuf;
5548       }
5549       else {
5550         if (*(rms_nam_ver(mynam)) != '\"')
5551           speclen = rms_nam_ver(mynam) - tbuf;
5552       }
5553     }
5554     if (trimtype) {
5555       /* If we didn't already trim version, copy down */
5556       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5557         if (speclen > rms_nam_verl(mynam) - tbuf)
5558           memmove
5559            (rms_nam_typel(mynam),
5560             rms_nam_verl(mynam),
5561             speclen - (rms_nam_verl(mynam) - tbuf));
5562           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5563       }
5564       else {
5565         if (speclen > rms_nam_ver(mynam) - tbuf)
5566           memmove
5567            (rms_nam_type(mynam),
5568             rms_nam_ver(mynam),
5569             speclen - (rms_nam_ver(mynam) - tbuf));
5570           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5571       }
5572     }
5573   }
5574
5575    /* Done with these copies of the input files */
5576   /*-------------------------------------------*/
5577   if (vmsfspec != NULL)
5578         PerlMem_free(vmsfspec);
5579   if (tmpfspec != NULL)
5580         PerlMem_free(tmpfspec);
5581
5582   /* If we just had a directory spec on input, $PARSE "helpfully"
5583    * adds an empty name and type for us */
5584 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5585   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5586     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5587         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5588         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5589       speclen = rms_nam_namel(mynam) - tbuf;
5590   }
5591   else
5592 #endif
5593   {
5594     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5595         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5596         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5597       speclen = rms_nam_name(mynam) - tbuf;
5598   }
5599
5600   /* Posix format specifications must have matching quotes */
5601   if (speclen < (VMS_MAXRSS - 1)) {
5602     if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
5603       if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
5604         tbuf[speclen] = '\"';
5605         speclen++;
5606       }
5607     }
5608   }
5609   tbuf[speclen] = '\0';
5610   if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
5611
5612   /* Have we been working with an expanded, but not resultant, spec? */
5613   /* Also, convert back to Unix syntax if necessary. */
5614   {
5615   int rsl;
5616
5617 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5618     if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5619       rsl = rms_nam_rsll(mynam);
5620     } else
5621 #endif
5622     {
5623       rsl = rms_nam_rsl(mynam);
5624     }
5625     if (!rsl) {
5626       if (isunix) {
5627         if (do_tounixspec(tbuf, outbuf ,0 , fs_utf8) == NULL) {
5628           if (out) Safefree(out);
5629           if (esal != NULL)
5630             PerlMem_free(esal);
5631           PerlMem_free(esa);
5632           if (outbufl != NULL)
5633             PerlMem_free(outbufl);
5634           return NULL;
5635         }
5636       }
5637       else strcpy(outbuf, tbuf);
5638     }
5639     else if (isunix) {
5640       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5641       if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5642       if (do_tounixspec(tbuf,tmpfspec,0,fs_utf8) == NULL) {
5643         if (out) Safefree(out);
5644         PerlMem_free(esa);
5645         if (esal != NULL)
5646             PerlMem_free(esal);
5647         PerlMem_free(tmpfspec);
5648         if (outbufl != NULL)
5649             PerlMem_free(outbufl);
5650         return NULL;
5651       }
5652       strcpy(outbuf,tmpfspec);
5653       PerlMem_free(tmpfspec);
5654     }
5655   }
5656   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5657   sts = rms_free_search_context(&myfab); /* Free search context */
5658   PerlMem_free(esa);
5659   if (esal != NULL)
5660      PerlMem_free(esal);
5661   if (outbufl != NULL)
5662      PerlMem_free(outbufl);
5663   return outbuf;
5664 }
5665 /*}}}*/
5666 /* External entry points */
5667 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5668 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5669 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5670 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5671 char *Perl_rmsexpand_utf8
5672   (pTHX_ const char *spec, char *buf, const char *def,
5673    unsigned opt, int * fs_utf8, int * dfs_utf8)
5674 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5675 char *Perl_rmsexpand_utf8_ts
5676   (pTHX_ const char *spec, char *buf, const char *def,
5677    unsigned opt, int * fs_utf8, int * dfs_utf8)
5678 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5679
5680
5681 /*
5682 ** The following routines are provided to make life easier when
5683 ** converting among VMS-style and Unix-style directory specifications.
5684 ** All will take input specifications in either VMS or Unix syntax. On
5685 ** failure, all return NULL.  If successful, the routines listed below
5686 ** return a pointer to a buffer containing the appropriately
5687 ** reformatted spec (and, therefore, subsequent calls to that routine
5688 ** will clobber the result), while the routines of the same names with
5689 ** a _ts suffix appended will return a pointer to a mallocd string
5690 ** containing the appropriately reformatted spec.
5691 ** In all cases, only explicit syntax is altered; no check is made that
5692 ** the resulting string is valid or that the directory in question
5693 ** actually exists.
5694 **
5695 **   fileify_dirspec() - convert a directory spec into the name of the
5696 **     directory file (i.e. what you can stat() to see if it's a dir).
5697 **     The style (VMS or Unix) of the result is the same as the style
5698 **     of the parameter passed in.
5699 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5700 **     what you prepend to a filename to indicate what directory it's in).
5701 **     The style (VMS or Unix) of the result is the same as the style
5702 **     of the parameter passed in.
5703 **   tounixpath() - convert a directory spec into a Unix-style path.
5704 **   tovmspath() - convert a directory spec into a VMS-style path.
5705 **   tounixspec() - convert any file spec into a Unix-style file spec.
5706 **   tovmsspec() - convert any file spec into a VMS-style spec.
5707 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5708 **
5709 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5710 ** Permission is given to distribute this code as part of the Perl
5711 ** standard distribution under the terms of the GNU General Public
5712 ** License or the Perl Artistic License.  Copies of each may be
5713 ** found in the Perl standard distribution.
5714  */
5715
5716 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5717 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
5718 {
5719     static char __fileify_retbuf[VMS_MAXRSS];
5720     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5721     char *retspec, *cp1, *cp2, *lastdir;
5722     char *trndir, *vmsdir;
5723     unsigned short int trnlnm_iter_count;
5724     int sts;
5725     if (utf8_fl != NULL)
5726         *utf8_fl = 0;
5727
5728     if (!dir || !*dir) {
5729       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5730     }
5731     dirlen = strlen(dir);
5732     while (dirlen && dir[dirlen-1] == '/') --dirlen;
5733     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5734       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5735         dir = "/sys$disk";
5736         dirlen = 9;
5737       }
5738       else
5739         dirlen = 1;
5740     }
5741     if (dirlen > (VMS_MAXRSS - 1)) {
5742       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5743       return NULL;
5744     }
5745     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
5746     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5747     if (!strpbrk(dir+1,"/]>:")  &&
5748         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5749       strcpy(trndir,*dir == '/' ? dir + 1: dir);
5750       trnlnm_iter_count = 0;
5751       while (!strpbrk(trndir,"/]>:") && my_trnlnm(trndir,trndir,0)) {
5752         trnlnm_iter_count++;
5753         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5754       }
5755       dirlen = strlen(trndir);
5756     }
5757     else {
5758       strncpy(trndir,dir,dirlen);
5759       trndir[dirlen] = '\0';
5760     }
5761
5762     /* At this point we are done with *dir and use *trndir which is a
5763      * copy that can be modified.  *dir must not be modified.
5764      */
5765
5766     /* If we were handed a rooted logical name or spec, treat it like a
5767      * simple directory, so that
5768      *    $ Define myroot dev:[dir.]
5769      *    ... do_fileify_dirspec("myroot",buf,1) ...
5770      * does something useful.
5771      */
5772     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5773       trndir[--dirlen] = '\0';
5774       trndir[dirlen-1] = ']';
5775     }
5776     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5777       trndir[--dirlen] = '\0';
5778       trndir[dirlen-1] = '>';
5779     }
5780
5781     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5782       /* If we've got an explicit filename, we can just shuffle the string. */
5783       if (*(cp1+1)) hasfilename = 1;
5784       /* Similarly, we can just back up a level if we've got multiple levels
5785          of explicit directories in a VMS spec which ends with directories. */
5786       else {
5787         for (cp2 = cp1; cp2 > trndir; cp2--) {
5788           if (*cp2 == '.') {
5789             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5790 /* fix-me, can not scan EFS file specs backward like this */
5791               *cp2 = *cp1; *cp1 = '\0';
5792               hasfilename = 1;
5793               break;
5794             }
5795           }
5796           if (*cp2 == '[' || *cp2 == '<') break;
5797         }
5798       }
5799     }
5800
5801     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
5802     if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
5803     cp1 = strpbrk(trndir,"]:>");
5804     if (hasfilename || !cp1) { /* Unix-style path or filename */
5805       if (trndir[0] == '.') {
5806         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5807           PerlMem_free(trndir);
5808           PerlMem_free(vmsdir);
5809           return do_fileify_dirspec("[]",buf,ts,NULL);
5810         }
5811         else if (trndir[1] == '.' &&
5812                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5813           PerlMem_free(trndir);
5814           PerlMem_free(vmsdir);
5815           return do_fileify_dirspec("[-]",buf,ts,NULL);
5816         }
5817       }
5818       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
5819         dirlen -= 1;                 /* to last element */
5820         lastdir = strrchr(trndir,'/');
5821       }
5822       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
5823         /* If we have "/." or "/..", VMSify it and let the VMS code
5824          * below expand it, rather than repeating the code to handle
5825          * relative components of a filespec here */
5826         do {
5827           if (*(cp1+2) == '.') cp1++;
5828           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
5829             char * ret_chr;
5830             if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5831                 PerlMem_free(trndir);
5832                 PerlMem_free(vmsdir);
5833                 return NULL;
5834             }
5835             if (strchr(vmsdir,'/') != NULL) {
5836               /* If do_tovmsspec() returned it, it must have VMS syntax
5837                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
5838                * the time to check this here only so we avoid a recursion
5839                * loop; otherwise, gigo.
5840                */
5841               PerlMem_free(trndir);
5842               PerlMem_free(vmsdir);
5843               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
5844               return NULL;
5845             }
5846             if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5847                 PerlMem_free(trndir);
5848                 PerlMem_free(vmsdir);
5849                 return NULL;
5850             }
5851             ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5852             PerlMem_free(trndir);
5853             PerlMem_free(vmsdir);
5854             return ret_chr;
5855           }
5856           cp1++;
5857         } while ((cp1 = strstr(cp1,"/.")) != NULL);
5858         lastdir = strrchr(trndir,'/');
5859       }
5860       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5861         char * ret_chr;
5862         /* Ditto for specs that end in an MFD -- let the VMS code
5863          * figure out whether it's a real device or a rooted logical. */
5864
5865         /* This should not happen any more.  Allowing the fake /000000
5866          * in a UNIX pathname causes all sorts of problems when trying
5867          * to run in UNIX emulation.  So the VMS to UNIX conversions
5868          * now remove the fake /000000 directories.
5869          */
5870
5871         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5872         if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5873             PerlMem_free(trndir);
5874             PerlMem_free(vmsdir);
5875             return NULL;
5876         }
5877         if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5878             PerlMem_free(trndir);
5879             PerlMem_free(vmsdir);
5880             return NULL;
5881         }
5882         ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5883         PerlMem_free(trndir);
5884         PerlMem_free(vmsdir);
5885         return ret_chr;
5886       }
5887       else {
5888
5889         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5890              !(lastdir = cp1 = strrchr(trndir,']')) &&
5891              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5892         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
5893           int ver; char *cp3;
5894
5895           /* For EFS or ODS-5 look for the last dot */
5896           if (decc_efs_charset) {
5897               cp2 = strrchr(cp1,'.');
5898           }
5899           if (vms_process_case_tolerant) {
5900               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5901                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5902                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5903                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5904                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5905                             (ver || *cp3)))))) {
5906                   PerlMem_free(trndir);
5907                   PerlMem_free(vmsdir);
5908                   set_errno(ENOTDIR);
5909                   set_vaxc_errno(RMS$_DIR);
5910                   return NULL;
5911               }
5912           }
5913           else {
5914               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5915                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5916                   !*(cp2+3) || *(cp2+3) != 'R' ||
5917                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5918                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5919                             (ver || *cp3)))))) {
5920                  PerlMem_free(trndir);
5921                  PerlMem_free(vmsdir);
5922                  set_errno(ENOTDIR);
5923                  set_vaxc_errno(RMS$_DIR);
5924                  return NULL;
5925               }
5926           }
5927           dirlen = cp2 - trndir;
5928         }
5929       }
5930
5931       retlen = dirlen + 6;
5932       if (buf) retspec = buf;
5933       else if (ts) Newx(retspec,retlen+1,char);
5934       else retspec = __fileify_retbuf;
5935       memcpy(retspec,trndir,dirlen);
5936       retspec[dirlen] = '\0';
5937
5938       /* We've picked up everything up to the directory file name.
5939          Now just add the type and version, and we're set. */
5940       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5941         strcat(retspec,".dir;1");
5942       else
5943         strcat(retspec,".DIR;1");
5944       PerlMem_free(trndir);
5945       PerlMem_free(vmsdir);
5946       return retspec;
5947     }
5948     else {  /* VMS-style directory spec */
5949
5950       char *esa, *esal, term, *cp;
5951       char *my_esa;
5952       int my_esa_len;
5953       unsigned long int sts, cmplen, haslower = 0;
5954       unsigned int nam_fnb;
5955       char * nam_type;
5956       struct FAB dirfab = cc$rms_fab;
5957       rms_setup_nam(savnam);
5958       rms_setup_nam(dirnam);
5959
5960       esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5961       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5962       esal = NULL;
5963 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5964       esal = PerlMem_malloc(VMS_MAXRSS);
5965       if (esal == NULL) _ckvmssts(SS$_INSFMEM);
5966 #endif
5967       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5968       rms_bind_fab_nam(dirfab, dirnam);
5969       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5970       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
5971 #ifdef NAM$M_NO_SHORT_UPCASE
5972       if (decc_efs_case_preserve)
5973         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5974 #endif
5975
5976       for (cp = trndir; *cp; cp++)
5977         if (islower(*cp)) { haslower = 1; break; }
5978       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5979         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5980           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5981           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5982         }
5983         if (!sts) {
5984           PerlMem_free(esa);
5985           if (esal != NULL)
5986               PerlMem_free(esal);
5987           PerlMem_free(trndir);
5988           PerlMem_free(vmsdir);
5989           set_errno(EVMSERR);
5990           set_vaxc_errno(dirfab.fab$l_sts);
5991           return NULL;
5992         }
5993       }
5994       else {
5995         savnam = dirnam;
5996         /* Does the file really exist? */
5997         if (sys$search(&dirfab)& STS$K_SUCCESS) {
5998           /* Yes; fake the fnb bits so we'll check type below */
5999         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6000         }
6001         else { /* No; just work with potential name */
6002           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6003           else {
6004             int fab_sts;
6005             fab_sts = dirfab.fab$l_sts;
6006             sts = rms_free_search_context(&dirfab);
6007             PerlMem_free(esa);
6008             if (esal != NULL)
6009                 PerlMem_free(esal);
6010             PerlMem_free(trndir);
6011             PerlMem_free(vmsdir);
6012             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
6013             return NULL;
6014           }
6015         }
6016       }
6017
6018       /* Make sure we are using the right buffer */
6019       if (esal != NULL) {
6020         my_esa = esal;
6021         my_esa_len = rms_nam_esll(dirnam);
6022       } else {
6023         my_esa = esa;
6024         my_esa_len = rms_nam_esl(dirnam);
6025       }
6026       my_esa[my_esa_len] = '\0';
6027       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6028         cp1 = strchr(my_esa,']');
6029         if (!cp1) cp1 = strchr(my_esa,'>');
6030         if (cp1) {  /* Should always be true */
6031           my_esa_len -= cp1 - my_esa - 1;
6032           memmove(my_esa, cp1 + 1, my_esa_len);
6033         }
6034       }
6035       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6036         /* Yep; check version while we're at it, if it's there. */
6037         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6038         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6039           /* Something other than .DIR[;1].  Bzzt. */
6040           sts = rms_free_search_context(&dirfab);
6041           PerlMem_free(esa);
6042           if (esal != NULL)
6043              PerlMem_free(esal);
6044           PerlMem_free(trndir);
6045           PerlMem_free(vmsdir);
6046           set_errno(ENOTDIR);
6047           set_vaxc_errno(RMS$_DIR);
6048           return NULL;
6049         }
6050       }
6051
6052       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6053         /* They provided at least the name; we added the type, if necessary, */
6054         if (buf) retspec = buf;                            /* in sys$parse() */
6055         else if (ts) Newx(retspec, my_esa_len + 1, char);
6056         else retspec = __fileify_retbuf;
6057         strcpy(retspec,my_esa);
6058         sts = rms_free_search_context(&dirfab);
6059         PerlMem_free(trndir);
6060         PerlMem_free(esa);
6061         if (esal != NULL)
6062             PerlMem_free(esal);
6063         PerlMem_free(vmsdir);
6064         return retspec;
6065       }
6066       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6067         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6068         *cp1 = '\0';
6069         my_esa_len -= 9;
6070       }
6071       if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6072       if (cp1 == NULL) { /* should never happen */
6073         sts = rms_free_search_context(&dirfab);
6074         PerlMem_free(trndir);
6075         PerlMem_free(esa);
6076         if (esal != NULL)
6077             PerlMem_free(esal);
6078         PerlMem_free(vmsdir);
6079         return NULL;
6080       }
6081       term = *cp1;
6082       *cp1 = '\0';
6083       retlen = strlen(my_esa);
6084       cp1 = strrchr(my_esa,'.');
6085       /* ODS-5 directory specifications can have extra "." in them. */
6086       /* Fix-me, can not scan EFS file specifications backwards */
6087       while (cp1 != NULL) {
6088         if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6089           break;
6090         else {
6091            cp1--;
6092            while ((cp1 > my_esa) && (*cp1 != '.'))
6093              cp1--;
6094         }
6095         if (cp1 == my_esa)
6096           cp1 = NULL;
6097       }
6098
6099       if ((cp1) != NULL) {
6100         /* There's more than one directory in the path.  Just roll back. */
6101         *cp1 = term;
6102         if (buf) retspec = buf;
6103         else if (ts) Newx(retspec,retlen+7,char);
6104         else retspec = __fileify_retbuf;
6105         strcpy(retspec,my_esa);
6106       }
6107       else {
6108         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6109           /* Go back and expand rooted logical name */
6110           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6111 #ifdef NAM$M_NO_SHORT_UPCASE
6112           if (decc_efs_case_preserve)
6113             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6114 #endif
6115           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6116             sts = rms_free_search_context(&dirfab);
6117             PerlMem_free(esa);
6118             if (esal != NULL)
6119                 PerlMem_free(esal);
6120             PerlMem_free(trndir);
6121             PerlMem_free(vmsdir);
6122             set_errno(EVMSERR);
6123             set_vaxc_errno(dirfab.fab$l_sts);
6124             return NULL;
6125           }
6126
6127           /* This changes the length of the string of course */
6128           if (esal != NULL) {
6129               my_esa_len = rms_nam_esll(dirnam);
6130           } else {
6131               my_esa_len = rms_nam_esl(dirnam);
6132           }
6133
6134           retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6135           if (buf) retspec = buf;
6136           else if (ts) Newx(retspec,retlen+16,char);
6137           else retspec = __fileify_retbuf;
6138           cp1 = strstr(my_esa,"][");
6139           if (!cp1) cp1 = strstr(my_esa,"]<");
6140           dirlen = cp1 - my_esa;
6141           memcpy(retspec,my_esa,dirlen);
6142           if (!strncmp(cp1+2,"000000]",7)) {
6143             retspec[dirlen-1] = '\0';
6144             /* fix-me Not full ODS-5, just extra dots in directories for now */
6145             cp1 = retspec + dirlen - 1;
6146             while (cp1 > retspec)
6147             {
6148               if (*cp1 == '[')
6149                 break;
6150               if (*cp1 == '.') {
6151                 if (*(cp1-1) != '^')
6152                   break;
6153               }
6154               cp1--;
6155             }
6156             if (*cp1 == '.') *cp1 = ']';
6157             else {
6158               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6159               memmove(cp1+1,"000000]",7);
6160             }
6161           }
6162           else {
6163             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
6164             retspec[retlen] = '\0';
6165             /* Convert last '.' to ']' */
6166             cp1 = retspec+retlen-1;
6167             while (*cp != '[') {
6168               cp1--;
6169               if (*cp1 == '.') {
6170                 /* Do not trip on extra dots in ODS-5 directories */
6171                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
6172                 break;
6173               }
6174             }
6175             if (*cp1 == '.') *cp1 = ']';
6176             else {
6177               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6178               memmove(cp1+1,"000000]",7);
6179             }
6180           }
6181         }
6182         else {  /* This is a top-level dir.  Add the MFD to the path. */
6183           if (buf) retspec = buf;
6184           else if (ts) Newx(retspec,retlen+16,char);
6185           else retspec = __fileify_retbuf;
6186           cp1 = my_esa;
6187           cp2 = retspec;
6188           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6189           strcpy(cp2,":[000000]");
6190           cp1 += 2;
6191           strcpy(cp2+9,cp1);
6192         }
6193       }
6194       sts = rms_free_search_context(&dirfab);
6195       /* We've set up the string up through the filename.  Add the
6196          type and version, and we're done. */
6197       strcat(retspec,".DIR;1");
6198
6199       /* $PARSE may have upcased filespec, so convert output to lower
6200        * case if input contained any lowercase characters. */
6201       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
6202       PerlMem_free(trndir);
6203       PerlMem_free(esa);
6204       if (esal != NULL)
6205         PerlMem_free(esal);
6206       PerlMem_free(vmsdir);
6207       return retspec;
6208     }
6209 }  /* end of do_fileify_dirspec() */
6210 /*}}}*/
6211 /* External entry points */
6212 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6213 { return do_fileify_dirspec(dir,buf,0,NULL); }
6214 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6215 { return do_fileify_dirspec(dir,buf,1,NULL); }
6216 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6217 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6218 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6219 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6220
6221 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6222 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6223 {
6224     static char __pathify_retbuf[VMS_MAXRSS];
6225     unsigned long int retlen;
6226     char *retpath, *cp1, *cp2, *trndir;
6227     unsigned short int trnlnm_iter_count;
6228     STRLEN trnlen;
6229     int sts;
6230     if (utf8_fl != NULL)
6231         *utf8_fl = 0;
6232
6233     if (!dir || !*dir) {
6234       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6235     }
6236
6237     trndir = PerlMem_malloc(VMS_MAXRSS);
6238     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
6239     if (*dir) strcpy(trndir,dir);
6240     else getcwd(trndir,VMS_MAXRSS - 1);
6241
6242     trnlnm_iter_count = 0;
6243     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6244            && my_trnlnm(trndir,trndir,0)) {
6245       trnlnm_iter_count++;
6246       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6247       trnlen = strlen(trndir);
6248
6249       /* Trap simple rooted lnms, and return lnm:[000000] */
6250       if (!strcmp(trndir+trnlen-2,".]")) {
6251         if (buf) retpath = buf;
6252         else if (ts) Newx(retpath,strlen(dir)+10,char);
6253         else retpath = __pathify_retbuf;
6254         strcpy(retpath,dir);
6255         strcat(retpath,":[000000]");
6256         PerlMem_free(trndir);
6257         return retpath;
6258       }
6259     }
6260
6261     /* At this point we do not work with *dir, but the copy in
6262      * *trndir that is modifiable.
6263      */
6264
6265     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
6266       if (*trndir == '.' && (*(trndir+1) == '\0' ||
6267                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
6268         retlen = 2 + (*(trndir+1) != '\0');
6269       else {
6270         if ( !(cp1 = strrchr(trndir,'/')) &&
6271              !(cp1 = strrchr(trndir,']')) &&
6272              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
6273         if ((cp2 = strchr(cp1,'.')) != NULL &&
6274             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
6275              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
6276               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
6277               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
6278           int ver; char *cp3;
6279
6280           /* For EFS or ODS-5 look for the last dot */
6281           if (decc_efs_charset) {
6282             cp2 = strrchr(cp1,'.');
6283           }
6284           if (vms_process_case_tolerant) {
6285               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
6286                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
6287                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6288                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6289                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6290                             (ver || *cp3)))))) {
6291                 PerlMem_free(trndir);
6292                 set_errno(ENOTDIR);
6293                 set_vaxc_errno(RMS$_DIR);
6294                 return NULL;
6295               }
6296           }
6297           else {
6298               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
6299                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
6300                   !*(cp2+3) || *(cp2+3) != 'R' ||
6301                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6302                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6303                             (ver || *cp3)))))) {
6304                 PerlMem_free(trndir);
6305                 set_errno(ENOTDIR);
6306                 set_vaxc_errno(RMS$_DIR);
6307                 return NULL;
6308               }
6309           }
6310           retlen = cp2 - trndir + 1;
6311         }
6312         else {  /* No file type present.  Treat the filename as a directory. */
6313           retlen = strlen(trndir) + 1;
6314         }
6315       }
6316       if (buf) retpath = buf;
6317       else if (ts) Newx(retpath,retlen+1,char);
6318       else retpath = __pathify_retbuf;
6319       strncpy(retpath, trndir, retlen-1);
6320       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
6321         retpath[retlen-1] = '/';      /* with '/', add it. */
6322         retpath[retlen] = '\0';
6323       }
6324       else retpath[retlen-1] = '\0';
6325     }
6326     else {  /* VMS-style directory spec */
6327       char *esa, *esal, *cp;
6328       char *my_esa;
6329       int my_esa_len;
6330       unsigned long int sts, cmplen, haslower;
6331       struct FAB dirfab = cc$rms_fab;
6332       int dirlen;
6333       rms_setup_nam(savnam);
6334       rms_setup_nam(dirnam);
6335
6336       /* If we've got an explicit filename, we can just shuffle the string. */
6337       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
6338              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
6339         if ((cp2 = strchr(cp1,'.')) != NULL) {
6340           int ver; char *cp3;
6341           if (vms_process_case_tolerant) {
6342               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
6343                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
6344                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6345                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6346                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6347                             (ver || *cp3)))))) {
6348                PerlMem_free(trndir);
6349                set_errno(ENOTDIR);
6350                set_vaxc_errno(RMS$_DIR);
6351                return NULL;
6352              }
6353           }
6354           else {
6355               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
6356                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
6357                   !*(cp2+3) || *(cp2+3) != 'R' ||
6358                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6359                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6360                             (ver || *cp3)))))) {
6361                PerlMem_free(trndir);
6362                set_errno(ENOTDIR);
6363                set_vaxc_errno(RMS$_DIR);
6364                return NULL;
6365              }
6366           }
6367         }
6368         else {  /* No file type, so just draw name into directory part */
6369           for (cp2 = cp1; *cp2; cp2++) ;
6370         }
6371         *cp2 = *cp1;
6372         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
6373         *cp1 = '.';
6374         /* We've now got a VMS 'path'; fall through */
6375       }
6376
6377       dirlen = strlen(trndir);
6378       if (trndir[dirlen-1] == ']' ||
6379           trndir[dirlen-1] == '>' ||
6380           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
6381         if (buf) retpath = buf;
6382         else if (ts) Newx(retpath,strlen(trndir)+1,char);
6383         else retpath = __pathify_retbuf;
6384         strcpy(retpath,trndir);
6385         PerlMem_free(trndir);
6386         return retpath;
6387       }
6388       rms_set_fna(dirfab, dirnam, trndir, dirlen);
6389       esa = PerlMem_malloc(VMS_MAXRSS);
6390       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
6391       esal = NULL;
6392 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6393       esal = PerlMem_malloc(VMS_MAXRSS);
6394       if (esal == NULL) _ckvmssts(SS$_INSFMEM);
6395 #endif
6396       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6397       rms_bind_fab_nam(dirfab, dirnam);
6398       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
6399 #ifdef NAM$M_NO_SHORT_UPCASE
6400       if (decc_efs_case_preserve)
6401           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6402 #endif
6403
6404       for (cp = trndir; *cp; cp++)
6405         if (islower(*cp)) { haslower = 1; break; }
6406
6407       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
6408         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
6409           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6410           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
6411         }
6412         if (!sts) {
6413           PerlMem_free(trndir);
6414           PerlMem_free(esa);
6415           if (esal != NULL)
6416             PerlMem_free(esal);
6417           set_errno(EVMSERR);
6418           set_vaxc_errno(dirfab.fab$l_sts);
6419           return NULL;
6420         }
6421       }
6422       else {
6423         savnam = dirnam;
6424         /* Does the file really exist? */
6425         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
6426           if (dirfab.fab$l_sts != RMS$_FNF) {
6427             int sts1;
6428             sts1 = rms_free_search_context(&dirfab);
6429             PerlMem_free(trndir);
6430             PerlMem_free(esa);
6431             if (esal != NULL)
6432                 PerlMem_free(esal);
6433             set_errno(EVMSERR);
6434             set_vaxc_errno(dirfab.fab$l_sts);
6435             return NULL;
6436           }
6437           dirnam = savnam; /* No; just work with potential name */
6438         }
6439       }
6440       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6441         /* Yep; check version while we're at it, if it's there. */
6442         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6443         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
6444           int sts2;
6445           /* Something other than .DIR[;1].  Bzzt. */
6446           sts2 = rms_free_search_context(&dirfab);
6447           PerlMem_free(trndir);
6448           PerlMem_free(esa);
6449           if (esal != NULL)
6450              PerlMem_free(esal);
6451           set_errno(ENOTDIR);
6452           set_vaxc_errno(RMS$_DIR);
6453           return NULL;
6454         }
6455       }
6456       /* Make sure we are using the right buffer */
6457       if (esal != NULL) {
6458         /* We only need one, clean up the other */
6459         my_esa = esal;
6460         my_esa_len = rms_nam_esll(dirnam);
6461       } else {
6462         my_esa = esa;
6463         my_esa_len = rms_nam_esl(dirnam);
6464       }
6465
6466       /* Null terminate the buffer */
6467       my_esa[my_esa_len] = '\0';
6468
6469       /* OK, the type was fine.  Now pull any file name into the
6470          directory path. */
6471       if ((cp1 = strrchr(my_esa,']'))) *(rms_nam_typel(dirnam)) = ']';
6472       else {
6473         cp1 = strrchr(my_esa,'>');
6474         *(rms_nam_typel(dirnam)) = '>';
6475       }
6476       *cp1 = '.';
6477       *(rms_nam_typel(dirnam) + 1) = '\0';
6478       retlen = (rms_nam_typel(dirnam)) - my_esa + 2;
6479       if (buf) retpath = buf;
6480       else if (ts) Newx(retpath,retlen,char);
6481       else retpath = __pathify_retbuf;
6482       strcpy(retpath,my_esa);
6483       PerlMem_free(esa);
6484       if (esal != NULL)
6485           PerlMem_free(esal);
6486       sts = rms_free_search_context(&dirfab);
6487       /* $PARSE may have upcased filespec, so convert output to lower
6488        * case if input contained any lowercase characters. */
6489       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
6490     }
6491
6492     PerlMem_free(trndir);
6493     return retpath;
6494 }  /* end of do_pathify_dirspec() */
6495 /*}}}*/
6496 /* External entry points */
6497 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6498 { return do_pathify_dirspec(dir,buf,0,NULL); }
6499 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6500 { return do_pathify_dirspec(dir,buf,1,NULL); }
6501 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6502 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6503 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6504 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
6505
6506 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
6507 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
6508 {
6509   static char __tounixspec_retbuf[VMS_MAXRSS];
6510   char *dirend, *rslt, *cp1, *cp3, *tmp;
6511   const char *cp2;
6512   int devlen, dirlen, retlen = VMS_MAXRSS;
6513   int expand = 1; /* guarantee room for leading and trailing slashes */
6514   unsigned short int trnlnm_iter_count;
6515   int cmp_rslt;
6516   if (utf8_fl != NULL)
6517     *utf8_fl = 0;
6518
6519   if (spec == NULL) return NULL;
6520   if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
6521   if (buf) rslt = buf;
6522   else if (ts) {
6523     Newx(rslt, VMS_MAXRSS, char);
6524   }
6525   else rslt = __tounixspec_retbuf;
6526
6527   /* New VMS specific format needs translation
6528    * glob passes filenames with trailing '\n' and expects this preserved.
6529    */
6530   if (decc_posix_compliant_pathnames) {
6531     if (strncmp(spec, "\"^UP^", 5) == 0) {
6532       char * uspec;
6533       char *tunix;
6534       int tunix_len;
6535       int nl_flag;
6536
6537       tunix = PerlMem_malloc(VMS_MAXRSS);
6538       if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
6539       strcpy(tunix, spec);
6540       tunix_len = strlen(tunix);
6541       nl_flag = 0;
6542       if (tunix[tunix_len - 1] == '\n') {
6543         tunix[tunix_len - 1] = '\"';
6544         tunix[tunix_len] = '\0';
6545         tunix_len--;
6546         nl_flag = 1;
6547       }
6548       uspec = decc$translate_vms(tunix);
6549       PerlMem_free(tunix);
6550       if ((int)uspec > 0) {
6551         strcpy(rslt,uspec);
6552         if (nl_flag) {
6553           strcat(rslt,"\n");
6554         }
6555         else {
6556           /* If we can not translate it, makemaker wants as-is */
6557           strcpy(rslt, spec);
6558         }
6559         return rslt;
6560       }
6561     }
6562   }
6563
6564   cmp_rslt = 0; /* Presume VMS */
6565   cp1 = strchr(spec, '/');
6566   if (cp1 == NULL)
6567     cmp_rslt = 0;
6568
6569     /* Look for EFS ^/ */
6570     if (decc_efs_charset) {
6571       while (cp1 != NULL) {
6572         cp2 = cp1 - 1;
6573         if (*cp2 != '^') {
6574           /* Found illegal VMS, assume UNIX */
6575           cmp_rslt = 1;
6576           break;
6577         }
6578       cp1++;
6579       cp1 = strchr(cp1, '/');
6580     }
6581   }
6582
6583   /* Look for "." and ".." */
6584   if (decc_filename_unix_report) {
6585     if (spec[0] == '.') {
6586       if ((spec[1] == '\0') || (spec[1] == '\n')) {
6587         cmp_rslt = 1;
6588       }
6589       else {
6590         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
6591           cmp_rslt = 1;
6592         }
6593       }
6594     }
6595   }
6596   /* This is already UNIX or at least nothing VMS understands */
6597   if (cmp_rslt) {
6598     strcpy(rslt,spec);
6599     return rslt;
6600   }
6601
6602   cp1 = rslt;
6603   cp2 = spec;
6604   dirend = strrchr(spec,']');
6605   if (dirend == NULL) dirend = strrchr(spec,'>');
6606   if (dirend == NULL) dirend = strchr(spec,':');
6607   if (dirend == NULL) {
6608     strcpy(rslt,spec);
6609     return rslt;
6610   }
6611
6612   /* Special case 1 - sys$posix_root = / */
6613 #if __CRTL_VER >= 70000000
6614   if (!decc_disable_posix_root) {
6615     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6616       *cp1 = '/';
6617       cp1++;
6618       cp2 = cp2 + 15;
6619       }
6620   }
6621 #endif
6622
6623   /* Special case 2 - Convert NLA0: to /dev/null */
6624 #if __CRTL_VER < 70000000
6625   cmp_rslt = strncmp(spec,"NLA0:", 5);
6626   if (cmp_rslt != 0)
6627      cmp_rslt = strncmp(spec,"nla0:", 5);
6628 #else
6629   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6630 #endif
6631   if (cmp_rslt == 0) {
6632     strcpy(rslt, "/dev/null");
6633     cp1 = cp1 + 9;
6634     cp2 = cp2 + 5;
6635     if (spec[6] != '\0') {
6636       cp1[9] == '/';
6637       cp1++;
6638       cp2++;
6639     }
6640   }
6641
6642    /* Also handle special case "SYS$SCRATCH:" */
6643 #if __CRTL_VER < 70000000
6644   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
6645   if (cmp_rslt != 0)
6646      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
6647 #else
6648   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6649 #endif
6650   tmp = PerlMem_malloc(VMS_MAXRSS);
6651   if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
6652   if (cmp_rslt == 0) {
6653   int islnm;
6654
6655     islnm = my_trnlnm(tmp, "TMP", 0);
6656     if (!islnm) {
6657       strcpy(rslt, "/tmp");
6658       cp1 = cp1 + 4;
6659       cp2 = cp2 + 12;
6660       if (spec[12] != '\0') {
6661         cp1[4] == '/';
6662         cp1++;
6663         cp2++;
6664       }
6665     }
6666   }
6667
6668   if (*cp2 != '[' && *cp2 != '<') {
6669     *(cp1++) = '/';
6670   }
6671   else {  /* the VMS spec begins with directories */
6672     cp2++;
6673     if (*cp2 == ']' || *cp2 == '>') {
6674       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
6675       PerlMem_free(tmp);
6676       return rslt;
6677     }
6678     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
6679       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
6680         if (ts) Safefree(rslt);
6681         PerlMem_free(tmp);
6682         return NULL;
6683       }
6684       trnlnm_iter_count = 0;
6685       do {
6686         cp3 = tmp;
6687         while (*cp3 != ':' && *cp3) cp3++;
6688         *(cp3++) = '\0';
6689         if (strchr(cp3,']') != NULL) break;
6690         trnlnm_iter_count++;
6691         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
6692       } while (vmstrnenv(tmp,tmp,0,fildev,0));
6693       if (ts && !buf &&
6694           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
6695         retlen = devlen + dirlen;
6696         Renew(rslt,retlen+1+2*expand,char);
6697         cp1 = rslt;
6698       }
6699       cp3 = tmp;
6700       *(cp1++) = '/';
6701       while (*cp3) {
6702         *(cp1++) = *(cp3++);
6703         if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
6704             PerlMem_free(tmp);
6705             return NULL; /* No room */
6706         }
6707       }
6708       *(cp1++) = '/';
6709     }
6710     if ((*cp2 == '^')) {
6711         /* EFS file escape, pass the next character as is */
6712         /* Fix me: HEX encoding for Unicode not implemented */
6713         cp2++;
6714     }
6715     else if ( *cp2 == '.') {
6716       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
6717         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6718         cp2 += 3;
6719       }
6720       else cp2++;
6721     }
6722   }
6723   PerlMem_free(tmp);
6724   for (; cp2 <= dirend; cp2++) {
6725     if ((*cp2 == '^')) {
6726         /* EFS file escape, pass the next character as is */
6727         /* Fix me: HEX encoding for Unicode not implemented */
6728         *(cp1++) = *(++cp2);
6729         /* An escaped dot stays as is -- don't convert to slash */
6730         if (*cp2 == '.') cp2++;
6731     }
6732     if (*cp2 == ':') {
6733       *(cp1++) = '/';
6734       if (*(cp2+1) == '[') cp2++;
6735     }
6736     else if (*cp2 == ']' || *cp2 == '>') {
6737       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6738     }
6739     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
6740       *(cp1++) = '/';
6741       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6742         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6743                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6744         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6745             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6746       }
6747       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6748         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6749         cp2 += 2;
6750       }
6751     }
6752     else if (*cp2 == '-') {
6753       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6754         while (*cp2 == '-') {
6755           cp2++;
6756           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6757         }
6758         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
6759           if (ts) Safefree(rslt);                        /* filespecs like */
6760           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
6761           return NULL;
6762         }
6763       }
6764       else *(cp1++) = *cp2;
6765     }
6766     else *(cp1++) = *cp2;
6767   }
6768   while (*cp2) {
6769     if ((*cp2 == '^') && (*(cp2+1) == '.')) cp2++;  /* '^.' --> '.' */
6770     *(cp1++) = *(cp2++);
6771   }
6772   *cp1 = '\0';
6773
6774   /* This still leaves /000000/ when working with a
6775    * VMS device root or concealed root.
6776    */
6777   {
6778   int ulen;
6779   char * zeros;
6780
6781       ulen = strlen(rslt);
6782
6783       /* Get rid of "000000/ in rooted filespecs */
6784       if (ulen > 7) {
6785         zeros = strstr(rslt, "/000000/");
6786         if (zeros != NULL) {
6787           int mlen;
6788           mlen = ulen - (zeros - rslt) - 7;
6789           memmove(zeros, &zeros[7], mlen);
6790           ulen = ulen - 7;
6791           rslt[ulen] = '\0';
6792         }
6793       }
6794   }
6795
6796   return rslt;
6797
6798 }  /* end of do_tounixspec() */
6799 /*}}}*/
6800 /* External entry points */
6801 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
6802   { return do_tounixspec(spec,buf,0, NULL); }
6803 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
6804   { return do_tounixspec(spec,buf,1, NULL); }
6805 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
6806   { return do_tounixspec(spec,buf,0, utf8_fl); }
6807 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
6808   { return do_tounixspec(spec,buf,1, utf8_fl); }
6809
6810 #if __CRTL_VER >= 70200000 && !defined(__VAX)
6811
6812 /*
6813  This procedure is used to identify if a path is based in either
6814  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
6815  it returns the OpenVMS format directory for it.
6816
6817  It is expecting specifications of only '/' or '/xxxx/'
6818
6819  If a posix root does not exist, or 'xxxx' is not a directory
6820  in the posix root, it returns a failure.
6821
6822  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
6823
6824  It is used only internally by posix_to_vmsspec_hardway().
6825  */
6826
6827 static int posix_root_to_vms
6828   (char *vmspath, int vmspath_len,
6829    const char *unixpath,
6830    const int * utf8_fl)
6831 {
6832 int sts;
6833 struct FAB myfab = cc$rms_fab;
6834 rms_setup_nam(mynam);
6835 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6836 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6837 char * esa, * esal, * rsa, * rsal;
6838 char *vms_delim;
6839 int dir_flag;
6840 int unixlen;
6841
6842     dir_flag = 0;
6843     vmspath[0] = '\0';
6844     unixlen = strlen(unixpath);
6845     if (unixlen == 0) {
6846       return RMS$_FNF;
6847     }
6848
6849 #if __CRTL_VER >= 80200000
6850   /* If not a posix spec already, convert it */
6851   if (decc_posix_compliant_pathnames) {
6852     if (strncmp(unixpath,"\"^UP^",5) != 0) {
6853       sprintf(vmspath,"\"^UP^%s\"",unixpath);
6854     }
6855     else {
6856       /* This is already a VMS specification, no conversion */
6857       unixlen--;
6858       strncpy(vmspath,unixpath, vmspath_len);
6859     }
6860   }
6861   else
6862 #endif
6863   {
6864   int path_len;
6865   int i,j;
6866
6867      /* Check to see if this is under the POSIX root */
6868      if (decc_disable_posix_root) {
6869         return RMS$_FNF;
6870      }
6871
6872      /* Skip leading / */
6873      if (unixpath[0] == '/') {
6874         unixpath++;
6875         unixlen--;
6876      }
6877
6878
6879      strcpy(vmspath,"SYS$POSIX_ROOT:");
6880
6881      /* If this is only the / , or blank, then... */
6882      if (unixpath[0] == '\0') {
6883         /* by definition, this is the answer */
6884         return SS$_NORMAL;
6885      }
6886
6887      /* Need to look up a directory */
6888      vmspath[15] = '[';
6889      vmspath[16] = '\0';
6890
6891      /* Copy and add '^' escape characters as needed */
6892      j = 16;
6893      i = 0;
6894      while (unixpath[i] != 0) {
6895      int k;
6896
6897         j += copy_expand_unix_filename_escape
6898             (&vmspath[j], &unixpath[i], &k, utf8_fl);
6899         i += k;
6900      }
6901
6902      path_len = strlen(vmspath);
6903      if (vmspath[path_len - 1] == '/')
6904         path_len--;
6905      vmspath[path_len] = ']';
6906      path_len++;
6907      vmspath[path_len] = '\0';
6908
6909   }
6910   vmspath[vmspath_len] = 0;
6911   if (unixpath[unixlen - 1] == '/')
6912   dir_flag = 1;
6913   esal = PerlMem_malloc(VMS_MAXRSS);
6914   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6915   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6916   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6917   rsal = PerlMem_malloc(VMS_MAXRSS);
6918   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6919   rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6920   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6921   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
6922   rms_bind_fab_nam(myfab, mynam);
6923   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
6924   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
6925   if (decc_efs_case_preserve)
6926     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6927 #ifdef NAML$M_OPEN_SPECIAL
6928   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6929 #endif
6930
6931   /* Set up the remaining naml fields */
6932   sts = sys$parse(&myfab);
6933
6934   /* It failed! Try again as a UNIX filespec */
6935   if (!(sts & 1)) {
6936     PerlMem_free(esal);
6937     PerlMem_free(esa);
6938     PerlMem_free(rsal);
6939     PerlMem_free(rsa);
6940     return sts;
6941   }
6942
6943    /* get the Device ID and the FID */
6944    sts = sys$search(&myfab);
6945
6946    /* These are no longer needed */
6947    PerlMem_free(esa);
6948    PerlMem_free(rsal);
6949    PerlMem_free(rsa);
6950
6951    /* on any failure, returned the POSIX ^UP^ filespec */
6952    if (!(sts & 1)) {
6953       PerlMem_free(esal);
6954       return sts;
6955    }
6956    specdsc.dsc$a_pointer = vmspath;
6957    specdsc.dsc$w_length = vmspath_len;
6958
6959    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6960    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6961    sts = lib$fid_to_name
6962       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6963
6964   /* on any failure, returned the POSIX ^UP^ filespec */
6965   if (!(sts & 1)) {
6966      /* This can happen if user does not have permission to read directories */
6967      if (strncmp(unixpath,"\"^UP^",5) != 0)
6968        sprintf(vmspath,"\"^UP^%s\"",unixpath);
6969      else
6970        strcpy(vmspath, unixpath);
6971   }
6972   else {
6973     vmspath[specdsc.dsc$w_length] = 0;
6974
6975     /* Are we expecting a directory? */
6976     if (dir_flag != 0) {
6977     int i;
6978     char *eptr;
6979
6980       eptr = NULL;
6981
6982       i = specdsc.dsc$w_length - 1;
6983       while (i > 0) {
6984       int zercnt;
6985         zercnt = 0;
6986         /* Version must be '1' */
6987         if (vmspath[i--] != '1')
6988           break;
6989         /* Version delimiter is one of ".;" */
6990         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6991           break;
6992         i--;
6993         if (vmspath[i--] != 'R')
6994           break;
6995         if (vmspath[i--] != 'I')
6996           break;
6997         if (vmspath[i--] != 'D')
6998           break;
6999         if (vmspath[i--] != '.')
7000           break;
7001         eptr = &vmspath[i+1];
7002         while (i > 0) {
7003           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7004             if (vmspath[i-1] != '^') {
7005               if (zercnt != 6) {
7006                 *eptr = vmspath[i];
7007                 eptr[1] = '\0';
7008                 vmspath[i] = '.';
7009                 break;
7010               }
7011               else {
7012                 /* Get rid of 6 imaginary zero directory filename */
7013                 vmspath[i+1] = '\0';
7014               }
7015             }
7016           }
7017           if (vmspath[i] == '0')
7018             zercnt++;
7019           else
7020             zercnt = 10;
7021           i--;
7022         }
7023         break;
7024       }
7025     }
7026   }
7027   PerlMem_free(esal);
7028   return sts;
7029 }
7030
7031 /* /dev/mumble needs to be handled special.
7032    /dev/null becomes NLA0:, And there is the potential for other stuff
7033    like /dev/tty which may need to be mapped to something.
7034 */
7035
7036 static int
7037 slash_dev_special_to_vms
7038    (const char * unixptr,
7039     char * vmspath,
7040     int vmspath_len)
7041 {
7042 char * nextslash;
7043 int len;
7044 int cmp;
7045 int islnm;
7046
7047     unixptr += 4;
7048     nextslash = strchr(unixptr, '/');
7049     len = strlen(unixptr);
7050     if (nextslash != NULL)
7051         len = nextslash - unixptr;
7052     cmp = strncmp("null", unixptr, 5);
7053     if (cmp == 0) {
7054         if (vmspath_len >= 6) {
7055             strcpy(vmspath, "_NLA0:");
7056             return SS$_NORMAL;
7057         }
7058     }
7059 }
7060
7061
7062 /* The built in routines do not understand perl's special needs, so
7063     doing a manual conversion from UNIX to VMS
7064
7065     If the utf8_fl is not null and points to a non-zero value, then
7066     treat 8 bit characters as UTF-8.
7067
7068     The sequence starting with '$(' and ending with ')' will be passed
7069     through with out interpretation instead of being escaped.
7070
7071   */
7072 static int posix_to_vmsspec_hardway
7073   (char *vmspath, int vmspath_len,
7074    const char *unixpath,
7075    int dir_flag,
7076    int * utf8_fl) {
7077
7078 char *esa;
7079 const char *unixptr;
7080 const char *unixend;
7081 char *vmsptr;
7082 const char *lastslash;
7083 const char *lastdot;
7084 int unixlen;
7085 int vmslen;
7086 int dir_start;
7087 int dir_dot;
7088 int quoted;
7089 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7090 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7091
7092   if (utf8_fl != NULL)
7093     *utf8_fl = 0;
7094
7095   unixptr = unixpath;
7096   dir_dot = 0;
7097
7098   /* Ignore leading "/" characters */
7099   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7100     unixptr++;
7101   }
7102   unixlen = strlen(unixptr);
7103
7104   /* Do nothing with blank paths */
7105   if (unixlen == 0) {
7106     vmspath[0] = '\0';
7107     return SS$_NORMAL;
7108   }
7109
7110   quoted = 0;
7111   /* This could have a "^UP^ on the front */
7112   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7113     quoted = 1;
7114     unixptr+= 5;
7115     unixlen-= 5;
7116   }
7117
7118   lastslash = strrchr(unixptr,'/');
7119   lastdot = strrchr(unixptr,'.');
7120   unixend = strrchr(unixptr,'\"');
7121   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7122     unixend = unixptr + unixlen;
7123   }
7124
7125   /* last dot is last dot or past end of string */
7126   if (lastdot == NULL)
7127     lastdot = unixptr + unixlen;
7128
7129   /* if no directories, set last slash to beginning of string */
7130   if (lastslash == NULL) {
7131     lastslash = unixptr;
7132   }
7133   else {
7134     /* Watch out for trailing "." after last slash, still a directory */
7135     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7136       lastslash = unixptr + unixlen;
7137     }
7138
7139     /* Watch out for traiing ".." after last slash, still a directory */
7140     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7141       lastslash = unixptr + unixlen;
7142     }
7143
7144     /* dots in directories are aways escaped */
7145     if (lastdot < lastslash)
7146       lastdot = unixptr + unixlen;
7147   }
7148
7149   /* if (unixptr < lastslash) then we are in a directory */
7150
7151   dir_start = 0;
7152
7153   vmsptr = vmspath;
7154   vmslen = 0;
7155
7156   /* Start with the UNIX path */
7157   if (*unixptr != '/') {
7158     /* relative paths */
7159
7160     /* If allowing logical names on relative pathnames, then handle here */
7161     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7162         !decc_posix_compliant_pathnames) {
7163     char * nextslash;
7164     int seg_len;
7165     char * trn;
7166     int islnm;
7167
7168         /* Find the next slash */
7169         nextslash = strchr(unixptr,'/');
7170
7171         esa = PerlMem_malloc(vmspath_len);
7172         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7173
7174         trn = PerlMem_malloc(VMS_MAXRSS);
7175         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7176
7177         if (nextslash != NULL) {
7178
7179             seg_len = nextslash - unixptr;
7180             strncpy(esa, unixptr, seg_len);
7181             esa[seg_len] = 0;
7182         }
7183         else {
7184             strcpy(esa, unixptr);
7185             seg_len = strlen(unixptr);
7186         }
7187         /* trnlnm(section) */
7188         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7189
7190         if (islnm) {
7191             /* Now fix up the directory */
7192
7193             /* Split up the path to find the components */
7194             sts = vms_split_path
7195                   (trn,
7196                    &v_spec,
7197                    &v_len,
7198                    &r_spec,
7199                    &r_len,
7200                    &d_spec,
7201                    &d_len,
7202                    &n_spec,
7203                    &n_len,
7204                    &e_spec,
7205                    &e_len,
7206                    &vs_spec,
7207                    &vs_len);
7208
7209             while (sts == 0) {
7210             char * strt;
7211             int cmp;
7212
7213                 /* A logical name must be a directory  or the full
7214                    specification.  It is only a full specification if
7215                    it is the only component */
7216                 if ((unixptr[seg_len] == '\0') ||
7217                     (unixptr[seg_len+1] == '\0')) {
7218
7219                     /* Is a directory being required? */
7220                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7221                         /* Not a logical name */
7222                         break;
7223                     }
7224
7225
7226                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7227                         /* This must be a directory */
7228                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7229                             strcpy(vmsptr, esa);
7230                             vmslen=strlen(vmsptr);
7231                             vmsptr[vmslen] = ':';
7232                             vmslen++;
7233                             vmsptr[vmslen] = '\0';
7234                             return SS$_NORMAL;
7235                         }
7236                     }
7237
7238                 }
7239
7240
7241                 /* must be dev/directory - ignore version */
7242                 if ((n_len + e_len) != 0)
7243                     break;
7244
7245                 /* transfer the volume */
7246                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7247                     strncpy(vmsptr, v_spec, v_len);
7248                     vmsptr += v_len;
7249                     vmsptr[0] = '\0';
7250                     vmslen += v_len;
7251                 }
7252
7253                 /* unroot the rooted directory */
7254                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7255                     r_spec[0] = '[';
7256                     r_spec[r_len - 1] = ']';
7257
7258                     /* This should not be there, but nothing is perfect */
7259                     if (r_len > 9) {
7260                         cmp = strcmp(&r_spec[1], "000000.");
7261                         if (cmp == 0) {
7262                             r_spec += 7;
7263                             r_spec[7] = '[';
7264                             r_len -= 7;
7265                             if (r_len == 2)
7266                                 r_len = 0;
7267                         }
7268                     }
7269                     if (r_len > 0) {
7270                         strncpy(vmsptr, r_spec, r_len);
7271                         vmsptr += r_len;
7272                         vmslen += r_len;
7273                         vmsptr[0] = '\0';
7274                     }
7275                 }
7276                 /* Bring over the directory. */
7277                 if ((d_len > 0) &&
7278                     ((d_len + vmslen) < vmspath_len)) {
7279                     d_spec[0] = '[';
7280                     d_spec[d_len - 1] = ']';
7281                     if (d_len > 9) {
7282                         cmp = strcmp(&d_spec[1], "000000.");
7283                         if (cmp == 0) {
7284                             d_spec += 7;
7285                             d_spec[7] = '[';
7286                             d_len -= 7;
7287                             if (d_len == 2)
7288                                 d_len = 0;
7289                         }
7290                     }
7291
7292                     if (r_len > 0) {
7293                         /* Remove the redundant root */
7294                         if (r_len > 0) {
7295                             /* remove the ][ */
7296                             vmsptr--;
7297                             vmslen--;
7298                             d_spec++;
7299                             d_len--;
7300                         }
7301                         strncpy(vmsptr, d_spec, d_len);
7302                             vmsptr += d_len;
7303                             vmslen += d_len;
7304                             vmsptr[0] = '\0';
7305                     }
7306                 }
7307                 break;
7308             }
7309         }
7310
7311         PerlMem_free(esa);
7312         PerlMem_free(trn);
7313     }
7314
7315     if (lastslash > unixptr) {
7316     int dotdir_seen;
7317
7318       /* skip leading ./ */
7319       dotdir_seen = 0;
7320       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7321         dotdir_seen = 1;
7322         unixptr++;
7323         unixptr++;
7324       }
7325
7326       /* Are we still in a directory? */
7327       if (unixptr <= lastslash) {
7328         *vmsptr++ = '[';
7329         vmslen = 1;
7330         dir_start = 1;
7331
7332         /* if not backing up, then it is relative forward. */
7333         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7334               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7335           *vmsptr++ = '.';
7336           vmslen++;
7337           dir_dot = 1;
7338           }
7339        }
7340        else {
7341          if (dotdir_seen) {
7342            /* Perl wants an empty directory here to tell the difference
7343             * between a DCL commmand and a filename
7344             */
7345           *vmsptr++ = '[';
7346           *vmsptr++ = ']';
7347           vmslen = 2;
7348         }
7349       }
7350     }
7351     else {
7352       /* Handle two special files . and .. */
7353       if (unixptr[0] == '.') {
7354         if (&unixptr[1] == unixend) {
7355           *vmsptr++ = '[';
7356           *vmsptr++ = ']';
7357           vmslen += 2;
7358           *vmsptr++ = '\0';
7359           return SS$_NORMAL;
7360         }
7361         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7362           *vmsptr++ = '[';
7363           *vmsptr++ = '-';
7364           *vmsptr++ = ']';
7365           vmslen += 3;
7366           *vmsptr++ = '\0';
7367           return SS$_NORMAL;
7368         }
7369       }
7370     }
7371   }
7372   else {        /* Absolute PATH handling */
7373   int sts;
7374   char * nextslash;
7375   int seg_len;
7376     /* Need to find out where root is */
7377
7378     /* In theory, this procedure should never get an absolute POSIX pathname
7379      * that can not be found on the POSIX root.
7380      * In practice, that can not be relied on, and things will show up
7381      * here that are a VMS device name or concealed logical name instead.
7382      * So to make things work, this procedure must be tolerant.
7383      */
7384     esa = PerlMem_malloc(vmspath_len);
7385     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7386
7387     sts = SS$_NORMAL;
7388     nextslash = strchr(&unixptr[1],'/');
7389     seg_len = 0;
7390     if (nextslash != NULL) {
7391     int cmp;
7392       seg_len = nextslash - &unixptr[1];
7393       strncpy(vmspath, unixptr, seg_len + 1);
7394       vmspath[seg_len+1] = 0;
7395       cmp = 1;
7396       if (seg_len == 3) {
7397         cmp = strncmp(vmspath, "dev", 4);
7398         if (cmp == 0) {
7399             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7400             if (sts = SS$_NORMAL)
7401                 return SS$_NORMAL;
7402         }
7403       }
7404       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
7405     }
7406
7407     if ($VMS_STATUS_SUCCESS(sts)) {
7408       /* This is verified to be a real path */
7409
7410       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7411       if ($VMS_STATUS_SUCCESS(sts)) {
7412         strcpy(vmspath, esa);
7413         vmslen = strlen(vmspath);
7414         vmsptr = vmspath + vmslen;
7415         unixptr++;
7416         if (unixptr < lastslash) {
7417         char * rptr;
7418           vmsptr--;
7419           *vmsptr++ = '.';
7420           dir_start = 1;
7421           dir_dot = 1;
7422           if (vmslen > 7) {
7423           int cmp;
7424             rptr = vmsptr - 7;
7425             cmp = strcmp(rptr,"000000.");
7426             if (cmp == 0) {
7427               vmslen -= 7;
7428               vmsptr -= 7;
7429               vmsptr[1] = '\0';
7430             } /* removing 6 zeros */
7431           } /* vmslen < 7, no 6 zeros possible */
7432         } /* Not in a directory */
7433       } /* Posix root found */
7434       else {
7435         /* No posix root, fall back to default directory */
7436         strcpy(vmspath, "SYS$DISK:[");
7437         vmsptr = &vmspath[10];
7438         vmslen = 10;
7439         if (unixptr > lastslash) {
7440            *vmsptr = ']';
7441            vmsptr++;
7442            vmslen++;
7443         }
7444         else {
7445            dir_start = 1;
7446         }
7447       }
7448     } /* end of verified real path handling */
7449     else {
7450     int add_6zero;
7451     int islnm;
7452
7453       /* Ok, we have a device or a concealed root that is not in POSIX
7454        * or we have garbage.  Make the best of it.
7455        */
7456
7457       /* Posix to VMS destroyed this, so copy it again */
7458       strncpy(vmspath, &unixptr[1], seg_len);
7459       vmspath[seg_len] = 0;
7460       vmslen = seg_len;
7461       vmsptr = &vmsptr[vmslen];
7462       islnm = 0;
7463
7464       /* Now do we need to add the fake 6 zero directory to it? */
7465       add_6zero = 1;
7466       if ((*lastslash == '/') && (nextslash < lastslash)) {
7467         /* No there is another directory */
7468         add_6zero = 0;
7469       }
7470       else {
7471       int trnend;
7472       int cmp;
7473
7474         /* now we have foo:bar or foo:[000000]bar to decide from */
7475         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
7476
7477         if (!islnm && !decc_posix_compliant_pathnames) {
7478
7479             cmp = strncmp("bin", vmspath, 4);
7480             if (cmp == 0) {
7481                 /* bin => SYS$SYSTEM: */
7482                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7483             }
7484             else {
7485                 /* tmp => SYS$SCRATCH: */
7486                 cmp = strncmp("tmp", vmspath, 4);
7487                 if (cmp == 0) {
7488                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
7489                 }
7490             }
7491         }
7492
7493         trnend = islnm ? islnm - 1 : 0;
7494
7495         /* if this was a logical name, ']' or '>' must be present */
7496         /* if not a logical name, then assume a device and hope. */
7497         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
7498
7499         /* if log name and trailing '.' then rooted - treat as device */
7500         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
7501
7502         /* Fix me, if not a logical name, a device lookup should be
7503          * done to see if the device is file structured.  If the device
7504          * is not file structured, the 6 zeros should not be put on.
7505          *
7506          * As it is, perl is occasionally looking for dev:[000000]tty.
7507          * which looks a little strange.
7508          *
7509          * Not that easy to detect as "/dev" may be file structured with
7510          * special device files.
7511          */
7512
7513         if ((add_6zero == 0) && (*nextslash == '/') &&
7514             (&nextslash[1] == unixend)) {
7515           /* No real directory present */
7516           add_6zero = 1;
7517         }
7518       }
7519
7520       /* Put the device delimiter on */
7521       *vmsptr++ = ':';
7522       vmslen++;
7523       unixptr = nextslash;
7524       unixptr++;
7525
7526       /* Start directory if needed */
7527       if (!islnm || add_6zero) {
7528         *vmsptr++ = '[';
7529         vmslen++;
7530         dir_start = 1;
7531       }
7532
7533       /* add fake 000000] if needed */
7534       if (add_6zero) {
7535         *vmsptr++ = '0';
7536         *vmsptr++ = '0';
7537         *vmsptr++ = '0';
7538         *vmsptr++ = '0';
7539         *vmsptr++ = '0';
7540         *vmsptr++ = '0';
7541         *vmsptr++ = ']';
7542         vmslen += 7;
7543         dir_start = 0;
7544       }
7545
7546     } /* non-POSIX translation */
7547     PerlMem_free(esa);
7548   } /* End of relative/absolute path handling */
7549
7550   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
7551   int dash_flag;
7552   int in_cnt;
7553   int out_cnt;
7554
7555     dash_flag = 0;
7556
7557     if (dir_start != 0) {
7558
7559       /* First characters in a directory are handled special */
7560       while ((*unixptr == '/') ||
7561              ((*unixptr == '.') &&
7562               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
7563                 (&unixptr[1]==unixend)))) {
7564       int loop_flag;
7565
7566         loop_flag = 0;
7567
7568         /* Skip redundant / in specification */
7569         while ((*unixptr == '/') && (dir_start != 0)) {
7570           loop_flag = 1;
7571           unixptr++;
7572           if (unixptr == lastslash)
7573             break;
7574         }
7575         if (unixptr == lastslash)
7576           break;
7577
7578         /* Skip redundant ./ characters */
7579         while ((*unixptr == '.') &&
7580                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
7581           loop_flag = 1;
7582           unixptr++;
7583           if (unixptr == lastslash)
7584             break;
7585           if (*unixptr == '/')
7586             unixptr++;
7587         }
7588         if (unixptr == lastslash)
7589           break;
7590
7591         /* Skip redundant ../ characters */
7592         while ((*unixptr == '.') && (unixptr[1] == '.') &&
7593              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
7594           /* Set the backing up flag */
7595           loop_flag = 1;
7596           dir_dot = 0;
7597           dash_flag = 1;
7598           *vmsptr++ = '-';
7599           vmslen++;
7600           unixptr++; /* first . */
7601           unixptr++; /* second . */
7602           if (unixptr == lastslash)
7603             break;
7604           if (*unixptr == '/') /* The slash */
7605             unixptr++;
7606         }
7607         if (unixptr == lastslash)
7608           break;
7609
7610         /* To do: Perl expects /.../ to be translated to [...] on VMS */
7611         /* Not needed when VMS is pretending to be UNIX. */
7612
7613         /* Is this loop stuck because of too many dots? */
7614         if (loop_flag == 0) {
7615           /* Exit the loop and pass the rest through */
7616           break;
7617         }
7618       }
7619
7620       /* Are we done with directories yet? */
7621       if (unixptr >= lastslash) {
7622
7623         /* Watch out for trailing dots */
7624         if (dir_dot != 0) {
7625             vmslen --;
7626             vmsptr--;
7627         }
7628         *vmsptr++ = ']';
7629         vmslen++;
7630         dash_flag = 0;
7631         dir_start = 0;
7632         if (*unixptr == '/')
7633           unixptr++;
7634       }
7635       else {
7636         /* Have we stopped backing up? */
7637         if (dash_flag) {
7638           *vmsptr++ = '.';
7639           vmslen++;
7640           dash_flag = 0;
7641           /* dir_start continues to be = 1 */
7642         }
7643         if (*unixptr == '-') {
7644           *vmsptr++ = '^';
7645           *vmsptr++ = *unixptr++;
7646           vmslen += 2;
7647           dir_start = 0;
7648
7649           /* Now are we done with directories yet? */
7650           if (unixptr >= lastslash) {
7651
7652             /* Watch out for trailing dots */
7653             if (dir_dot != 0) {
7654               vmslen --;
7655               vmsptr--;
7656             }
7657
7658             *vmsptr++ = ']';
7659             vmslen++;
7660             dash_flag = 0;
7661             dir_start = 0;
7662           }
7663         }
7664       }
7665     }
7666
7667     /* All done? */
7668     if (unixptr >= unixend)
7669       break;
7670
7671     /* Normal characters - More EFS work probably needed */
7672     dir_start = 0;
7673     dir_dot = 0;
7674
7675     switch(*unixptr) {
7676     case '/':
7677         /* remove multiple / */
7678         while (unixptr[1] == '/') {
7679            unixptr++;
7680         }
7681         if (unixptr == lastslash) {
7682           /* Watch out for trailing dots */
7683           if (dir_dot != 0) {
7684             vmslen --;
7685             vmsptr--;
7686           }
7687           *vmsptr++ = ']';
7688         }
7689         else {
7690           dir_start = 1;
7691           *vmsptr++ = '.';
7692           dir_dot = 1;
7693
7694           /* To do: Perl expects /.../ to be translated to [...] on VMS */
7695           /* Not needed when VMS is pretending to be UNIX. */
7696
7697         }
7698         dash_flag = 0;
7699         if (unixptr != unixend)
7700           unixptr++;
7701         vmslen++;
7702         break;
7703     case '.':
7704         if ((unixptr < lastdot) || (unixptr < lastslash) ||
7705             (&unixptr[1] == unixend)) {
7706           *vmsptr++ = '^';
7707           *vmsptr++ = '.';
7708           vmslen += 2;
7709           unixptr++;
7710
7711           /* trailing dot ==> '^..' on VMS */
7712           if (unixptr == unixend) {
7713             *vmsptr++ = '.';
7714             vmslen++;
7715             unixptr++;
7716           }
7717           break;
7718         }
7719
7720         *vmsptr++ = *unixptr++;
7721         vmslen ++;
7722         break;
7723     case '"':
7724         if (quoted && (&unixptr[1] == unixend)) {
7725             unixptr++;
7726             break;
7727         }
7728         in_cnt = copy_expand_unix_filename_escape
7729                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7730         vmsptr += out_cnt;
7731         unixptr += in_cnt;
7732         break;
7733     case '~':
7734     case ';':
7735     case '\\':
7736     case '?':
7737     case ' ':
7738     default:
7739         in_cnt = copy_expand_unix_filename_escape
7740                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7741         vmsptr += out_cnt;
7742         unixptr += in_cnt;
7743         break;
7744     }
7745   }
7746
7747   /* Make sure directory is closed */
7748   if (unixptr == lastslash) {
7749     char *vmsptr2;
7750     vmsptr2 = vmsptr - 1;
7751
7752     if (*vmsptr2 != ']') {
7753       *vmsptr2--;
7754
7755       /* directories do not end in a dot bracket */
7756       if (*vmsptr2 == '.') {
7757         vmsptr2--;
7758
7759         /* ^. is allowed */
7760         if (*vmsptr2 != '^') {
7761           vmsptr--; /* back up over the dot */
7762         }
7763       }
7764       *vmsptr++ = ']';
7765     }
7766   }
7767   else {
7768     char *vmsptr2;
7769     /* Add a trailing dot if a file with no extension */
7770     vmsptr2 = vmsptr - 1;
7771     if ((vmslen > 1) &&
7772         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
7773         (*vmsptr2 != ')') && (*lastdot != '.')) {
7774         *vmsptr++ = '.';
7775         vmslen++;
7776     }
7777   }
7778
7779   *vmsptr = '\0';
7780   return SS$_NORMAL;
7781 }
7782 #endif
7783
7784  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
7785 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
7786 {
7787 char * result;
7788 int utf8_flag;
7789
7790    /* If a UTF8 flag is being passed, honor it */
7791    utf8_flag = 0;
7792    if (utf8_fl != NULL) {
7793      utf8_flag = *utf8_fl;
7794     *utf8_fl = 0;
7795    }
7796
7797    if (utf8_flag) {
7798      /* If there is a possibility of UTF8, then if any UTF8 characters
7799         are present, then they must be converted to VTF-7
7800       */
7801      result = strcpy(rslt, path); /* FIX-ME */
7802    }
7803    else
7804      result = strcpy(rslt, path);
7805
7806    return result;
7807 }
7808
7809
7810 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
7811 static char *mp_do_tovmsspec
7812    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
7813   static char __tovmsspec_retbuf[VMS_MAXRSS];
7814   char *rslt, *dirend;
7815   char *lastdot;
7816   char *vms_delim;
7817   register char *cp1;
7818   const char *cp2;
7819   unsigned long int infront = 0, hasdir = 1;
7820   int rslt_len;
7821   int no_type_seen;
7822   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7823   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7824
7825   if (path == NULL) return NULL;
7826   rslt_len = VMS_MAXRSS-1;
7827   if (buf) rslt = buf;
7828   else if (ts) Newx(rslt, VMS_MAXRSS, char);
7829   else rslt = __tovmsspec_retbuf;
7830
7831   /* '.' and '..' are "[]" and "[-]" for a quick check */
7832   if (path[0] == '.') {
7833     if (path[1] == '\0') {
7834       strcpy(rslt,"[]");
7835       if (utf8_flag != NULL)
7836         *utf8_flag = 0;
7837       return rslt;
7838     }
7839     else {
7840       if (path[1] == '.' && path[2] == '\0') {
7841         strcpy(rslt,"[-]");
7842         if (utf8_flag != NULL)
7843            *utf8_flag = 0;
7844         return rslt;
7845       }
7846     }
7847   }
7848
7849    /* Posix specifications are now a native VMS format */
7850   /*--------------------------------------------------*/
7851 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7852   if (decc_posix_compliant_pathnames) {
7853     if (strncmp(path,"\"^UP^",5) == 0) {
7854       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7855       return rslt;
7856     }
7857   }
7858 #endif
7859
7860   /* This is really the only way to see if this is already in VMS format */
7861   sts = vms_split_path
7862        (path,
7863         &v_spec,
7864         &v_len,
7865         &r_spec,
7866         &r_len,
7867         &d_spec,
7868         &d_len,
7869         &n_spec,
7870         &n_len,
7871         &e_spec,
7872         &e_len,
7873         &vs_spec,
7874         &vs_len);
7875   if (sts == 0) {
7876     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
7877        replacement, because the above parse just took care of most of
7878        what is needed to do vmspath when the specification is already
7879        in VMS format.
7880
7881        And if it is not already, it is easier to do the conversion as
7882        part of this routine than to call this routine and then work on
7883        the result.
7884      */
7885
7886     /* If VMS punctuation was found, it is already VMS format */
7887     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
7888       if (utf8_flag != NULL)
7889         *utf8_flag = 0;
7890       strcpy(rslt, path);
7891       return rslt;
7892     }
7893     /* Now, what to do with trailing "." cases where there is no
7894        extension?  If this is a UNIX specification, and EFS characters
7895        are enabled, then the trailing "." should be converted to a "^.".
7896        But if this was already a VMS specification, then it should be
7897        left alone.
7898
7899        So in the case of ambiguity, leave the specification alone.
7900      */
7901
7902
7903     /* If there is a possibility of UTF8, then if any UTF8 characters
7904         are present, then they must be converted to VTF-7
7905      */
7906     if (utf8_flag != NULL)
7907       *utf8_flag = 0;
7908     strcpy(rslt, path);
7909     return rslt;
7910   }
7911
7912   dirend = strrchr(path,'/');
7913
7914   if (dirend == NULL) {
7915      /* If we get here with no UNIX directory delimiters, then this is
7916         not a complete file specification, either garbage a UNIX glob
7917         specification that can not be converted to a VMS wildcard, or
7918         it a UNIX shell macro.  MakeMaker wants these passed through AS-IS,
7919         so apparently other programs expect this also.
7920
7921         utf8 flag setting needs to be preserved.
7922       */
7923       strcpy(rslt, path);
7924       return rslt;
7925   }
7926
7927 /* If POSIX mode active, handle the conversion */
7928 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7929   if (decc_efs_charset) {
7930     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7931     return rslt;
7932   }
7933 #endif
7934
7935   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
7936     if (!*(dirend+2)) dirend +=2;
7937     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7938     if (decc_efs_charset == 0) {
7939       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7940     }
7941   }
7942
7943   cp1 = rslt;
7944   cp2 = path;
7945   lastdot = strrchr(cp2,'.');
7946   if (*cp2 == '/') {
7947     char *trndev;
7948     int islnm, rooted;
7949     STRLEN trnend;
7950
7951     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7952     if (!*(cp2+1)) {
7953       if (decc_disable_posix_root) {
7954         strcpy(rslt,"sys$disk:[000000]");
7955       }
7956       else {
7957         strcpy(rslt,"sys$posix_root:[000000]");
7958       }
7959       if (utf8_flag != NULL)
7960         *utf8_flag = 0;
7961       return rslt;
7962     }
7963     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7964     *cp1 = '\0';
7965     trndev = PerlMem_malloc(VMS_MAXRSS);
7966     if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7967     islnm =  my_trnlnm(rslt,trndev,0);
7968
7969      /* DECC special handling */
7970     if (!islnm) {
7971       if (strcmp(rslt,"bin") == 0) {
7972         strcpy(rslt,"sys$system");
7973         cp1 = rslt + 10;
7974         *cp1 = 0;
7975         islnm =  my_trnlnm(rslt,trndev,0);
7976       }
7977       else if (strcmp(rslt,"tmp") == 0) {
7978         strcpy(rslt,"sys$scratch");
7979         cp1 = rslt + 11;
7980         *cp1 = 0;
7981         islnm =  my_trnlnm(rslt,trndev,0);
7982       }
7983       else if (!decc_disable_posix_root) {
7984         strcpy(rslt, "sys$posix_root");
7985         cp1 = rslt + 13;
7986         *cp1 = 0;
7987         cp2 = path;
7988         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7989         islnm =  my_trnlnm(rslt,trndev,0);
7990       }
7991       else if (strcmp(rslt,"dev") == 0) {
7992         if (strncmp(cp2,"/null", 5) == 0) {
7993           if ((cp2[5] == 0) || (cp2[5] == '/')) {
7994             strcpy(rslt,"NLA0");
7995             cp1 = rslt + 4;
7996             *cp1 = 0;
7997             cp2 = cp2 + 5;
7998             islnm =  my_trnlnm(rslt,trndev,0);
7999           }
8000         }
8001       }
8002     }
8003
8004     trnend = islnm ? strlen(trndev) - 1 : 0;
8005     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8006     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8007     /* If the first element of the path is a logical name, determine
8008      * whether it has to be translated so we can add more directories. */
8009     if (!islnm || rooted) {
8010       *(cp1++) = ':';
8011       *(cp1++) = '[';
8012       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8013       else cp2++;
8014     }
8015     else {
8016       if (cp2 != dirend) {
8017         strcpy(rslt,trndev);
8018         cp1 = rslt + trnend;
8019         if (*cp2 != 0) {
8020           *(cp1++) = '.';
8021           cp2++;
8022         }
8023       }
8024       else {
8025         if (decc_disable_posix_root) {
8026           *(cp1++) = ':';
8027           hasdir = 0;
8028         }
8029       }
8030     }
8031     PerlMem_free(trndev);
8032   }
8033   else {
8034     *(cp1++) = '[';
8035     if (*cp2 == '.') {
8036       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8037         cp2 += 2;         /* skip over "./" - it's redundant */
8038         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8039       }
8040       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8041         *(cp1++) = '-';                                 /* "../" --> "-" */
8042         cp2 += 3;
8043       }
8044       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8045                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8046         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8047         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8048         cp2 += 4;
8049       }
8050       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8051         /* Escape the extra dots in EFS file specifications */
8052         *(cp1++) = '^';
8053       }
8054       if (cp2 > dirend) cp2 = dirend;
8055     }
8056     else *(cp1++) = '.';
8057   }
8058   for (; cp2 < dirend; cp2++) {
8059     if (*cp2 == '/') {
8060       if (*(cp2-1) == '/') continue;
8061       if (*(cp1-1) != '.') *(cp1++) = '.';
8062       infront = 0;
8063     }
8064     else if (!infront && *cp2 == '.') {
8065       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8066       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8067       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8068         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8069         else if (*(cp1-2) == '[') *(cp1-1) = '-';
8070         else {  /* back up over previous directory name */
8071           cp1--;
8072           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
8073           if (*(cp1-1) == '[') {
8074             memcpy(cp1,"000000.",7);
8075             cp1 += 7;
8076           }
8077         }
8078         cp2 += 2;
8079         if (cp2 == dirend) break;
8080       }
8081       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8082                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8083         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8084         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8085         if (!*(cp2+3)) {
8086           *(cp1++) = '.';  /* Simulate trailing '/' */
8087           cp2 += 2;  /* for loop will incr this to == dirend */
8088         }
8089         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8090       }
8091       else {
8092         if (decc_efs_charset == 0)
8093           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8094         else {
8095           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
8096           *(cp1++) = '.';
8097         }
8098       }
8099     }
8100     else {
8101       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
8102       if (*cp2 == '.') {
8103         if (decc_efs_charset == 0)
8104           *(cp1++) = '_';
8105         else {
8106           *(cp1++) = '^';
8107           *(cp1++) = '.';
8108         }
8109       }
8110       else                  *(cp1++) =  *cp2;
8111       infront = 1;
8112     }
8113   }
8114   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8115   if (hasdir) *(cp1++) = ']';
8116   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
8117   /* fixme for ODS5 */
8118   no_type_seen = 0;
8119   if (cp2 > lastdot)
8120     no_type_seen = 1;
8121   while (*cp2) {
8122     switch(*cp2) {
8123     case '?':
8124         if (decc_efs_charset == 0)
8125           *(cp1++) = '%';
8126         else
8127           *(cp1++) = '?';
8128         cp2++;
8129     case ' ':
8130         *(cp1)++ = '^';
8131         *(cp1)++ = '_';
8132         cp2++;
8133         break;
8134     case '.':
8135         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8136             decc_readdir_dropdotnotype) {
8137           *(cp1)++ = '^';
8138           *(cp1)++ = '.';
8139           cp2++;
8140
8141           /* trailing dot ==> '^..' on VMS */
8142           if (*cp2 == '\0') {
8143             *(cp1++) = '.';
8144             no_type_seen = 0;
8145           }
8146         }
8147         else {
8148           *(cp1++) = *(cp2++);
8149           no_type_seen = 0;
8150         }
8151         break;
8152     case '$':
8153          /* This could be a macro to be passed through */
8154         *(cp1++) = *(cp2++);
8155         if (*cp2 == '(') {
8156         const char * save_cp2;
8157         char * save_cp1;
8158         int is_macro;
8159
8160             /* paranoid check */
8161             save_cp2 = cp2;
8162             save_cp1 = cp1;
8163             is_macro = 0;
8164
8165             /* Test through */
8166             *(cp1++) = *(cp2++);
8167             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8168                 *(cp1++) = *(cp2++);
8169                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8170                     *(cp1++) = *(cp2++);
8171                 }
8172                 if (*cp2 == ')') {
8173                     *(cp1++) = *(cp2++);
8174                     is_macro = 1;
8175                 }
8176             }
8177             if (is_macro == 0) {
8178                 /* Not really a macro - never mind */
8179                 cp2 = save_cp2;
8180                 cp1 = save_cp1;
8181             }
8182         }
8183         break;
8184     case '\"':
8185     case '~':
8186     case '`':
8187     case '!':
8188     case '#':
8189     case '%':
8190     case '^':
8191         /* Don't escape again if following character is
8192          * already something we escape.
8193          */
8194         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8195             *(cp1++) = *(cp2++);
8196             break;
8197         }
8198         /* But otherwise fall through and escape it. */
8199     case '&':
8200     case '(':
8201     case ')':
8202     case '=':
8203     case '+':
8204     case '\'':
8205     case '@':
8206     case '[':
8207     case ']':
8208     case '{':
8209     case '}':
8210     case ':':
8211     case '\\':
8212     case '|':
8213     case '<':
8214     case '>':
8215         *(cp1++) = '^';
8216         *(cp1++) = *(cp2++);
8217         break;
8218     case ';':
8219         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8220          * which is wrong.  UNIX notation should be ".dir." unless
8221          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8222          * changing this behavior could break more things at this time.
8223          * efs character set effectively does not allow "." to be a version
8224          * delimiter as a further complication about changing this.
8225          */
8226         if (decc_filename_unix_report != 0) {
8227           *(cp1++) = '^';
8228         }
8229         *(cp1++) = *(cp2++);
8230         break;
8231     default:
8232         *(cp1++) = *(cp2++);
8233     }
8234   }
8235   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8236   char *lcp1;
8237     lcp1 = cp1;
8238     lcp1--;
8239      /* Fix me for "^]", but that requires making sure that you do
8240       * not back up past the start of the filename
8241       */
8242     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8243       *cp1++ = '.';
8244   }
8245   *cp1 = '\0';
8246
8247   if (utf8_flag != NULL)
8248     *utf8_flag = 0;
8249   return rslt;
8250
8251 }  /* end of do_tovmsspec() */
8252 /*}}}*/
8253 /* External entry points */
8254 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8255   { return do_tovmsspec(path,buf,0,NULL); }
8256 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8257   { return do_tovmsspec(path,buf,1,NULL); }
8258 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8259   { return do_tovmsspec(path,buf,0,utf8_fl); }
8260 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8261   { return do_tovmsspec(path,buf,1,utf8_fl); }
8262
8263 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8264 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8265   static char __tovmspath_retbuf[VMS_MAXRSS];
8266   int vmslen;
8267   char *pathified, *vmsified, *cp;
8268
8269   if (path == NULL) return NULL;
8270   pathified = PerlMem_malloc(VMS_MAXRSS);
8271   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8272   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
8273     PerlMem_free(pathified);
8274     return NULL;
8275   }
8276
8277   vmsified = NULL;
8278   if (buf == NULL)
8279      Newx(vmsified, VMS_MAXRSS, char);
8280   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8281     PerlMem_free(pathified);
8282     if (vmsified) Safefree(vmsified);
8283     return NULL;
8284   }
8285   PerlMem_free(pathified);
8286   if (buf) {
8287     return buf;
8288   }
8289   else if (ts) {
8290     vmslen = strlen(vmsified);
8291     Newx(cp,vmslen+1,char);
8292     memcpy(cp,vmsified,vmslen);
8293     cp[vmslen] = '\0';
8294     Safefree(vmsified);
8295     return cp;
8296   }
8297   else {
8298     strcpy(__tovmspath_retbuf,vmsified);
8299     Safefree(vmsified);
8300     return __tovmspath_retbuf;
8301   }
8302
8303 }  /* end of do_tovmspath() */
8304 /*}}}*/
8305 /* External entry points */
8306 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8307   { return do_tovmspath(path,buf,0, NULL); }
8308 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8309   { return do_tovmspath(path,buf,1, NULL); }
8310 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8311   { return do_tovmspath(path,buf,0,utf8_fl); }
8312 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8313   { return do_tovmspath(path,buf,1,utf8_fl); }
8314
8315
8316 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8317 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8318   static char __tounixpath_retbuf[VMS_MAXRSS];
8319   int unixlen;
8320   char *pathified, *unixified, *cp;
8321
8322   if (path == NULL) return NULL;
8323   pathified = PerlMem_malloc(VMS_MAXRSS);
8324   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8325   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
8326     PerlMem_free(pathified);
8327     return NULL;
8328   }
8329
8330   unixified = NULL;
8331   if (buf == NULL) {
8332       Newx(unixified, VMS_MAXRSS, char);
8333   }
8334   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
8335     PerlMem_free(pathified);
8336     if (unixified) Safefree(unixified);
8337     return NULL;
8338   }
8339   PerlMem_free(pathified);
8340   if (buf) {
8341     return buf;
8342   }
8343   else if (ts) {
8344     unixlen = strlen(unixified);
8345     Newx(cp,unixlen+1,char);
8346     memcpy(cp,unixified,unixlen);
8347     cp[unixlen] = '\0';
8348     Safefree(unixified);
8349     return cp;
8350   }
8351   else {
8352     strcpy(__tounixpath_retbuf,unixified);
8353     Safefree(unixified);
8354     return __tounixpath_retbuf;
8355   }
8356
8357 }  /* end of do_tounixpath() */
8358 /*}}}*/
8359 /* External entry points */
8360 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8361   { return do_tounixpath(path,buf,0,NULL); }
8362 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8363   { return do_tounixpath(path,buf,1,NULL); }
8364 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8365   { return do_tounixpath(path,buf,0,utf8_fl); }
8366 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8367   { return do_tounixpath(path,buf,1,utf8_fl); }
8368
8369 /*
8370  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
8371  *
8372  *****************************************************************************
8373  *                                                                           *
8374  *  Copyright (C) 1989-1994, 2007 by                                         *
8375  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
8376  *                                                                           *
8377  *  Permission is hereby granted for the reproduction of this software       *
8378  *  on condition that this copyright notice is included in source            *
8379  *  distributions of the software.  The code may be modified and             *
8380  *  distributed under the same terms as Perl itself.                         *
8381  *                                                                           *
8382  *  27-Aug-1994 Modified for inclusion in perl5                              *
8383  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
8384  *****************************************************************************
8385  */
8386
8387 /*
8388  * getredirection() is intended to aid in porting C programs
8389  * to VMS (Vax-11 C).  The native VMS environment does not support
8390  * '>' and '<' I/O redirection, or command line wild card expansion,
8391  * or a command line pipe mechanism using the '|' AND background
8392  * command execution '&'.  All of these capabilities are provided to any
8393  * C program which calls this procedure as the first thing in the
8394  * main program.
8395  * The piping mechanism will probably work with almost any 'filter' type
8396  * of program.  With suitable modification, it may useful for other
8397  * portability problems as well.
8398  *
8399  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
8400  */
8401 struct list_item
8402     {
8403     struct list_item *next;
8404     char *value;
8405     };
8406
8407 static void add_item(struct list_item **head,
8408                      struct list_item **tail,
8409                      char *value,
8410                      int *count);
8411
8412 static void mp_expand_wild_cards(pTHX_ char *item,
8413                                 struct list_item **head,
8414                                 struct list_item **tail,
8415                                 int *count);
8416
8417 static int background_process(pTHX_ int argc, char **argv);
8418
8419 static void pipe_and_fork(pTHX_ char **cmargv);
8420
8421 /*{{{ void getredirection(int *ac, char ***av)*/
8422 static void
8423 mp_getredirection(pTHX_ int *ac, char ***av)
8424 /*
8425  * Process vms redirection arg's.  Exit if any error is seen.
8426  * If getredirection() processes an argument, it is erased
8427  * from the vector.  getredirection() returns a new argc and argv value.
8428  * In the event that a background command is requested (by a trailing "&"),
8429  * this routine creates a background subprocess, and simply exits the program.
8430  *
8431  * Warning: do not try to simplify the code for vms.  The code
8432  * presupposes that getredirection() is called before any data is
8433  * read from stdin or written to stdout.
8434  *
8435  * Normal usage is as follows:
8436  *
8437  *      main(argc, argv)
8438  *      int             argc;
8439  *      char            *argv[];
8440  *      {
8441  *              getredirection(&argc, &argv);
8442  *      }
8443  */
8444 {
8445     int                 argc = *ac;     /* Argument Count         */
8446     char                **argv = *av;   /* Argument Vector        */
8447     char                *ap;            /* Argument pointer       */
8448     int                 j;              /* argv[] index           */
8449     int                 item_count = 0; /* Count of Items in List */
8450     struct list_item    *list_head = 0; /* First Item in List       */
8451     struct list_item    *list_tail;     /* Last Item in List        */
8452     char                *in = NULL;     /* Input File Name          */
8453     char                *out = NULL;    /* Output File Name         */
8454     char                *outmode = "w"; /* Mode to Open Output File */
8455     char                *err = NULL;    /* Error File Name          */
8456     char                *errmode = "w"; /* Mode to Open Error File  */
8457     int                 cmargc = 0;     /* Piped Command Arg Count  */
8458     char                **cmargv = NULL;/* Piped Command Arg Vector */
8459
8460     /*
8461      * First handle the case where the last thing on the line ends with
8462      * a '&'.  This indicates the desire for the command to be run in a
8463      * subprocess, so we satisfy that desire.
8464      */
8465     ap = argv[argc-1];
8466     if (0 == strcmp("&", ap))
8467        exit(background_process(aTHX_ --argc, argv));
8468     if (*ap && '&' == ap[strlen(ap)-1])
8469         {
8470         ap[strlen(ap)-1] = '\0';
8471        exit(background_process(aTHX_ argc, argv));
8472         }
8473     /*
8474      * Now we handle the general redirection cases that involve '>', '>>',
8475      * '<', and pipes '|'.
8476      */
8477     for (j = 0; j < argc; ++j)
8478         {
8479         if (0 == strcmp("<", argv[j]))
8480             {
8481             if (j+1 >= argc)
8482                 {
8483                 fprintf(stderr,"No input file after < on command line");
8484                 exit(LIB$_WRONUMARG);
8485                 }
8486             in = argv[++j];
8487             continue;
8488             }
8489         if ('<' == *(ap = argv[j]))
8490             {
8491             in = 1 + ap;
8492             continue;
8493             }
8494         if (0 == strcmp(">", ap))
8495             {
8496             if (j+1 >= argc)
8497                 {
8498                 fprintf(stderr,"No output file after > on command line");
8499                 exit(LIB$_WRONUMARG);
8500                 }
8501             out = argv[++j];
8502             continue;
8503             }
8504         if ('>' == *ap)
8505             {
8506             if ('>' == ap[1])
8507                 {
8508                 outmode = "a";
8509                 if ('\0' == ap[2])
8510                     out = argv[++j];
8511                 else
8512                     out = 2 + ap;
8513                 }
8514             else
8515                 out = 1 + ap;
8516             if (j >= argc)
8517                 {
8518                 fprintf(stderr,"No output file after > or >> on command line");
8519                 exit(LIB$_WRONUMARG);
8520                 }
8521             continue;
8522             }
8523         if (('2' == *ap) && ('>' == ap[1]))
8524             {
8525             if ('>' == ap[2])
8526                 {
8527                 errmode = "a";
8528                 if ('\0' == ap[3])
8529                     err = argv[++j];
8530                 else
8531                     err = 3 + ap;
8532                 }
8533             else
8534                 if ('\0' == ap[2])
8535                     err = argv[++j];
8536                 else
8537                     err = 2 + ap;
8538             if (j >= argc)
8539                 {
8540                 fprintf(stderr,"No output file after 2> or 2>> on command line");
8541                 exit(LIB$_WRONUMARG);
8542                 }
8543             continue;
8544             }
8545         if (0 == strcmp("|", argv[j]))
8546             {
8547             if (j+1 >= argc)
8548                 {
8549                 fprintf(stderr,"No command into which to pipe on command line");
8550                 exit(LIB$_WRONUMARG);
8551                 }
8552             cmargc = argc-(j+1);
8553             cmargv = &argv[j+1];
8554             argc = j;
8555             continue;
8556             }
8557         if ('|' == *(ap = argv[j]))
8558             {
8559             ++argv[j];
8560             cmargc = argc-j;
8561             cmargv = &argv[j];
8562             argc = j;
8563             continue;
8564             }
8565         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
8566         }
8567     /*
8568      * Allocate and fill in the new argument vector, Some Unix's terminate
8569      * the list with an extra null pointer.
8570      */
8571     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
8572     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8573     *av = argv;
8574     for (j = 0; j < item_count; ++j, list_head = list_head->next)
8575         argv[j] = list_head->value;
8576     *ac = item_count;
8577     if (cmargv != NULL)
8578         {
8579         if (out != NULL)
8580             {
8581             fprintf(stderr,"'|' and '>' may not both be specified on command line");
8582             exit(LIB$_INVARGORD);
8583             }
8584         pipe_and_fork(aTHX_ cmargv);
8585         }
8586
8587     /* Check for input from a pipe (mailbox) */
8588
8589     if (in == NULL && 1 == isapipe(0))
8590         {
8591         char mbxname[L_tmpnam];
8592         long int bufsize;
8593         long int dvi_item = DVI$_DEVBUFSIZ;
8594         $DESCRIPTOR(mbxnam, "");
8595         $DESCRIPTOR(mbxdevnam, "");
8596
8597         /* Input from a pipe, reopen it in binary mode to disable       */
8598         /* carriage control processing.                                 */
8599
8600         fgetname(stdin, mbxname);
8601         mbxnam.dsc$a_pointer = mbxname;
8602         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
8603         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
8604         mbxdevnam.dsc$a_pointer = mbxname;
8605         mbxdevnam.dsc$w_length = sizeof(mbxname);
8606         dvi_item = DVI$_DEVNAM;
8607         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
8608         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
8609         set_errno(0);
8610         set_vaxc_errno(1);
8611         freopen(mbxname, "rb", stdin);
8612         if (errno != 0)
8613             {
8614             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
8615             exit(vaxc$errno);
8616             }
8617         }
8618     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
8619         {
8620         fprintf(stderr,"Can't open input file %s as stdin",in);
8621         exit(vaxc$errno);
8622         }
8623     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
8624         {
8625         fprintf(stderr,"Can't open output file %s as stdout",out);
8626         exit(vaxc$errno);
8627         }
8628         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
8629
8630     if (err != NULL) {
8631         if (strcmp(err,"&1") == 0) {
8632             dup2(fileno(stdout), fileno(stderr));
8633             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
8634         } else {
8635         FILE *tmperr;
8636         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
8637             {
8638             fprintf(stderr,"Can't open error file %s as stderr",err);
8639             exit(vaxc$errno);
8640             }
8641             fclose(tmperr);
8642            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
8643                 {
8644                 exit(vaxc$errno);
8645                 }
8646             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
8647         }
8648         }
8649 #ifdef ARGPROC_DEBUG
8650     PerlIO_printf(Perl_debug_log, "Arglist:\n");
8651     for (j = 0; j < *ac;  ++j)
8652         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
8653 #endif
8654    /* Clear errors we may have hit expanding wildcards, so they don't
8655       show up in Perl's $! later */
8656    set_errno(0); set_vaxc_errno(1);
8657 }  /* end of getredirection() */
8658 /*}}}*/
8659
8660 static void add_item(struct list_item **head,
8661                      struct list_item **tail,
8662                      char *value,
8663                      int *count)
8664 {
8665     if (*head == 0)
8666         {
8667         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8668         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8669         *tail = *head;
8670         }
8671     else {
8672         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8673         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8674         *tail = (*tail)->next;
8675         }
8676     (*tail)->value = value;
8677     ++(*count);
8678 }
8679
8680 static void mp_expand_wild_cards(pTHX_ char *item,
8681                               struct list_item **head,
8682                               struct list_item **tail,
8683                               int *count)
8684 {
8685 int expcount = 0;
8686 unsigned long int context = 0;
8687 int isunix = 0;
8688 int item_len = 0;
8689 char *had_version;
8690 char *had_device;
8691 int had_directory;
8692 char *devdir,*cp;
8693 char *vmsspec;
8694 $DESCRIPTOR(filespec, "");
8695 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
8696 $DESCRIPTOR(resultspec, "");
8697 unsigned long int lff_flags = 0;
8698 int sts;
8699 int rms_sts;
8700
8701 #ifdef VMS_LONGNAME_SUPPORT
8702     lff_flags = LIB$M_FIL_LONG_NAMES;
8703 #endif
8704
8705     for (cp = item; *cp; cp++) {
8706         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
8707         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
8708     }
8709     if (!*cp || isspace(*cp))
8710         {
8711         add_item(head, tail, item, count);
8712         return;
8713         }
8714     else
8715         {
8716      /* "double quoted" wild card expressions pass as is */
8717      /* From DCL that means using e.g.:                  */
8718      /* perl program """perl.*"""                        */
8719      item_len = strlen(item);
8720      if ( '"' == *item && '"' == item[item_len-1] )
8721        {
8722        item++;
8723        item[item_len-2] = '\0';
8724        add_item(head, tail, item, count);
8725        return;
8726        }
8727      }
8728     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
8729     resultspec.dsc$b_class = DSC$K_CLASS_D;
8730     resultspec.dsc$a_pointer = NULL;
8731     vmsspec = PerlMem_malloc(VMS_MAXRSS);
8732     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8733     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
8734       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
8735     if (!isunix || !filespec.dsc$a_pointer)
8736       filespec.dsc$a_pointer = item;
8737     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
8738     /*
8739      * Only return version specs, if the caller specified a version
8740      */
8741     had_version = strchr(item, ';');
8742     /*
8743      * Only return device and directory specs, if the caller specifed either.
8744      */
8745     had_device = strchr(item, ':');
8746     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
8747
8748     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
8749                                  (&filespec, &resultspec, &context,
8750                                   &defaultspec, 0, &rms_sts, &lff_flags)))
8751         {
8752         char *string;
8753         char *c;
8754
8755         string = PerlMem_malloc(resultspec.dsc$w_length+1);
8756         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8757         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
8758         string[resultspec.dsc$w_length] = '\0';
8759         if (NULL == had_version)
8760             *(strrchr(string, ';')) = '\0';
8761         if ((!had_directory) && (had_device == NULL))
8762             {
8763             if (NULL == (devdir = strrchr(string, ']')))
8764                 devdir = strrchr(string, '>');
8765             strcpy(string, devdir + 1);
8766             }
8767         /*
8768          * Be consistent with what the C RTL has already done to the rest of
8769          * the argv items and lowercase all of these names.
8770          */
8771         if (!decc_efs_case_preserve) {
8772             for (c = string; *c; ++c)
8773             if (isupper(*c))
8774                 *c = tolower(*c);
8775         }
8776         if (isunix) trim_unixpath(string,item,1);
8777         add_item(head, tail, string, count);
8778         ++expcount;
8779     }
8780     PerlMem_free(vmsspec);
8781     if (sts != RMS$_NMF)
8782         {
8783         set_vaxc_errno(sts);
8784         switch (sts)
8785             {
8786             case RMS$_FNF: case RMS$_DNF:
8787                 set_errno(ENOENT); break;
8788             case RMS$_DIR:
8789                 set_errno(ENOTDIR); break;
8790             case RMS$_DEV:
8791                 set_errno(ENODEV); break;
8792             case RMS$_FNM: case RMS$_SYN:
8793                 set_errno(EINVAL); break;
8794             case RMS$_PRV:
8795                 set_errno(EACCES); break;
8796             default:
8797                 _ckvmssts_noperl(sts);
8798             }
8799         }
8800     if (expcount == 0)
8801         add_item(head, tail, item, count);
8802     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
8803     _ckvmssts_noperl(lib$find_file_end(&context));
8804 }
8805
8806 static int child_st[2];/* Event Flag set when child process completes   */
8807
8808 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
8809
8810 static unsigned long int exit_handler(int *status)
8811 {
8812 short iosb[4];
8813
8814     if (0 == child_st[0])
8815         {
8816 #ifdef ARGPROC_DEBUG
8817         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
8818 #endif
8819         fflush(stdout);     /* Have to flush pipe for binary data to    */
8820                             /* terminate properly -- <tp@mccall.com>    */
8821         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
8822         sys$dassgn(child_chan);
8823         fclose(stdout);
8824         sys$synch(0, child_st);
8825         }
8826     return(1);
8827 }
8828
8829 static void sig_child(int chan)
8830 {
8831 #ifdef ARGPROC_DEBUG
8832     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
8833 #endif
8834     if (child_st[0] == 0)
8835         child_st[0] = 1;
8836 }
8837
8838 static struct exit_control_block exit_block =
8839     {
8840     0,
8841     exit_handler,
8842     1,
8843     &exit_block.exit_status,
8844     0
8845     };
8846
8847 static void
8848 pipe_and_fork(pTHX_ char **cmargv)
8849 {
8850     PerlIO *fp;
8851     struct dsc$descriptor_s *vmscmd;
8852     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
8853     int sts, j, l, ismcr, quote, tquote = 0;
8854
8855     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
8856     vms_execfree(vmscmd);
8857
8858     j = l = 0;
8859     p = subcmd;
8860     q = cmargv[0];
8861     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
8862               && toupper(*(q+2)) == 'R' && !*(q+3);
8863
8864     while (q && l < MAX_DCL_LINE_LENGTH) {
8865         if (!*q) {
8866             if (j > 0 && quote) {
8867                 *p++ = '"';
8868                 l++;
8869             }
8870             q = cmargv[++j];
8871             if (q) {
8872                 if (ismcr && j > 1) quote = 1;
8873                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
8874                 *p++ = ' ';
8875                 l++;
8876                 if (quote || tquote) {
8877                     *p++ = '"';
8878                     l++;
8879                 }
8880             }
8881         } else {
8882             if ((quote||tquote) && *q == '"') {
8883                 *p++ = '"';
8884                 l++;
8885             }
8886             *p++ = *q++;
8887             l++;
8888         }
8889     }
8890     *p = '\0';
8891
8892     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
8893     if (fp == Nullfp) {
8894         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
8895     }
8896 }
8897
8898 static int background_process(pTHX_ int argc, char **argv)
8899 {
8900 char command[MAX_DCL_SYMBOL + 1] = "$";
8901 $DESCRIPTOR(value, "");
8902 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
8903 static $DESCRIPTOR(null, "NLA0:");
8904 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
8905 char pidstring[80];
8906 $DESCRIPTOR(pidstr, "");
8907 int pid;
8908 unsigned long int flags = 17, one = 1, retsts;
8909 int len;
8910
8911     strcat(command, argv[0]);
8912     len = strlen(command);
8913     while (--argc && (len < MAX_DCL_SYMBOL))
8914         {
8915         strcat(command, " \"");
8916         strcat(command, *(++argv));
8917         strcat(command, "\"");
8918         len = strlen(command);
8919         }
8920     value.dsc$a_pointer = command;
8921     value.dsc$w_length = strlen(value.dsc$a_pointer);
8922     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
8923     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
8924     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
8925         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8926     }
8927     else {
8928         _ckvmssts_noperl(retsts);
8929     }
8930 #ifdef ARGPROC_DEBUG
8931     PerlIO_printf(Perl_debug_log, "%s\n", command);
8932 #endif
8933     sprintf(pidstring, "%08X", pid);
8934     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8935     pidstr.dsc$a_pointer = pidstring;
8936     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8937     lib$set_symbol(&pidsymbol, &pidstr);
8938     return(SS$_NORMAL);
8939 }
8940 /*}}}*/
8941 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8942
8943
8944 /* OS-specific initialization at image activation (not thread startup) */
8945 /* Older VAXC header files lack these constants */
8946 #ifndef JPI$_RIGHTS_SIZE
8947 #  define JPI$_RIGHTS_SIZE 817
8948 #endif
8949 #ifndef KGB$M_SUBSYSTEM
8950 #  define KGB$M_SUBSYSTEM 0x8
8951 #endif
8952
8953 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8954
8955 /*{{{void vms_image_init(int *, char ***)*/
8956 void
8957 vms_image_init(int *argcp, char ***argvp)
8958 {
8959   char eqv[LNM$C_NAMLENGTH+1] = "";
8960   unsigned int len, tabct = 8, tabidx = 0;
8961   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8962   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8963   unsigned short int dummy, rlen;
8964   struct dsc$descriptor_s **tabvec;
8965 #if defined(PERL_IMPLICIT_CONTEXT)
8966   pTHX = NULL;
8967 #endif
8968   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
8969                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
8970                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8971                                  {          0,                0,    0,      0} };
8972
8973 #ifdef KILL_BY_SIGPRC
8974     Perl_csighandler_init();
8975 #endif
8976
8977   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8978   _ckvmssts_noperl(iosb[0]);
8979   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8980     if (iprv[i]) {           /* Running image installed with privs? */
8981       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
8982       will_taint = TRUE;
8983       break;
8984     }
8985   }
8986   /* Rights identifiers might trigger tainting as well. */
8987   if (!will_taint && (rlen || rsz)) {
8988     while (rlen < rsz) {
8989       /* We didn't get all the identifiers on the first pass.  Allocate a
8990        * buffer much larger than $GETJPI wants (rsz is size in bytes that
8991        * were needed to hold all identifiers at time of last call; we'll
8992        * allocate that many unsigned long ints), and go back and get 'em.
8993        * If it gave us less than it wanted to despite ample buffer space,
8994        * something's broken.  Is your system missing a system identifier?
8995        */
8996       if (rsz <= jpilist[1].buflen) {
8997          /* Perl_croak accvios when used this early in startup. */
8998          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
8999                          rsz, (unsigned long) jpilist[1].buflen,
9000                          "Check your rights database for corruption.\n");
9001          exit(SS$_ABORT);
9002       }
9003       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9004       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9005       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9006       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9007       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9008       _ckvmssts_noperl(iosb[0]);
9009     }
9010     mask = jpilist[1].bufadr;
9011     /* Check attribute flags for each identifier (2nd longword); protected
9012      * subsystem identifiers trigger tainting.
9013      */
9014     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9015       if (mask[i] & KGB$M_SUBSYSTEM) {
9016         will_taint = TRUE;
9017         break;
9018       }
9019     }
9020     if (mask != rlst) PerlMem_free(mask);
9021   }
9022
9023   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9024    * logical, some versions of the CRTL will add a phanthom /000000/
9025    * directory.  This needs to be removed.
9026    */
9027   if (decc_filename_unix_report) {
9028   char * zeros;
9029   int ulen;
9030     ulen = strlen(argvp[0][0]);
9031     if (ulen > 7) {
9032       zeros = strstr(argvp[0][0], "/000000/");
9033       if (zeros != NULL) {
9034         int mlen;
9035         mlen = ulen - (zeros - argvp[0][0]) - 7;
9036         memmove(zeros, &zeros[7], mlen);
9037         ulen = ulen - 7;
9038         argvp[0][0][ulen] = '\0';
9039       }
9040     }
9041     /* It also may have a trailing dot that needs to be removed otherwise
9042      * it will be converted to VMS mode incorrectly.
9043      */
9044     ulen--;
9045     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9046       argvp[0][0][ulen] = '\0';
9047   }
9048
9049   /* We need to use this hack to tell Perl it should run with tainting,
9050    * since its tainting flag may be part of the PL_curinterp struct, which
9051    * hasn't been allocated when vms_image_init() is called.
9052    */
9053   if (will_taint) {
9054     char **newargv, **oldargv;
9055     oldargv = *argvp;
9056     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9057     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9058     newargv[0] = oldargv[0];
9059     newargv[1] = PerlMem_malloc(3 * sizeof(char));
9060     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9061     strcpy(newargv[1], "-T");
9062     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9063     (*argcp)++;
9064     newargv[*argcp] = NULL;
9065     /* We orphan the old argv, since we don't know where it's come from,
9066      * so we don't know how to free it.
9067      */
9068     *argvp = newargv;
9069   }
9070   else {  /* Did user explicitly request tainting? */
9071     int i;
9072     char *cp, **av = *argvp;
9073     for (i = 1; i < *argcp; i++) {
9074       if (*av[i] != '-') break;
9075       for (cp = av[i]+1; *cp; cp++) {
9076         if (*cp == 'T') { will_taint = 1; break; }
9077         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9078                   strchr("DFIiMmx",*cp)) break;
9079       }
9080       if (will_taint) break;
9081     }
9082   }
9083
9084   for (tabidx = 0;
9085        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9086        tabidx++) {
9087     if (!tabidx) {
9088       tabvec = (struct dsc$descriptor_s **)
9089             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9090       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9091     }
9092     else if (tabidx >= tabct) {
9093       tabct += 8;
9094       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9095       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9096     }
9097     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9098     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9099     tabvec[tabidx]->dsc$w_length  = 0;
9100     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9101     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
9102     tabvec[tabidx]->dsc$a_pointer = NULL;
9103     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9104   }
9105   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9106
9107   getredirection(argcp,argvp);
9108 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9109   {
9110 # include <reentrancy.h>
9111   decc$set_reentrancy(C$C_MULTITHREAD);
9112   }
9113 #endif
9114   return;
9115 }
9116 /*}}}*/
9117
9118
9119 /* trim_unixpath()
9120  * Trim Unix-style prefix off filespec, so it looks like what a shell
9121  * glob expansion would return (i.e. from specified prefix on, not
9122  * full path).  Note that returned filespec is Unix-style, regardless
9123  * of whether input filespec was VMS-style or Unix-style.
9124  *
9125  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9126  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9127  * vector of options; at present, only bit 0 is used, and if set tells
9128  * trim unixpath to try the current default directory as a prefix when
9129  * presented with a possibly ambiguous ... wildcard.
9130  *
9131  * Returns !=0 on success, with trimmed filespec replacing contents of
9132  * fspec, and 0 on failure, with contents of fpsec unchanged.
9133  */
9134 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9135 int
9136 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9137 {
9138   char *unixified, *unixwild,
9139        *template, *base, *end, *cp1, *cp2;
9140   register int tmplen, reslen = 0, dirs = 0;
9141
9142   unixwild = PerlMem_malloc(VMS_MAXRSS);
9143   if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
9144   if (!wildspec || !fspec) return 0;
9145   template = unixwild;
9146   if (strpbrk(wildspec,"]>:") != NULL) {
9147     if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
9148         PerlMem_free(unixwild);
9149         return 0;
9150     }
9151   }
9152   else {
9153     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
9154     unixwild[VMS_MAXRSS-1] = 0;
9155   }
9156   unixified = PerlMem_malloc(VMS_MAXRSS);
9157   if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
9158   if (strpbrk(fspec,"]>:") != NULL) {
9159     if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
9160         PerlMem_free(unixwild);
9161         PerlMem_free(unixified);
9162         return 0;
9163     }
9164     else base = unixified;
9165     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9166      * check to see that final result fits into (isn't longer than) fspec */
9167     reslen = strlen(fspec);
9168   }
9169   else base = fspec;
9170
9171   /* No prefix or absolute path on wildcard, so nothing to remove */
9172   if (!*template || *template == '/') {
9173     PerlMem_free(unixwild);
9174     if (base == fspec) {
9175         PerlMem_free(unixified);
9176         return 1;
9177     }
9178     tmplen = strlen(unixified);
9179     if (tmplen > reslen) {
9180         PerlMem_free(unixified);
9181         return 0;  /* not enough space */
9182     }
9183     /* Copy unixified resultant, including trailing NUL */
9184     memmove(fspec,unixified,tmplen+1);
9185     PerlMem_free(unixified);
9186     return 1;
9187   }
9188
9189   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
9190   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
9191     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
9192     for (cp1 = end ;cp1 >= base; cp1--)
9193       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9194         { cp1++; break; }
9195     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9196     PerlMem_free(unixified);
9197     PerlMem_free(unixwild);
9198     return 1;
9199   }
9200   else {
9201     char *tpl, *lcres;
9202     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9203     int ells = 1, totells, segdirs, match;
9204     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9205                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9206
9207     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9208     totells = ells;
9209     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9210     tpl = PerlMem_malloc(VMS_MAXRSS);
9211     if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
9212     if (ellipsis == template && opts & 1) {
9213       /* Template begins with an ellipsis.  Since we can't tell how many
9214        * directory names at the front of the resultant to keep for an
9215        * arbitrary starting point, we arbitrarily choose the current
9216        * default directory as a starting point.  If it's there as a prefix,
9217        * clip it off.  If not, fall through and act as if the leading
9218        * ellipsis weren't there (i.e. return shortest possible path that
9219        * could match template).
9220        */
9221       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9222           PerlMem_free(tpl);
9223           PerlMem_free(unixified);
9224           PerlMem_free(unixwild);
9225           return 0;
9226       }
9227       if (!decc_efs_case_preserve) {
9228         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9229           if (_tolower(*cp1) != _tolower(*cp2)) break;
9230       }
9231       segdirs = dirs - totells;  /* Min # of dirs we must have left */
9232       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9233       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9234         memmove(fspec,cp2+1,end - cp2);
9235         PerlMem_free(tpl);
9236         PerlMem_free(unixified);
9237         PerlMem_free(unixwild);
9238         return 1;
9239       }
9240     }
9241     /* First off, back up over constant elements at end of path */
9242     if (dirs) {
9243       for (front = end ; front >= base; front--)
9244          if (*front == '/' && !dirs--) { front++; break; }
9245     }
9246     lcres = PerlMem_malloc(VMS_MAXRSS);
9247     if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
9248     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9249          cp1++,cp2++) {
9250             if (!decc_efs_case_preserve) {
9251                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
9252             }
9253             else {
9254                 *cp2 = *cp1;
9255             }
9256     }
9257     if (cp1 != '\0') {
9258         PerlMem_free(tpl);
9259         PerlMem_free(unixified);
9260         PerlMem_free(unixwild);
9261         PerlMem_free(lcres);
9262         return 0;  /* Path too long. */
9263     }
9264     lcend = cp2;
9265     *cp2 = '\0';  /* Pick up with memcpy later */
9266     lcfront = lcres + (front - base);
9267     /* Now skip over each ellipsis and try to match the path in front of it. */
9268     while (ells--) {
9269       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
9270         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
9271             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
9272       if (cp1 < template) break; /* template started with an ellipsis */
9273       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9274         ellipsis = cp1; continue;
9275       }
9276       wilddsc.dsc$a_pointer = tpl;
9277       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9278       nextell = cp1;
9279       for (segdirs = 0, cp2 = tpl;
9280            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9281            cp1++, cp2++) {
9282          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9283          else {
9284             if (!decc_efs_case_preserve) {
9285               *cp2 = _tolower(*cp1);  /* else lowercase for match */
9286             }
9287             else {
9288               *cp2 = *cp1;  /* else preserve case for match */
9289             }
9290          }
9291          if (*cp2 == '/') segdirs++;
9292       }
9293       if (cp1 != ellipsis - 1) {
9294           PerlMem_free(tpl);
9295           PerlMem_free(unixified);
9296           PerlMem_free(unixwild);
9297           PerlMem_free(lcres);
9298           return 0; /* Path too long */
9299       }
9300       /* Back up at least as many dirs as in template before matching */
9301       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9302         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9303       for (match = 0; cp1 > lcres;) {
9304         resdsc.dsc$a_pointer = cp1;
9305         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9306           match++;
9307           if (match == 1) lcfront = cp1;
9308         }
9309         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9310       }
9311       if (!match) {
9312         PerlMem_free(tpl);
9313         PerlMem_free(unixified);
9314         PerlMem_free(unixwild);
9315         PerlMem_free(lcres);
9316         return 0;  /* Can't find prefix ??? */
9317       }
9318       if (match > 1 && opts & 1) {
9319         /* This ... wildcard could cover more than one set of dirs (i.e.
9320          * a set of similar dir names is repeated).  If the template
9321          * contains more than 1 ..., upstream elements could resolve the
9322          * ambiguity, but it's not worth a full backtracking setup here.
9323          * As a quick heuristic, clip off the current default directory
9324          * if it's present to find the trimmed spec, else use the
9325          * shortest string that this ... could cover.
9326          */
9327         char def[NAM$C_MAXRSS+1], *st;
9328
9329         if (getcwd(def, sizeof def,0) == NULL) {
9330             Safefree(unixified);
9331             Safefree(unixwild);
9332             Safefree(lcres);
9333             Safefree(tpl);
9334             return 0;
9335         }
9336         if (!decc_efs_case_preserve) {
9337           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9338             if (_tolower(*cp1) != _tolower(*cp2)) break;
9339         }
9340         segdirs = dirs - totells;  /* Min # of dirs we must have left */
9341         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9342         if (*cp1 == '\0' && *cp2 == '/') {
9343           memmove(fspec,cp2+1,end - cp2);
9344           PerlMem_free(tpl);
9345           PerlMem_free(unixified);
9346           PerlMem_free(unixwild);
9347           PerlMem_free(lcres);
9348           return 1;
9349         }
9350         /* Nope -- stick with lcfront from above and keep going. */
9351       }
9352     }
9353     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
9354     PerlMem_free(tpl);
9355     PerlMem_free(unixified);
9356     PerlMem_free(unixwild);
9357     PerlMem_free(lcres);
9358     return 1;
9359     ellipsis = nextell;
9360   }
9361
9362 }  /* end of trim_unixpath() */
9363 /*}}}*/
9364
9365
9366 /*
9367  *  VMS readdir() routines.
9368  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
9369  *
9370  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
9371  *  Minor modifications to original routines.
9372  */
9373
9374 /* readdir may have been redefined by reentr.h, so make sure we get
9375  * the local version for what we do here.
9376  */
9377 #ifdef readdir
9378 # undef readdir
9379 #endif
9380 #if !defined(PERL_IMPLICIT_CONTEXT)
9381 # define readdir Perl_readdir
9382 #else
9383 # define readdir(a) Perl_readdir(aTHX_ a)
9384 #endif
9385
9386     /* Number of elements in vms_versions array */
9387 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
9388
9389 /*
9390  *  Open a directory, return a handle for later use.
9391  */
9392 /*{{{ DIR *opendir(char*name) */
9393 DIR *
9394 Perl_opendir(pTHX_ const char *name)
9395 {
9396     DIR *dd;
9397     char *dir;
9398     Stat_t sb;
9399
9400     Newx(dir, VMS_MAXRSS, char);
9401     if (do_tovmspath(name,dir,0,NULL) == NULL) {
9402       Safefree(dir);
9403       return NULL;
9404     }
9405     /* Check access before stat; otherwise stat does not
9406      * accurately report whether it's a directory.
9407      */
9408     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
9409       /* cando_by_name has already set errno */
9410       Safefree(dir);
9411       return NULL;
9412     }
9413     if (flex_stat(dir,&sb) == -1) return NULL;
9414     if (!S_ISDIR(sb.st_mode)) {
9415       Safefree(dir);
9416       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
9417       return NULL;
9418     }
9419     /* Get memory for the handle, and the pattern. */
9420     Newx(dd,1,DIR);
9421     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
9422
9423     /* Fill in the fields; mainly playing with the descriptor. */
9424     sprintf(dd->pattern, "%s*.*",dir);
9425     Safefree(dir);
9426     dd->context = 0;
9427     dd->count = 0;
9428     dd->flags = 0;
9429     /* By saying we always want the result of readdir() in unix format, we
9430      * are really saying we want all the escapes removed.  Otherwise the caller,
9431      * having no way to know whether it's already in VMS format, might send it
9432      * through tovmsspec again, thus double escaping.
9433      */
9434     dd->flags = PERL_VMSDIR_M_UNIXSPECS;
9435     dd->pat.dsc$a_pointer = dd->pattern;
9436     dd->pat.dsc$w_length = strlen(dd->pattern);
9437     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
9438     dd->pat.dsc$b_class = DSC$K_CLASS_S;
9439 #if defined(USE_ITHREADS)
9440     Newx(dd->mutex,1,perl_mutex);
9441     MUTEX_INIT( (perl_mutex *) dd->mutex );
9442 #else
9443     dd->mutex = NULL;
9444 #endif
9445
9446     return dd;
9447 }  /* end of opendir() */
9448 /*}}}*/
9449
9450 /*
9451  *  Set the flag to indicate we want versions or not.
9452  */
9453 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
9454 void
9455 vmsreaddirversions(DIR *dd, int flag)
9456 {
9457     if (flag)
9458         dd->flags |= PERL_VMSDIR_M_VERSIONS;
9459     else
9460         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9461 }
9462 /*}}}*/
9463
9464 /*
9465  *  Free up an opened directory.
9466  */
9467 /*{{{ void closedir(DIR *dd)*/
9468 void
9469 Perl_closedir(DIR *dd)
9470 {
9471     int sts;
9472
9473     sts = lib$find_file_end(&dd->context);
9474     Safefree(dd->pattern);
9475 #if defined(USE_ITHREADS)
9476     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
9477     Safefree(dd->mutex);
9478 #endif
9479     Safefree(dd);
9480 }
9481 /*}}}*/
9482
9483 /*
9484  *  Collect all the version numbers for the current file.
9485  */
9486 static void
9487 collectversions(pTHX_ DIR *dd)
9488 {
9489     struct dsc$descriptor_s     pat;
9490     struct dsc$descriptor_s     res;
9491     struct dirent *e;
9492     char *p, *text, *buff;
9493     int i;
9494     unsigned long context, tmpsts;
9495
9496     /* Convenient shorthand. */
9497     e = &dd->entry;
9498
9499     /* Add the version wildcard, ignoring the "*.*" put on before */
9500     i = strlen(dd->pattern);
9501     Newx(text,i + e->d_namlen + 3,char);
9502     strcpy(text, dd->pattern);
9503     sprintf(&text[i - 3], "%s;*", e->d_name);
9504
9505     /* Set up the pattern descriptor. */
9506     pat.dsc$a_pointer = text;
9507     pat.dsc$w_length = i + e->d_namlen - 1;
9508     pat.dsc$b_dtype = DSC$K_DTYPE_T;
9509     pat.dsc$b_class = DSC$K_CLASS_S;
9510
9511     /* Set up result descriptor. */
9512     Newx(buff, VMS_MAXRSS, char);
9513     res.dsc$a_pointer = buff;
9514     res.dsc$w_length = VMS_MAXRSS - 1;
9515     res.dsc$b_dtype = DSC$K_DTYPE_T;
9516     res.dsc$b_class = DSC$K_CLASS_S;
9517
9518     /* Read files, collecting versions. */
9519     for (context = 0, e->vms_verscount = 0;
9520          e->vms_verscount < VERSIZE(e);
9521          e->vms_verscount++) {
9522         unsigned long rsts;
9523         unsigned long flags = 0;
9524
9525 #ifdef VMS_LONGNAME_SUPPORT
9526         flags = LIB$M_FIL_LONG_NAMES;
9527 #endif
9528         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
9529         if (tmpsts == RMS$_NMF || context == 0) break;
9530         _ckvmssts(tmpsts);
9531         buff[VMS_MAXRSS - 1] = '\0';
9532         if ((p = strchr(buff, ';')))
9533             e->vms_versions[e->vms_verscount] = atoi(p + 1);
9534         else
9535             e->vms_versions[e->vms_verscount] = -1;
9536     }
9537
9538     _ckvmssts(lib$find_file_end(&context));
9539     Safefree(text);
9540     Safefree(buff);
9541
9542 }  /* end of collectversions() */
9543
9544 /*
9545  *  Read the next entry from the directory.
9546  */
9547 /*{{{ struct dirent *readdir(DIR *dd)*/
9548 struct dirent *
9549 Perl_readdir(pTHX_ DIR *dd)
9550 {
9551     struct dsc$descriptor_s     res;
9552     char *p, *buff;
9553     unsigned long int tmpsts;
9554     unsigned long rsts;
9555     unsigned long flags = 0;
9556     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
9557     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
9558
9559     /* Set up result descriptor, and get next file. */
9560     Newx(buff, VMS_MAXRSS, char);
9561     res.dsc$a_pointer = buff;
9562     res.dsc$w_length = VMS_MAXRSS - 1;
9563     res.dsc$b_dtype = DSC$K_DTYPE_T;
9564     res.dsc$b_class = DSC$K_CLASS_S;
9565
9566 #ifdef VMS_LONGNAME_SUPPORT
9567     flags = LIB$M_FIL_LONG_NAMES;
9568 #endif
9569
9570     tmpsts = lib$find_file
9571         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
9572     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
9573     if (!(tmpsts & 1)) {
9574       set_vaxc_errno(tmpsts);
9575       switch (tmpsts) {
9576         case RMS$_PRV:
9577           set_errno(EACCES); break;
9578         case RMS$_DEV:
9579           set_errno(ENODEV); break;
9580         case RMS$_DIR:
9581           set_errno(ENOTDIR); break;
9582         case RMS$_FNF: case RMS$_DNF:
9583           set_errno(ENOENT); break;
9584         default:
9585           set_errno(EVMSERR);
9586       }
9587       Safefree(buff);
9588       return NULL;
9589     }
9590     dd->count++;
9591     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
9592     if (!decc_efs_case_preserve) {
9593       buff[VMS_MAXRSS - 1] = '\0';
9594       for (p = buff; *p; p++) *p = _tolower(*p);
9595     }
9596     else {
9597       /* we don't want to force to lowercase, just null terminate */
9598       buff[res.dsc$w_length] = '\0';
9599     }
9600     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
9601     *p = '\0';
9602
9603     /* Skip any directory component and just copy the name. */
9604     sts = vms_split_path
9605        (buff,
9606         &v_spec,
9607         &v_len,
9608         &r_spec,
9609         &r_len,
9610         &d_spec,
9611         &d_len,
9612         &n_spec,
9613         &n_len,
9614         &e_spec,
9615         &e_len,
9616         &vs_spec,
9617         &vs_len);
9618
9619     /* Drop NULL extensions on UNIX file specification */
9620     if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
9621         (e_len == 1) && decc_readdir_dropdotnotype)) {
9622         e_len = 0;
9623         e_spec[0] = '\0';
9624     }
9625
9626     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
9627     dd->entry.d_name[n_len + e_len] = '\0';
9628     dd->entry.d_namlen = strlen(dd->entry.d_name);
9629
9630     /* Convert the filename to UNIX format if needed */
9631     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
9632
9633         /* Translate the encoded characters. */
9634         /* Fixme: Unicode handling could result in embedded 0 characters */
9635         if (strchr(dd->entry.d_name, '^') != NULL) {
9636             char new_name[256];
9637             char * q;
9638             p = dd->entry.d_name;
9639             q = new_name;
9640             while (*p != 0) {
9641                 int inchars_read, outchars_added;
9642                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
9643                 p += inchars_read;
9644                 q += outchars_added;
9645                 /* fix-me */
9646                 /* if outchars_added > 1, then this is a wide file specification */
9647                 /* Wide file specifications need to be passed in Perl */
9648                 /* counted strings apparently with a Unicode flag */
9649             }
9650             *q = 0;
9651             strcpy(dd->entry.d_name, new_name);
9652             dd->entry.d_namlen = strlen(dd->entry.d_name);
9653         }
9654     }
9655
9656     dd->entry.vms_verscount = 0;
9657     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
9658     Safefree(buff);
9659     return &dd->entry;
9660
9661 }  /* end of readdir() */
9662 /*}}}*/
9663
9664 /*
9665  *  Read the next entry from the directory -- thread-safe version.
9666  */
9667 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
9668 int
9669 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
9670 {
9671     int retval;
9672
9673     MUTEX_LOCK( (perl_mutex *) dd->mutex );
9674
9675     entry = readdir(dd);
9676     *result = entry;
9677     retval = ( *result == NULL ? errno : 0 );
9678
9679     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
9680
9681     return retval;
9682
9683 }  /* end of readdir_r() */
9684 /*}}}*/
9685
9686 /*
9687  *  Return something that can be used in a seekdir later.
9688  */
9689 /*{{{ long telldir(DIR *dd)*/
9690 long
9691 Perl_telldir(DIR *dd)
9692 {
9693     return dd->count;
9694 }
9695 /*}}}*/
9696
9697 /*
9698  *  Return to a spot where we used to be.  Brute force.
9699  */
9700 /*{{{ void seekdir(DIR *dd,long count)*/
9701 void
9702 Perl_seekdir(pTHX_ DIR *dd, long count)
9703 {
9704     int old_flags;
9705
9706     /* If we haven't done anything yet... */
9707     if (dd->count == 0)
9708         return;
9709
9710     /* Remember some state, and clear it. */
9711     old_flags = dd->flags;
9712     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9713     _ckvmssts(lib$find_file_end(&dd->context));
9714     dd->context = 0;
9715
9716     /* The increment is in readdir(). */
9717     for (dd->count = 0; dd->count < count; )
9718         readdir(dd);
9719
9720     dd->flags = old_flags;
9721
9722 }  /* end of seekdir() */
9723 /*}}}*/
9724
9725 /* VMS subprocess management
9726  *
9727  * my_vfork() - just a vfork(), after setting a flag to record that
9728  * the current script is trying a Unix-style fork/exec.
9729  *
9730  * vms_do_aexec() and vms_do_exec() are called in response to the
9731  * perl 'exec' function.  If this follows a vfork call, then they
9732  * call out the regular perl routines in doio.c which do an
9733  * execvp (for those who really want to try this under VMS).
9734  * Otherwise, they do exactly what the perl docs say exec should
9735  * do - terminate the current script and invoke a new command
9736  * (See below for notes on command syntax.)
9737  *
9738  * do_aspawn() and do_spawn() implement the VMS side of the perl
9739  * 'system' function.
9740  *
9741  * Note on command arguments to perl 'exec' and 'system': When handled
9742  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
9743  * are concatenated to form a DCL command string.  If the first non-numeric
9744  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
9745  * the command string is handed off to DCL directly.  Otherwise,
9746  * the first token of the command is taken as the filespec of an image
9747  * to run.  The filespec is expanded using a default type of '.EXE' and
9748  * the process defaults for device, directory, etc., and if found, the resultant
9749  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
9750  * the command string as parameters.  This is perhaps a bit complicated,
9751  * but I hope it will form a happy medium between what VMS folks expect
9752  * from lib$spawn and what Unix folks expect from exec.
9753  */
9754
9755 static int vfork_called;
9756
9757 /*{{{int my_vfork()*/
9758 int
9759 my_vfork()
9760 {
9761   vfork_called++;
9762   return vfork();
9763 }
9764 /*}}}*/
9765
9766
9767 static void
9768 vms_execfree(struct dsc$descriptor_s *vmscmd)
9769 {
9770   if (vmscmd) {
9771       if (vmscmd->dsc$a_pointer) {
9772           PerlMem_free(vmscmd->dsc$a_pointer);
9773       }
9774       PerlMem_free(vmscmd);
9775   }
9776 }
9777
9778 static char *
9779 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
9780 {
9781   char *junk, *tmps = Nullch;
9782   register size_t cmdlen = 0;
9783   size_t rlen;
9784   register SV **idx;
9785   STRLEN n_a;
9786
9787   idx = mark;
9788   if (really) {
9789     tmps = SvPV(really,rlen);
9790     if (*tmps) {
9791       cmdlen += rlen + 1;
9792       idx++;
9793     }
9794   }
9795
9796   for (idx++; idx <= sp; idx++) {
9797     if (*idx) {
9798       junk = SvPVx(*idx,rlen);
9799       cmdlen += rlen ? rlen + 1 : 0;
9800     }
9801   }
9802   Newx(PL_Cmd, cmdlen+1, char);
9803
9804   if (tmps && *tmps) {
9805     strcpy(PL_Cmd,tmps);
9806     mark++;
9807   }
9808   else *PL_Cmd = '\0';
9809   while (++mark <= sp) {
9810     if (*mark) {
9811       char *s = SvPVx(*mark,n_a);
9812       if (!*s) continue;
9813       if (*PL_Cmd) strcat(PL_Cmd," ");
9814       strcat(PL_Cmd,s);
9815     }
9816   }
9817   return PL_Cmd;
9818
9819 }  /* end of setup_argstr() */
9820
9821
9822 static unsigned long int
9823 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
9824                    struct dsc$descriptor_s **pvmscmd)
9825 {
9826   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
9827   char image_name[NAM$C_MAXRSS+1];
9828   char image_argv[NAM$C_MAXRSS+1];
9829   $DESCRIPTOR(defdsc,".EXE");
9830   $DESCRIPTOR(defdsc2,".");
9831   $DESCRIPTOR(resdsc,resspec);
9832   struct dsc$descriptor_s *vmscmd;
9833   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9834   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
9835   register char *s, *rest, *cp, *wordbreak;
9836   char * cmd;
9837   int cmdlen;
9838   register int isdcl;
9839
9840   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9841   if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
9842
9843   /* Make a copy for modification */
9844   cmdlen = strlen(incmd);
9845   cmd = PerlMem_malloc(cmdlen+1);
9846   if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
9847   strncpy(cmd, incmd, cmdlen);
9848   cmd[cmdlen] = 0;
9849   image_name[0] = 0;
9850   image_argv[0] = 0;
9851
9852   vmscmd->dsc$a_pointer = NULL;
9853   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
9854   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
9855   vmscmd->dsc$w_length = 0;
9856   if (pvmscmd) *pvmscmd = vmscmd;
9857
9858   if (suggest_quote) *suggest_quote = 0;
9859
9860   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
9861     PerlMem_free(cmd);
9862     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
9863   }
9864
9865   s = cmd;
9866
9867   while (*s && isspace(*s)) s++;
9868
9869   if (*s == '@' || *s == '$') {
9870     vmsspec[0] = *s;  rest = s + 1;
9871     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
9872   }
9873   else { cp = vmsspec; rest = s; }
9874   if (*rest == '.' || *rest == '/') {
9875     char *cp2;
9876     for (cp2 = resspec;
9877          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
9878          rest++, cp2++) *cp2 = *rest;
9879     *cp2 = '\0';
9880     if (do_tovmsspec(resspec,cp,0,NULL)) {
9881       s = vmsspec;
9882       if (*rest) {
9883         for (cp2 = vmsspec + strlen(vmsspec);
9884              *rest && cp2 - vmsspec < sizeof vmsspec;
9885              rest++, cp2++) *cp2 = *rest;
9886         *cp2 = '\0';
9887       }
9888     }
9889   }
9890   /* Intuit whether verb (first word of cmd) is a DCL command:
9891    *   - if first nonspace char is '@', it's a DCL indirection
9892    * otherwise
9893    *   - if verb contains a filespec separator, it's not a DCL command
9894    *   - if it doesn't, caller tells us whether to default to a DCL
9895    *     command, or to a local image unless told it's DCL (by leading '$')
9896    */
9897   if (*s == '@') {
9898       isdcl = 1;
9899       if (suggest_quote) *suggest_quote = 1;
9900   } else {
9901     register char *filespec = strpbrk(s,":<[.;");
9902     rest = wordbreak = strpbrk(s," \"\t/");
9903     if (!wordbreak) wordbreak = s + strlen(s);
9904     if (*s == '$') check_img = 0;
9905     if (filespec && (filespec < wordbreak)) isdcl = 0;
9906     else isdcl = !check_img;
9907   }
9908
9909   if (!isdcl) {
9910     int rsts;
9911     imgdsc.dsc$a_pointer = s;
9912     imgdsc.dsc$w_length = wordbreak - s;
9913     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9914     if (!(retsts&1)) {
9915         _ckvmssts(lib$find_file_end(&cxt));
9916         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9917       if (!(retsts & 1) && *s == '$') {
9918         _ckvmssts(lib$find_file_end(&cxt));
9919         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
9920         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9921         if (!(retsts&1)) {
9922           _ckvmssts(lib$find_file_end(&cxt));
9923           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9924         }
9925       }
9926     }
9927     _ckvmssts(lib$find_file_end(&cxt));
9928
9929     if (retsts & 1) {
9930       FILE *fp;
9931       s = resspec;
9932       while (*s && !isspace(*s)) s++;
9933       *s = '\0';
9934
9935       /* check that it's really not DCL with no file extension */
9936       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9937       if (fp) {
9938         char b[256] = {0,0,0,0};
9939         read(fileno(fp), b, 256);
9940         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9941         if (isdcl) {
9942           int shebang_len;
9943
9944           /* Check for script */
9945           shebang_len = 0;
9946           if ((b[0] == '#') && (b[1] == '!'))
9947              shebang_len = 2;
9948 #ifdef ALTERNATE_SHEBANG
9949           else {
9950             shebang_len = strlen(ALTERNATE_SHEBANG);
9951             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9952               char * perlstr;
9953                 perlstr = strstr("perl",b);
9954                 if (perlstr == NULL)
9955                   shebang_len = 0;
9956             }
9957             else
9958               shebang_len = 0;
9959           }
9960 #endif
9961
9962           if (shebang_len > 0) {
9963           int i;
9964           int j;
9965           char tmpspec[NAM$C_MAXRSS + 1];
9966
9967             i = shebang_len;
9968              /* Image is following after white space */
9969             /*--------------------------------------*/
9970             while (isprint(b[i]) && isspace(b[i]))
9971                 i++;
9972
9973             j = 0;
9974             while (isprint(b[i]) && !isspace(b[i])) {
9975                 tmpspec[j++] = b[i++];
9976                 if (j >= NAM$C_MAXRSS)
9977                    break;
9978             }
9979             tmpspec[j] = '\0';
9980
9981              /* There may be some default parameters to the image */
9982             /*---------------------------------------------------*/
9983             j = 0;
9984             while (isprint(b[i])) {
9985                 image_argv[j++] = b[i++];
9986                 if (j >= NAM$C_MAXRSS)
9987                    break;
9988             }
9989             while ((j > 0) && !isprint(image_argv[j-1]))
9990                 j--;
9991             image_argv[j] = 0;
9992
9993             /* It will need to be converted to VMS format and validated */
9994             if (tmpspec[0] != '\0') {
9995               char * iname;
9996
9997                /* Try to find the exact program requested to be run */
9998               /*---------------------------------------------------*/
9999               iname = do_rmsexpand
10000                  (tmpspec, image_name, 0, ".exe",
10001                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10002               if (iname != NULL) {
10003                 if (cando_by_name_int
10004                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10005                   /* MCR prefix needed */
10006                   isdcl = 0;
10007                 }
10008                 else {
10009                    /* Try again with a null type */
10010                   /*----------------------------*/
10011                   iname = do_rmsexpand
10012                     (tmpspec, image_name, 0, ".",
10013                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10014                   if (iname != NULL) {
10015                     if (cando_by_name_int
10016                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10017                       /* MCR prefix needed */
10018                       isdcl = 0;
10019                     }
10020                   }
10021                 }
10022
10023                  /* Did we find the image to run the script? */
10024                 /*------------------------------------------*/
10025                 if (isdcl) {
10026                   char *tchr;
10027
10028                    /* Assume DCL or foreign command exists */
10029                   /*--------------------------------------*/
10030                   tchr = strrchr(tmpspec, '/');
10031                   if (tchr != NULL) {
10032                     tchr++;
10033                   }
10034                   else {
10035                     tchr = tmpspec;
10036                   }
10037                   strcpy(image_name, tchr);
10038                 }
10039               }
10040             }
10041           }
10042         }
10043         fclose(fp);
10044       }
10045       if (check_img && isdcl) return RMS$_FNF;
10046
10047       if (cando_by_name(S_IXUSR,0,resspec)) {
10048         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10049         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
10050         if (!isdcl) {
10051             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
10052             if (image_name[0] != 0) {
10053                 strcat(vmscmd->dsc$a_pointer, image_name);
10054                 strcat(vmscmd->dsc$a_pointer, " ");
10055             }
10056         } else if (image_name[0] != 0) {
10057             strcpy(vmscmd->dsc$a_pointer, image_name);
10058             strcat(vmscmd->dsc$a_pointer, " ");
10059         } else {
10060             strcpy(vmscmd->dsc$a_pointer,"@");
10061         }
10062         if (suggest_quote) *suggest_quote = 1;
10063
10064         /* If there is an image name, use original command */
10065         if (image_name[0] == 0)
10066             strcat(vmscmd->dsc$a_pointer,resspec);
10067         else {
10068             rest = cmd;
10069             while (*rest && isspace(*rest)) rest++;
10070         }
10071
10072         if (image_argv[0] != 0) {
10073           strcat(vmscmd->dsc$a_pointer,image_argv);
10074           strcat(vmscmd->dsc$a_pointer, " ");
10075         }
10076         if (rest) {
10077            int rest_len;
10078            int vmscmd_len;
10079
10080            rest_len = strlen(rest);
10081            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10082            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10083               strcat(vmscmd->dsc$a_pointer,rest);
10084            else
10085              retsts = CLI$_BUFOVF;
10086         }
10087         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10088         PerlMem_free(cmd);
10089         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10090       }
10091       else
10092         retsts = RMS$_PRV;
10093     }
10094   }
10095   /* It's either a DCL command or we couldn't find a suitable image */
10096   vmscmd->dsc$w_length = strlen(cmd);
10097
10098   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
10099   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
10100   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
10101
10102   PerlMem_free(cmd);
10103
10104   /* check if it's a symbol (for quoting purposes) */
10105   if (suggest_quote && !*suggest_quote) {
10106     int iss;
10107     char equiv[LNM$C_NAMLENGTH];
10108     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10109     eqvdsc.dsc$a_pointer = equiv;
10110
10111     iss = lib$get_symbol(vmscmd,&eqvdsc);
10112     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10113   }
10114   if (!(retsts & 1)) {
10115     /* just hand off status values likely to be due to user error */
10116     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10117         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10118        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10119     else { _ckvmssts(retsts); }
10120   }
10121
10122   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10123
10124 }  /* end of setup_cmddsc() */
10125
10126
10127 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10128 bool
10129 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10130 {
10131 bool exec_sts;
10132 char * cmd;
10133
10134   if (sp > mark) {
10135     if (vfork_called) {           /* this follows a vfork - act Unixish */
10136       vfork_called--;
10137       if (vfork_called < 0) {
10138         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10139         vfork_called = 0;
10140       }
10141       else return do_aexec(really,mark,sp);
10142     }
10143                                            /* no vfork - act VMSish */
10144     cmd = setup_argstr(aTHX_ really,mark,sp);
10145     exec_sts = vms_do_exec(cmd);
10146     Safefree(cmd);  /* Clean up from setup_argstr() */
10147     return exec_sts;
10148   }
10149
10150   return FALSE;
10151 }  /* end of vms_do_aexec() */
10152 /*}}}*/
10153
10154 /* {{{bool vms_do_exec(char *cmd) */
10155 bool
10156 Perl_vms_do_exec(pTHX_ const char *cmd)
10157 {
10158   struct dsc$descriptor_s *vmscmd;
10159
10160   if (vfork_called) {             /* this follows a vfork - act Unixish */
10161     vfork_called--;
10162     if (vfork_called < 0) {
10163       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10164       vfork_called = 0;
10165     }
10166     else return do_exec(cmd);
10167   }
10168
10169   {                               /* no vfork - act VMSish */
10170     unsigned long int retsts;
10171
10172     TAINT_ENV();
10173     TAINT_PROPER("exec");
10174     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10175       retsts = lib$do_command(vmscmd);
10176
10177     switch (retsts) {
10178       case RMS$_FNF: case RMS$_DNF:
10179         set_errno(ENOENT); break;
10180       case RMS$_DIR:
10181         set_errno(ENOTDIR); break;
10182       case RMS$_DEV:
10183         set_errno(ENODEV); break;
10184       case RMS$_PRV:
10185         set_errno(EACCES); break;
10186       case RMS$_SYN:
10187         set_errno(EINVAL); break;
10188       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10189         set_errno(E2BIG); break;
10190       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10191         _ckvmssts(retsts); /* fall through */
10192       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10193         set_errno(EVMSERR);
10194     }
10195     set_vaxc_errno(retsts);
10196     if (ckWARN(WARN_EXEC)) {
10197       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10198              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10199     }
10200     vms_execfree(vmscmd);
10201   }
10202
10203   return FALSE;
10204
10205 }  /* end of vms_do_exec() */
10206 /*}}}*/
10207
10208 unsigned long int Perl_do_spawn(pTHX_ const char *);
10209 unsigned long int do_spawn2(pTHX_ const char *, int);
10210
10211 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
10212 unsigned long int
10213 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
10214 {
10215 unsigned long int sts;
10216 char * cmd;
10217 int flags = 0;
10218
10219   if (sp > mark) {
10220
10221     /* We'll copy the (undocumented?) Win32 behavior and allow a
10222      * numeric first argument.  But the only value we'll support
10223      * through do_aspawn is a value of 1, which means spawn without
10224      * waiting for completion -- other values are ignored.
10225      */
10226     if (SvNIOKp(*((SV**)mark+1)) && !SvPOKp(*((SV**)mark+1))) {
10227         ++mark;
10228         flags = SvIVx(*(SV**)mark);
10229     }
10230
10231     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
10232         flags = CLI$M_NOWAIT;
10233     else
10234         flags = 0;
10235
10236     cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
10237     sts = do_spawn2(aTHX_ cmd, flags);
10238     /* pp_sys will clean up cmd */
10239     return sts;
10240   }
10241   return SS$_ABORT;
10242 }  /* end of do_aspawn() */
10243 /*}}}*/
10244
10245
10246 /* {{{unsigned long int do_spawn(char *cmd) */
10247 unsigned long int
10248 Perl_do_spawn(pTHX_ const char *cmd)
10249 {
10250     return do_spawn2(aTHX_ cmd, 0);
10251 }
10252 /*}}}*/
10253
10254 /* {{{unsigned long int do_spawn2(char *cmd) */
10255 unsigned long int
10256 do_spawn2(pTHX_ const char *cmd, int flags)
10257 {
10258   unsigned long int sts, substs;
10259
10260   /* The caller of this routine expects to Safefree(PL_Cmd) */
10261   Newx(PL_Cmd,10,char);
10262
10263   TAINT_ENV();
10264   TAINT_PROPER("spawn");
10265   if (!cmd || !*cmd) {
10266     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
10267     if (!(sts & 1)) {
10268       switch (sts) {
10269         case RMS$_FNF:  case RMS$_DNF:
10270           set_errno(ENOENT); break;
10271         case RMS$_DIR:
10272           set_errno(ENOTDIR); break;
10273         case RMS$_DEV:
10274           set_errno(ENODEV); break;
10275         case RMS$_PRV:
10276           set_errno(EACCES); break;
10277         case RMS$_SYN:
10278           set_errno(EINVAL); break;
10279         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10280           set_errno(E2BIG); break;
10281         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10282           _ckvmssts(sts); /* fall through */
10283         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10284           set_errno(EVMSERR);
10285       }
10286       set_vaxc_errno(sts);
10287       if (ckWARN(WARN_EXEC)) {
10288         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
10289                     Strerror(errno));
10290       }
10291     }
10292     sts = substs;
10293   }
10294   else {
10295     char mode[3];
10296     PerlIO * fp;
10297     if (flags & CLI$M_NOWAIT)
10298         strcpy(mode, "n");
10299     else
10300         strcpy(mode, "nW");
10301
10302     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
10303     if (fp != NULL)
10304       my_pclose(fp);
10305     /* sts will be the pid in the nowait case */
10306   }
10307   return sts;
10308 }  /* end of do_spawn2() */
10309 /*}}}*/
10310
10311
10312 static unsigned int *sockflags, sockflagsize;
10313
10314 /*
10315  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
10316  * routines found in some versions of the CRTL can't deal with sockets.
10317  * We don't shim the other file open routines since a socket isn't
10318  * likely to be opened by a name.
10319  */
10320 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
10321 FILE *my_fdopen(int fd, const char *mode)
10322 {
10323   FILE *fp = fdopen(fd, mode);
10324
10325   if (fp) {
10326     unsigned int fdoff = fd / sizeof(unsigned int);
10327     Stat_t sbuf; /* native stat; we don't need flex_stat */
10328     if (!sockflagsize || fdoff > sockflagsize) {
10329       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
10330       else           Newx  (sockflags,fdoff+2,unsigned int);
10331       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
10332       sockflagsize = fdoff + 2;
10333     }
10334     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
10335       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
10336   }
10337   return fp;
10338
10339 }
10340 /*}}}*/
10341
10342
10343 /*
10344  * Clear the corresponding bit when the (possibly) socket stream is closed.
10345  * There still a small hole: we miss an implicit close which might occur
10346  * via freopen().  >> Todo
10347  */
10348 /*{{{ int my_fclose(FILE *fp)*/
10349 int my_fclose(FILE *fp) {
10350   if (fp) {
10351     unsigned int fd = fileno(fp);
10352     unsigned int fdoff = fd / sizeof(unsigned int);
10353
10354     if (sockflagsize && fdoff <= sockflagsize)
10355       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
10356   }
10357   return fclose(fp);
10358 }
10359 /*}}}*/
10360
10361
10362 /*
10363  * A simple fwrite replacement which outputs itmsz*nitm chars without
10364  * introducing record boundaries every itmsz chars.
10365  * We are using fputs, which depends on a terminating null.  We may
10366  * well be writing binary data, so we need to accommodate not only
10367  * data with nulls sprinkled in the middle but also data with no null
10368  * byte at the end.
10369  */
10370 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
10371 int
10372 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
10373 {
10374   register char *cp, *end, *cpd, *data;
10375   register unsigned int fd = fileno(dest);
10376   register unsigned int fdoff = fd / sizeof(unsigned int);
10377   int retval;
10378   int bufsize = itmsz * nitm + 1;
10379
10380   if (fdoff < sockflagsize &&
10381       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
10382     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
10383     return nitm;
10384   }
10385
10386   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
10387   memcpy( data, src, itmsz*nitm );
10388   data[itmsz*nitm] = '\0';
10389
10390   end = data + itmsz * nitm;
10391   retval = (int) nitm; /* on success return # items written */
10392
10393   cpd = data;
10394   while (cpd <= end) {
10395     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
10396     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
10397     if (cp < end)
10398       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
10399     cpd = cp + 1;
10400   }
10401
10402   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
10403   return retval;
10404
10405 }  /* end of my_fwrite() */
10406 /*}}}*/
10407
10408 /*{{{ int my_flush(FILE *fp)*/
10409 int
10410 Perl_my_flush(pTHX_ FILE *fp)
10411 {
10412     int res;
10413     if ((res = fflush(fp)) == 0 && fp) {
10414 #ifdef VMS_DO_SOCKETS
10415         Stat_t s;
10416         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
10417 #endif
10418             res = fsync(fileno(fp));
10419     }
10420 /*
10421  * If the flush succeeded but set end-of-file, we need to clear
10422  * the error because our caller may check ferror().  BTW, this
10423  * probably means we just flushed an empty file.
10424  */
10425     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
10426
10427     return res;
10428 }
10429 /*}}}*/
10430
10431 /*
10432  * Here are replacements for the following Unix routines in the VMS environment:
10433  *      getpwuid    Get information for a particular UIC or UID
10434  *      getpwnam    Get information for a named user
10435  *      getpwent    Get information for each user in the rights database
10436  *      setpwent    Reset search to the start of the rights database
10437  *      endpwent    Finish searching for users in the rights database
10438  *
10439  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
10440  * (defined in pwd.h), which contains the following fields:-
10441  *      struct passwd {
10442  *              char        *pw_name;    Username (in lower case)
10443  *              char        *pw_passwd;  Hashed password
10444  *              unsigned int pw_uid;     UIC
10445  *              unsigned int pw_gid;     UIC group  number
10446  *              char        *pw_unixdir; Default device/directory (VMS-style)
10447  *              char        *pw_gecos;   Owner name
10448  *              char        *pw_dir;     Default device/directory (Unix-style)
10449  *              char        *pw_shell;   Default CLI name (eg. DCL)
10450  *      };
10451  * If the specified user does not exist, getpwuid and getpwnam return NULL.
10452  *
10453  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
10454  * not the UIC member number (eg. what's returned by getuid()),
10455  * getpwuid() can accept either as input (if uid is specified, the caller's
10456  * UIC group is used), though it won't recognise gid=0.
10457  *
10458  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
10459  * information about other users in your group or in other groups, respectively.
10460  * If the required privilege is not available, then these routines fill only
10461  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
10462  * string).
10463  *
10464  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
10465  */
10466
10467 /* sizes of various UAF record fields */
10468 #define UAI$S_USERNAME 12
10469 #define UAI$S_IDENT    31
10470 #define UAI$S_OWNER    31
10471 #define UAI$S_DEFDEV   31
10472 #define UAI$S_DEFDIR   63
10473 #define UAI$S_DEFCLI   31
10474 #define UAI$S_PWD       8
10475
10476 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
10477                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
10478                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
10479
10480 static char __empty[]= "";
10481 static struct passwd __passwd_empty=
10482     {(char *) __empty, (char *) __empty, 0, 0,
10483      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
10484 static int contxt= 0;
10485 static struct passwd __pwdcache;
10486 static char __pw_namecache[UAI$S_IDENT+1];
10487
10488 /*
10489  * This routine does most of the work extracting the user information.
10490  */
10491 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
10492 {
10493     static struct {
10494         unsigned char length;
10495         char pw_gecos[UAI$S_OWNER+1];
10496     } owner;
10497     static union uicdef uic;
10498     static struct {
10499         unsigned char length;
10500         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
10501     } defdev;
10502     static struct {
10503         unsigned char length;
10504         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
10505     } defdir;
10506     static struct {
10507         unsigned char length;
10508         char pw_shell[UAI$S_DEFCLI+1];
10509     } defcli;
10510     static char pw_passwd[UAI$S_PWD+1];
10511
10512     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
10513     struct dsc$descriptor_s name_desc;
10514     unsigned long int sts;
10515
10516     static struct itmlst_3 itmlst[]= {
10517         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
10518         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
10519         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
10520         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
10521         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
10522         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
10523         {0,                0,           NULL,    NULL}};
10524
10525     name_desc.dsc$w_length=  strlen(name);
10526     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
10527     name_desc.dsc$b_class=   DSC$K_CLASS_S;
10528     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
10529
10530 /*  Note that sys$getuai returns many fields as counted strings. */
10531     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
10532     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
10533       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
10534     }
10535     else { _ckvmssts(sts); }
10536     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
10537
10538     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
10539     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
10540     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
10541     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
10542     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
10543     owner.pw_gecos[lowner]=            '\0';
10544     defdev.pw_dir[ldefdev+ldefdir]= '\0';
10545     defcli.pw_shell[ldefcli]=          '\0';
10546     if (valid_uic(uic)) {
10547         pwd->pw_uid= uic.uic$l_uic;
10548         pwd->pw_gid= uic.uic$v_group;
10549     }
10550     else
10551       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
10552     pwd->pw_passwd=  pw_passwd;
10553     pwd->pw_gecos=   owner.pw_gecos;
10554     pwd->pw_dir=     defdev.pw_dir;
10555     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
10556     pwd->pw_shell=   defcli.pw_shell;
10557     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
10558         int ldir;
10559         ldir= strlen(pwd->pw_unixdir) - 1;
10560         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
10561     }
10562     else
10563         strcpy(pwd->pw_unixdir, pwd->pw_dir);
10564     if (!decc_efs_case_preserve)
10565         __mystrtolower(pwd->pw_unixdir);
10566     return 1;
10567 }
10568
10569 /*
10570  * Get information for a named user.
10571 */
10572 /*{{{struct passwd *getpwnam(char *name)*/
10573 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
10574 {
10575     struct dsc$descriptor_s name_desc;
10576     union uicdef uic;
10577     unsigned long int status, sts;
10578
10579     __pwdcache = __passwd_empty;
10580     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
10581       /* We still may be able to determine pw_uid and pw_gid */
10582       name_desc.dsc$w_length=  strlen(name);
10583       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
10584       name_desc.dsc$b_class=   DSC$K_CLASS_S;
10585       name_desc.dsc$a_pointer= (char *) name;
10586       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
10587         __pwdcache.pw_uid= uic.uic$l_uic;
10588         __pwdcache.pw_gid= uic.uic$v_group;
10589       }
10590       else {
10591         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
10592           set_vaxc_errno(sts);
10593           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
10594           return NULL;
10595         }
10596         else { _ckvmssts(sts); }
10597       }
10598     }
10599     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
10600     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
10601     __pwdcache.pw_name= __pw_namecache;
10602     return &__pwdcache;
10603 }  /* end of my_getpwnam() */
10604 /*}}}*/
10605
10606 /*
10607  * Get information for a particular UIC or UID.
10608  * Called by my_getpwent with uid=-1 to list all users.
10609 */
10610 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
10611 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
10612 {
10613     const $DESCRIPTOR(name_desc,__pw_namecache);
10614     unsigned short lname;
10615     union uicdef uic;
10616     unsigned long int status;
10617
10618     if (uid == (unsigned int) -1) {
10619       do {
10620         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
10621         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
10622           set_vaxc_errno(status);
10623           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10624           my_endpwent();
10625           return NULL;
10626         }
10627         else { _ckvmssts(status); }
10628       } while (!valid_uic (uic));
10629     }
10630     else {
10631       uic.uic$l_uic= uid;
10632       if (!uic.uic$v_group)
10633         uic.uic$v_group= PerlProc_getgid();
10634       if (valid_uic(uic))
10635         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
10636       else status = SS$_IVIDENT;
10637       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
10638           status == RMS$_PRV) {
10639         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10640         return NULL;
10641       }
10642       else { _ckvmssts(status); }
10643     }
10644     __pw_namecache[lname]= '\0';
10645     __mystrtolower(__pw_namecache);
10646
10647     __pwdcache = __passwd_empty;
10648     __pwdcache.pw_name = __pw_namecache;
10649
10650 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
10651     The identifier's value is usually the UIC, but it doesn't have to be,
10652     so if we can, we let fillpasswd update this. */
10653     __pwdcache.pw_uid =  uic.uic$l_uic;
10654     __pwdcache.pw_gid =  uic.uic$v_group;
10655
10656     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
10657     return &__pwdcache;
10658
10659 }  /* end of my_getpwuid() */
10660 /*}}}*/
10661
10662 /*
10663  * Get information for next user.
10664 */
10665 /*{{{struct passwd *my_getpwent()*/
10666 struct passwd *Perl_my_getpwent(pTHX)
10667 {
10668     return (my_getpwuid((unsigned int) -1));
10669 }
10670 /*}}}*/
10671
10672 /*
10673  * Finish searching rights database for users.
10674 */
10675 /*{{{void my_endpwent()*/
10676 void Perl_my_endpwent(pTHX)
10677 {
10678     if (contxt) {
10679       _ckvmssts(sys$finish_rdb(&contxt));
10680       contxt= 0;
10681     }
10682 }
10683 /*}}}*/
10684
10685 #ifdef HOMEGROWN_POSIX_SIGNALS
10686   /* Signal handling routines, pulled into the core from POSIX.xs.
10687    *
10688    * We need these for threads, so they've been rolled into the core,
10689    * rather than left in POSIX.xs.
10690    *
10691    * (DRS, Oct 23, 1997)
10692    */
10693
10694   /* sigset_t is atomic under VMS, so these routines are easy */
10695 /*{{{int my_sigemptyset(sigset_t *) */
10696 int my_sigemptyset(sigset_t *set) {
10697     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10698     *set = 0; return 0;
10699 }
10700 /*}}}*/
10701
10702
10703 /*{{{int my_sigfillset(sigset_t *)*/
10704 int my_sigfillset(sigset_t *set) {
10705     int i;
10706     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10707     for (i = 0; i < NSIG; i++) *set |= (1 << i);
10708     return 0;
10709 }
10710 /*}}}*/
10711
10712
10713 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
10714 int my_sigaddset(sigset_t *set, int sig) {
10715     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10716     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10717     *set |= (1 << (sig - 1));
10718     return 0;
10719 }
10720 /*}}}*/
10721
10722
10723 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
10724 int my_sigdelset(sigset_t *set, int sig) {
10725     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10726     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10727     *set &= ~(1 << (sig - 1));
10728     return 0;
10729 }
10730 /*}}}*/
10731
10732
10733 /*{{{int my_sigismember(sigset_t *set, int sig)*/
10734 int my_sigismember(sigset_t *set, int sig) {
10735     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10736     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10737     return *set & (1 << (sig - 1));
10738 }
10739 /*}}}*/
10740
10741
10742 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10743 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10744     sigset_t tempmask;
10745
10746     /* If set and oset are both null, then things are badly wrong. Bail out. */
10747     if ((oset == NULL) && (set == NULL)) {
10748       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
10749       return -1;
10750     }
10751
10752     /* If set's null, then we're just handling a fetch. */
10753     if (set == NULL) {
10754         tempmask = sigblock(0);
10755     }
10756     else {
10757       switch (how) {
10758       case SIG_SETMASK:
10759         tempmask = sigsetmask(*set);
10760         break;
10761       case SIG_BLOCK:
10762         tempmask = sigblock(*set);
10763         break;
10764       case SIG_UNBLOCK:
10765         tempmask = sigblock(0);
10766         sigsetmask(*oset & ~tempmask);
10767         break;
10768       default:
10769         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10770         return -1;
10771       }
10772     }
10773
10774     /* Did they pass us an oset? If so, stick our holding mask into it */
10775     if (oset)
10776       *oset = tempmask;
10777
10778     return 0;
10779 }
10780 /*}}}*/
10781 #endif  /* HOMEGROWN_POSIX_SIGNALS */
10782
10783
10784 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
10785  * my_utime(), and flex_stat(), all of which operate on UTC unless
10786  * VMSISH_TIMES is true.
10787  */
10788 /* method used to handle UTC conversions:
10789  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
10790  */
10791 static int gmtime_emulation_type;
10792 /* number of secs to add to UTC POSIX-style time to get local time */
10793 static long int utc_offset_secs;
10794
10795 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
10796  * in vmsish.h.  #undef them here so we can call the CRTL routines
10797  * directly.
10798  */
10799 #undef gmtime
10800 #undef localtime
10801 #undef time
10802
10803
10804 /*
10805  * DEC C previous to 6.0 corrupts the behavior of the /prefix
10806  * qualifier with the extern prefix pragma.  This provisional
10807  * hack circumvents this prefix pragma problem in previous
10808  * precompilers.
10809  */
10810 #if defined(__VMS_VER) && __VMS_VER >= 70000000
10811 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
10812 #    pragma __extern_prefix save
10813 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
10814 #    define gmtime decc$__utctz_gmtime
10815 #    define localtime decc$__utctz_localtime
10816 #    define time decc$__utc_time
10817 #    pragma __extern_prefix restore
10818
10819      struct tm *gmtime(), *localtime();
10820
10821 #  endif
10822 #endif
10823
10824
10825 static time_t toutc_dst(time_t loc) {
10826   struct tm *rsltmp;
10827
10828   if ((rsltmp = localtime(&loc)) == NULL) return -1;
10829   loc -= utc_offset_secs;
10830   if (rsltmp->tm_isdst) loc -= 3600;
10831   return loc;
10832 }
10833 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10834        ((gmtime_emulation_type || my_time(NULL)), \
10835        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
10836        ((secs) - utc_offset_secs))))
10837
10838 static time_t toloc_dst(time_t utc) {
10839   struct tm *rsltmp;
10840
10841   utc += utc_offset_secs;
10842   if ((rsltmp = localtime(&utc)) == NULL) return -1;
10843   if (rsltmp->tm_isdst) utc += 3600;
10844   return utc;
10845 }
10846 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10847        ((gmtime_emulation_type || my_time(NULL)), \
10848        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
10849        ((secs) + utc_offset_secs))))
10850
10851 #ifndef RTL_USES_UTC
10852 /*
10853
10854     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
10855         DST starts on 1st sun of april      at 02:00  std time
10856             ends on last sun of october     at 02:00  dst time
10857     see the UCX management command reference, SET CONFIG TIMEZONE
10858     for formatting info.
10859
10860     No, it's not as general as it should be, but then again, NOTHING
10861     will handle UK times in a sensible way.
10862 */
10863
10864
10865 /*
10866     parse the DST start/end info:
10867     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
10868 */
10869
10870 static char *
10871 tz_parse_startend(char *s, struct tm *w, int *past)
10872 {
10873     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
10874     int ly, dozjd, d, m, n, hour, min, sec, j, k;
10875     time_t g;
10876
10877     if (!s)    return 0;
10878     if (!w) return 0;
10879     if (!past) return 0;
10880
10881     ly = 0;
10882     if (w->tm_year % 4        == 0) ly = 1;
10883     if (w->tm_year % 100      == 0) ly = 0;
10884     if (w->tm_year+1900 % 400 == 0) ly = 1;
10885     if (ly) dinm[1]++;
10886
10887     dozjd = isdigit(*s);
10888     if (*s == 'J' || *s == 'j' || dozjd) {
10889         if (!dozjd && !isdigit(*++s)) return 0;
10890         d = *s++ - '0';
10891         if (isdigit(*s)) {
10892             d = d*10 + *s++ - '0';
10893             if (isdigit(*s)) {
10894                 d = d*10 + *s++ - '0';
10895             }
10896         }
10897         if (d == 0) return 0;
10898         if (d > 366) return 0;
10899         d--;
10900         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
10901         g = d * 86400;
10902         dozjd = 1;
10903     } else if (*s == 'M' || *s == 'm') {
10904         if (!isdigit(*++s)) return 0;
10905         m = *s++ - '0';
10906         if (isdigit(*s)) m = 10*m + *s++ - '0';
10907         if (*s != '.') return 0;
10908         if (!isdigit(*++s)) return 0;
10909         n = *s++ - '0';
10910         if (n < 1 || n > 5) return 0;
10911         if (*s != '.') return 0;
10912         if (!isdigit(*++s)) return 0;
10913         d = *s++ - '0';
10914         if (d > 6) return 0;
10915     }
10916
10917     if (*s == '/') {
10918         if (!isdigit(*++s)) return 0;
10919         hour = *s++ - '0';
10920         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
10921         if (*s == ':') {
10922             if (!isdigit(*++s)) return 0;
10923             min = *s++ - '0';
10924             if (isdigit(*s)) min = 10*min + *s++ - '0';
10925             if (*s == ':') {
10926                 if (!isdigit(*++s)) return 0;
10927                 sec = *s++ - '0';
10928                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
10929             }
10930         }
10931     } else {
10932         hour = 2;
10933         min = 0;
10934         sec = 0;
10935     }
10936
10937     if (dozjd) {
10938         if (w->tm_yday < d) goto before;
10939         if (w->tm_yday > d) goto after;
10940     } else {
10941         if (w->tm_mon+1 < m) goto before;
10942         if (w->tm_mon+1 > m) goto after;
10943
10944         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
10945         k = d - j; /* mday of first d */
10946         if (k <= 0) k += 7;
10947         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
10948         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
10949         if (w->tm_mday < k) goto before;
10950         if (w->tm_mday > k) goto after;
10951     }
10952
10953     if (w->tm_hour < hour) goto before;
10954     if (w->tm_hour > hour) goto after;
10955     if (w->tm_min  < min)  goto before;
10956     if (w->tm_min  > min)  goto after;
10957     if (w->tm_sec  < sec)  goto before;
10958     goto after;
10959
10960 before:
10961     *past = 0;
10962     return s;
10963 after:
10964     *past = 1;
10965     return s;
10966 }
10967
10968
10969
10970
10971 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
10972
10973 static char *
10974 tz_parse_offset(char *s, int *offset)
10975 {
10976     int hour = 0, min = 0, sec = 0;
10977     int neg = 0;
10978     if (!s) return 0;
10979     if (!offset) return 0;
10980
10981     if (*s == '-') {neg++; s++;}
10982     if (*s == '+') s++;
10983     if (!isdigit(*s)) return 0;
10984     hour = *s++ - '0';
10985     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10986     if (hour > 24) return 0;
10987     if (*s == ':') {
10988         if (!isdigit(*++s)) return 0;
10989         min = *s++ - '0';
10990         if (isdigit(*s)) min = min*10 + (*s++ - '0');
10991         if (min > 59) return 0;
10992         if (*s == ':') {
10993             if (!isdigit(*++s)) return 0;
10994             sec = *s++ - '0';
10995             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10996             if (sec > 59) return 0;
10997         }
10998     }
10999
11000     *offset = (hour*60+min)*60 + sec;
11001     if (neg) *offset = -*offset;
11002     return s;
11003 }
11004
11005 /*
11006     input time is w, whatever type of time the CRTL localtime() uses.
11007     sets dst, the zone, and the gmtoff (seconds)
11008
11009     caches the value of TZ and UCX$TZ env variables; note that
11010     my_setenv looks for these and sets a flag if they're changed
11011     for efficiency.
11012
11013     We have to watch out for the "australian" case (dst starts in
11014     october, ends in april)...flagged by "reverse" and checked by
11015     scanning through the months of the previous year.
11016
11017 */
11018
11019 static int
11020 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
11021 {
11022     time_t when;
11023     struct tm *w2;
11024     char *s,*s2;
11025     char *dstzone, *tz, *s_start, *s_end;
11026     int std_off, dst_off, isdst;
11027     int y, dststart, dstend;
11028     static char envtz[1025];  /* longer than any logical, symbol, ... */
11029     static char ucxtz[1025];
11030     static char reversed = 0;
11031
11032     if (!w) return 0;
11033
11034     if (tz_updated) {
11035         tz_updated = 0;
11036         reversed = -1;  /* flag need to check  */
11037         envtz[0] = ucxtz[0] = '\0';
11038         tz = my_getenv("TZ",0);
11039         if (tz) strcpy(envtz, tz);
11040         tz = my_getenv("UCX$TZ",0);
11041         if (tz) strcpy(ucxtz, tz);
11042         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
11043     }
11044     tz = envtz;
11045     if (!*tz) tz = ucxtz;
11046
11047     s = tz;
11048     while (isalpha(*s)) s++;
11049     s = tz_parse_offset(s, &std_off);
11050     if (!s) return 0;
11051     if (!*s) {                  /* no DST, hurray we're done! */
11052         isdst = 0;
11053         goto done;
11054     }
11055
11056     dstzone = s;
11057     while (isalpha(*s)) s++;
11058     s2 = tz_parse_offset(s, &dst_off);
11059     if (s2) {
11060         s = s2;
11061     } else {
11062         dst_off = std_off - 3600;
11063     }
11064
11065     if (!*s) {      /* default dst start/end?? */
11066         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
11067             s = strchr(ucxtz,',');
11068         }
11069         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
11070     }
11071     if (*s != ',') return 0;
11072
11073     when = *w;
11074     when = _toutc(when);      /* convert to utc */
11075     when = when - std_off;    /* convert to pseudolocal time*/
11076
11077     w2 = localtime(&when);
11078     y = w2->tm_year;
11079     s_start = s+1;
11080     s = tz_parse_startend(s_start,w2,&dststart);
11081     if (!s) return 0;
11082     if (*s != ',') return 0;
11083
11084     when = *w;
11085     when = _toutc(when);      /* convert to utc */
11086     when = when - dst_off;    /* convert to pseudolocal time*/
11087     w2 = localtime(&when);
11088     if (w2->tm_year != y) {   /* spans a year, just check one time */
11089         when += dst_off - std_off;
11090         w2 = localtime(&when);
11091     }
11092     s_end = s+1;
11093     s = tz_parse_startend(s_end,w2,&dstend);
11094     if (!s) return 0;
11095
11096     if (reversed == -1) {  /* need to check if start later than end */
11097         int j, ds, de;
11098
11099         when = *w;
11100         if (when < 2*365*86400) {
11101             when += 2*365*86400;
11102         } else {
11103             when -= 365*86400;
11104         }
11105         w2 =localtime(&when);
11106         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
11107
11108         for (j = 0; j < 12; j++) {
11109             w2 =localtime(&when);
11110             tz_parse_startend(s_start,w2,&ds);
11111             tz_parse_startend(s_end,w2,&de);
11112             if (ds != de) break;
11113             when += 30*86400;
11114         }
11115         reversed = 0;
11116         if (de && !ds) reversed = 1;
11117     }
11118
11119     isdst = dststart && !dstend;
11120     if (reversed) isdst = dststart  || !dstend;
11121
11122 done:
11123     if (dst)    *dst = isdst;
11124     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
11125     if (isdst)  tz = dstzone;
11126     if (zone) {
11127         while(isalpha(*tz))  *zone++ = *tz++;
11128         *zone = '\0';
11129     }
11130     return 1;
11131 }
11132
11133 #endif /* !RTL_USES_UTC */
11134
11135 /* my_time(), my_localtime(), my_gmtime()
11136  * By default traffic in UTC time values, using CRTL gmtime() or
11137  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11138  * Note: We need to use these functions even when the CRTL has working
11139  * UTC support, since they also handle C<use vmsish qw(times);>
11140  *
11141  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
11142  * Modified by Charles Bailey <bailey@newman.upenn.edu>
11143  */
11144
11145 /*{{{time_t my_time(time_t *timep)*/
11146 time_t Perl_my_time(pTHX_ time_t *timep)
11147 {
11148   time_t when;
11149   struct tm *tm_p;
11150
11151   if (gmtime_emulation_type == 0) {
11152     int dstnow;
11153     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
11154                               /* results of calls to gmtime() and localtime() */
11155                               /* for same &base */
11156
11157     gmtime_emulation_type++;
11158     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11159       char off[LNM$C_NAMLENGTH+1];;
11160
11161       gmtime_emulation_type++;
11162       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11163         gmtime_emulation_type++;
11164         utc_offset_secs = 0;
11165         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11166       }
11167       else { utc_offset_secs = atol(off); }
11168     }
11169     else { /* We've got a working gmtime() */
11170       struct tm gmt, local;
11171
11172       gmt = *tm_p;
11173       tm_p = localtime(&base);
11174       local = *tm_p;
11175       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
11176       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11177       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
11178       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
11179     }
11180   }
11181
11182   when = time(NULL);
11183 # ifdef VMSISH_TIME
11184 # ifdef RTL_USES_UTC
11185   if (VMSISH_TIME) when = _toloc(when);
11186 # else
11187   if (!VMSISH_TIME) when = _toutc(when);
11188 # endif
11189 # endif
11190   if (timep != NULL) *timep = when;
11191   return when;
11192
11193 }  /* end of my_time() */
11194 /*}}}*/
11195
11196
11197 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11198 struct tm *
11199 Perl_my_gmtime(pTHX_ const time_t *timep)
11200 {
11201   char *p;
11202   time_t when;
11203   struct tm *rsltmp;
11204
11205   if (timep == NULL) {
11206     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11207     return NULL;
11208   }
11209   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11210
11211   when = *timep;
11212 # ifdef VMSISH_TIME
11213   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11214 #  endif
11215 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
11216   return gmtime(&when);
11217 # else
11218   /* CRTL localtime() wants local time as input, so does no tz correction */
11219   rsltmp = localtime(&when);
11220   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
11221   return rsltmp;
11222 #endif
11223 }  /* end of my_gmtime() */
11224 /*}}}*/
11225
11226
11227 /*{{{struct tm *my_localtime(const time_t *timep)*/
11228 struct tm *
11229 Perl_my_localtime(pTHX_ const time_t *timep)
11230 {
11231   time_t when, whenutc;
11232   struct tm *rsltmp;
11233   int dst, offset;
11234
11235   if (timep == NULL) {
11236     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11237     return NULL;
11238   }
11239   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11240   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11241
11242   when = *timep;
11243 # ifdef RTL_USES_UTC
11244 # ifdef VMSISH_TIME
11245   if (VMSISH_TIME) when = _toutc(when);
11246 # endif
11247   /* CRTL localtime() wants UTC as input, does tz correction itself */
11248   return localtime(&when);
11249
11250 # else /* !RTL_USES_UTC */
11251   whenutc = when;
11252 # ifdef VMSISH_TIME
11253   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
11254   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
11255 # endif
11256   dst = -1;
11257 #ifndef RTL_USES_UTC
11258   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
11259       when = whenutc - offset;                   /* pseudolocal time*/
11260   }
11261 # endif
11262   /* CRTL localtime() wants local time as input, so does no tz correction */
11263   rsltmp = localtime(&when);
11264   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
11265   return rsltmp;
11266 # endif
11267
11268 } /*  end of my_localtime() */
11269 /*}}}*/
11270
11271 /* Reset definitions for later calls */
11272 #define gmtime(t)    my_gmtime(t)
11273 #define localtime(t) my_localtime(t)
11274 #define time(t)      my_time(t)
11275
11276
11277 /* my_utime - update modification/access time of a file
11278  *
11279  * VMS 7.3 and later implementation
11280  * Only the UTC translation is home-grown. The rest is handled by the
11281  * CRTL utime(), which will take into account the relevant feature
11282  * logicals and ODS-5 volume characteristics for true access times.
11283  *
11284  * pre VMS 7.3 implementation:
11285  * The calling sequence is identical to POSIX utime(), but under
11286  * VMS with ODS-2, only the modification time is changed; ODS-2 does
11287  * not maintain access times.  Restrictions differ from the POSIX
11288  * definition in that the time can be changed as long as the
11289  * caller has permission to execute the necessary IO$_MODIFY $QIO;
11290  * no separate checks are made to insure that the caller is the
11291  * owner of the file or has special privs enabled.
11292  * Code here is based on Joe Meadows' FILE utility.
11293  *
11294  */
11295
11296 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11297  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
11298  * in 100 ns intervals.
11299  */
11300 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11301
11302 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11303 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11304 {
11305 #if __CRTL_VER >= 70300000
11306   struct utimbuf utc_utimes, *utc_utimesp;
11307
11308   if (utimes != NULL) {
11309     utc_utimes.actime = utimes->actime;
11310     utc_utimes.modtime = utimes->modtime;
11311 # ifdef VMSISH_TIME
11312     /* If input was local; convert to UTC for sys svc */
11313     if (VMSISH_TIME) {
11314       utc_utimes.actime = _toutc(utimes->actime);
11315       utc_utimes.modtime = _toutc(utimes->modtime);
11316     }
11317 # endif
11318     utc_utimesp = &utc_utimes;
11319   }
11320   else {
11321     utc_utimesp = NULL;
11322   }
11323
11324   return utime(file, utc_utimesp);
11325
11326 #else /* __CRTL_VER < 70300000 */
11327
11328   register int i;
11329   int sts;
11330   long int bintime[2], len = 2, lowbit, unixtime,
11331            secscale = 10000000; /* seconds --> 100 ns intervals */
11332   unsigned long int chan, iosb[2], retsts;
11333   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11334   struct FAB myfab = cc$rms_fab;
11335   struct NAM mynam = cc$rms_nam;
11336 #if defined (__DECC) && defined (__VAX)
11337   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11338    * at least through VMS V6.1, which causes a type-conversion warning.
11339    */
11340 #  pragma message save
11341 #  pragma message disable cvtdiftypes
11342 #endif
11343   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11344   struct fibdef myfib;
11345 #if defined (__DECC) && defined (__VAX)
11346   /* This should be right after the declaration of myatr, but due
11347    * to a bug in VAX DEC C, this takes effect a statement early.
11348    */
11349 #  pragma message restore
11350 #endif
11351   /* cast ok for read only parameter */
11352   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11353                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11354                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
11355
11356   if (file == NULL || *file == '\0') {
11357     SETERRNO(ENOENT, LIB$_INVARG);
11358     return -1;
11359   }
11360
11361   /* Convert to VMS format ensuring that it will fit in 255 characters */
11362   if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
11363       SETERRNO(ENOENT, LIB$_INVARG);
11364       return -1;
11365   }
11366   if (utimes != NULL) {
11367     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
11368      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11369      * Since time_t is unsigned long int, and lib$emul takes a signed long int
11370      * as input, we force the sign bit to be clear by shifting unixtime right
11371      * one bit, then multiplying by an extra factor of 2 in lib$emul().
11372      */
11373     lowbit = (utimes->modtime & 1) ? secscale : 0;
11374     unixtime = (long int) utimes->modtime;
11375 #   ifdef VMSISH_TIME
11376     /* If input was UTC; convert to local for sys svc */
11377     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
11378 #   endif
11379     unixtime >>= 1;  secscale <<= 1;
11380     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11381     if (!(retsts & 1)) {
11382       SETERRNO(EVMSERR, retsts);
11383       return -1;
11384     }
11385     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11386     if (!(retsts & 1)) {
11387       SETERRNO(EVMSERR, retsts);
11388       return -1;
11389     }
11390   }
11391   else {
11392     /* Just get the current time in VMS format directly */
11393     retsts = sys$gettim(bintime);
11394     if (!(retsts & 1)) {
11395       SETERRNO(EVMSERR, retsts);
11396       return -1;
11397     }
11398   }
11399
11400   myfab.fab$l_fna = vmsspec;
11401   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11402   myfab.fab$l_nam = &mynam;
11403   mynam.nam$l_esa = esa;
11404   mynam.nam$b_ess = (unsigned char) sizeof esa;
11405   mynam.nam$l_rsa = rsa;
11406   mynam.nam$b_rss = (unsigned char) sizeof rsa;
11407   if (decc_efs_case_preserve)
11408       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
11409
11410   /* Look for the file to be affected, letting RMS parse the file
11411    * specification for us as well.  I have set errno using only
11412    * values documented in the utime() man page for VMS POSIX.
11413    */
11414   retsts = sys$parse(&myfab,0,0);
11415   if (!(retsts & 1)) {
11416     set_vaxc_errno(retsts);
11417     if      (retsts == RMS$_PRV) set_errno(EACCES);
11418     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11419     else                         set_errno(EVMSERR);
11420     return -1;
11421   }
11422   retsts = sys$search(&myfab,0,0);
11423   if (!(retsts & 1)) {
11424     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11425     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11426     set_vaxc_errno(retsts);
11427     if      (retsts == RMS$_PRV) set_errno(EACCES);
11428     else if (retsts == RMS$_FNF) set_errno(ENOENT);
11429     else                         set_errno(EVMSERR);
11430     return -1;
11431   }
11432
11433   devdsc.dsc$w_length = mynam.nam$b_dev;
11434   /* cast ok for read only parameter */
11435   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11436
11437   retsts = sys$assign(&devdsc,&chan,0,0);
11438   if (!(retsts & 1)) {
11439     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11440     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11441     set_vaxc_errno(retsts);
11442     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
11443     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
11444     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
11445     else                               set_errno(EVMSERR);
11446     return -1;
11447   }
11448
11449   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11450   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11451
11452   memset((void *) &myfib, 0, sizeof myfib);
11453 #if defined(__DECC) || defined(__DECCXX)
11454   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11455   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11456   /* This prevents the revision time of the file being reset to the current
11457    * time as a result of our IO$_MODIFY $QIO. */
11458   myfib.fib$l_acctl = FIB$M_NORECORD;
11459 #else
11460   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11461   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11462   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11463 #endif
11464   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
11465   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11466   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11467   _ckvmssts(sys$dassgn(chan));
11468   if (retsts & 1) retsts = iosb[0];
11469   if (!(retsts & 1)) {
11470     set_vaxc_errno(retsts);
11471     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11472     else                      set_errno(EVMSERR);
11473     return -1;
11474   }
11475
11476   return 0;
11477
11478 #endif /* #if __CRTL_VER >= 70300000 */
11479
11480 }  /* end of my_utime() */
11481 /*}}}*/
11482
11483 /*
11484  * flex_stat, flex_lstat, flex_fstat
11485  * basic stat, but gets it right when asked to stat
11486  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11487  */
11488
11489 #ifndef _USE_STD_STAT
11490 /* encode_dev packs a VMS device name string into an integer to allow
11491  * simple comparisons. This can be used, for example, to check whether two
11492  * files are located on the same device, by comparing their encoded device
11493  * names. Even a string comparison would not do, because stat() reuses the
11494  * device name buffer for each call; so without encode_dev, it would be
11495  * necessary to save the buffer and use strcmp (this would mean a number of
11496  * changes to the standard Perl code, to say nothing of what a Perl script
11497  * would have to do.
11498  *
11499  * The device lock id, if it exists, should be unique (unless perhaps compared
11500  * with lock ids transferred from other nodes). We have a lock id if the disk is
11501  * mounted cluster-wide, which is when we tend to get long (host-qualified)
11502  * device names. Thus we use the lock id in preference, and only if that isn't
11503  * available, do we try to pack the device name into an integer (flagged by
11504  * the sign bit (LOCKID_MASK) being set).
11505  *
11506  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11507  * name and its encoded form, but it seems very unlikely that we will find
11508  * two files on different disks that share the same encoded device names,
11509  * and even more remote that they will share the same file id (if the test
11510  * is to check for the same file).
11511  *
11512  * A better method might be to use sys$device_scan on the first call, and to
11513  * search for the device, returning an index into the cached array.
11514  * The number returned would be more intelligible.
11515  * This is probably not worth it, and anyway would take quite a bit longer
11516  * on the first call.
11517  */
11518 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
11519 static mydev_t encode_dev (pTHX_ const char *dev)
11520 {
11521   int i;
11522   unsigned long int f;
11523   mydev_t enc;
11524   char c;
11525   const char *q;
11526
11527   if (!dev || !dev[0]) return 0;
11528
11529 #if LOCKID_MASK
11530   {
11531     struct dsc$descriptor_s dev_desc;
11532     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11533
11534     /* For cluster-mounted disks, the disk lock identifier is unique, so we
11535        can try that first. */
11536     dev_desc.dsc$w_length =  strlen (dev);
11537     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
11538     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
11539     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
11540     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11541     if (!$VMS_STATUS_SUCCESS(status)) {
11542       switch (status) {
11543         case SS$_NOSUCHDEV:
11544           SETERRNO(ENODEV, status);
11545           return 0;
11546         default:
11547           _ckvmssts(status);
11548       }
11549     }
11550     if (lockid) return (lockid & ~LOCKID_MASK);
11551   }
11552 #endif
11553
11554   /* Otherwise we try to encode the device name */
11555   enc = 0;
11556   f = 1;
11557   i = 0;
11558   for (q = dev + strlen(dev); q--; q >= dev) {
11559     if (*q == ':')
11560         break;
11561     if (isdigit (*q))
11562       c= (*q) - '0';
11563     else if (isalpha (toupper (*q)))
11564       c= toupper (*q) - 'A' + (char)10;
11565     else
11566       continue; /* Skip '$'s */
11567     i++;
11568     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
11569     if (i>1) f *= 36;
11570     enc += f * (unsigned long int) c;
11571   }
11572   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
11573
11574 }  /* end of encode_dev() */
11575 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11576         device_no = encode_dev(aTHX_ devname)
11577 #else
11578 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11579         device_no = new_dev_no
11580 #endif
11581
11582 static int
11583 is_null_device(name)
11584     const char *name;
11585 {
11586   if (decc_bug_devnull != 0) {
11587     if (strncmp("/dev/null", name, 9) == 0)
11588       return 1;
11589   }
11590     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11591        The underscore prefix, controller letter, and unit number are
11592        independently optional; for our purposes, the colon punctuation
11593        is not.  The colon can be trailed by optional directory and/or
11594        filename, but two consecutive colons indicates a nodename rather
11595        than a device.  [pr]  */
11596   if (*name == '_') ++name;
11597   if (tolower(*name++) != 'n') return 0;
11598   if (tolower(*name++) != 'l') return 0;
11599   if (tolower(*name) == 'a') ++name;
11600   if (*name == '0') ++name;
11601   return (*name++ == ':') && (*name != ':');
11602 }
11603
11604
11605 static I32
11606 Perl_cando_by_name_int
11607    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
11608 {
11609   char usrname[L_cuserid];
11610   struct dsc$descriptor_s usrdsc =
11611          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11612   char *vmsname = NULL, *fileified = NULL;
11613   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11614   unsigned short int retlen, trnlnm_iter_count;
11615   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11616   union prvdef curprv;
11617   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11618          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11619          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11620   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11621          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11622          {0,0,0,0}};
11623   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11624          {0,0,0,0}};
11625   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11626   Stat_t st;
11627   static int profile_context = -1;
11628
11629   if (!fname || !*fname) return FALSE;
11630
11631   /* Make sure we expand logical names, since sys$check_access doesn't */
11632   fileified = PerlMem_malloc(VMS_MAXRSS);
11633   if (fileified == NULL) _ckvmssts(SS$_INSFMEM);
11634   if (!strpbrk(fname,"/]>:")) {
11635       strcpy(fileified,fname);
11636       trnlnm_iter_count = 0;
11637       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11638         trnlnm_iter_count++;
11639         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11640       }
11641       fname = fileified;
11642   }
11643
11644   vmsname = PerlMem_malloc(VMS_MAXRSS);
11645   if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
11646   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11647     /* Don't know if already in VMS format, so make sure */
11648     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11649       PerlMem_free(fileified);
11650       PerlMem_free(vmsname);
11651       return FALSE;
11652     }
11653   }
11654   else {
11655     strcpy(vmsname,fname);
11656   }
11657
11658   /* sys$check_access needs a file spec, not a directory spec.
11659    * Don't use flex_stat here, as that depends on thread context
11660    * having been initialized, and we may get here during startup.
11661    */
11662
11663   retlen = namdsc.dsc$w_length = strlen(vmsname);
11664   if (vmsname[retlen-1] == ']'
11665       || vmsname[retlen-1] == '>'
11666       || vmsname[retlen-1] == ':'
11667       || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
11668
11669       if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) {
11670         PerlMem_free(fileified);
11671         PerlMem_free(vmsname);
11672         return FALSE;
11673       }
11674       fname = fileified;
11675   }
11676   else {
11677       fname = vmsname;
11678   }
11679
11680   retlen = namdsc.dsc$w_length = strlen(fname);
11681   namdsc.dsc$a_pointer = (char *)fname;
11682
11683   switch (bit) {
11684     case S_IXUSR: case S_IXGRP: case S_IXOTH:
11685       access = ARM$M_EXECUTE;
11686       flags = CHP$M_READ;
11687       break;
11688     case S_IRUSR: case S_IRGRP: case S_IROTH:
11689       access = ARM$M_READ;
11690       flags = CHP$M_READ | CHP$M_USEREADALL;
11691       break;
11692     case S_IWUSR: case S_IWGRP: case S_IWOTH:
11693       access = ARM$M_WRITE;
11694       flags = CHP$M_READ | CHP$M_WRITE;
11695       break;
11696     case S_IDUSR: case S_IDGRP: case S_IDOTH:
11697       access = ARM$M_DELETE;
11698       flags = CHP$M_READ | CHP$M_WRITE;
11699       break;
11700     default:
11701       if (fileified != NULL)
11702         PerlMem_free(fileified);
11703       if (vmsname != NULL)
11704         PerlMem_free(vmsname);
11705       return FALSE;
11706   }
11707
11708   /* Before we call $check_access, create a user profile with the current
11709    * process privs since otherwise it just uses the default privs from the
11710    * UAF and might give false positives or negatives.  This only works on
11711    * VMS versions v6.0 and later since that's when sys$create_user_profile
11712    * became available.
11713    */
11714
11715   /* get current process privs and username */
11716   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11717   _ckvmssts(iosb[0]);
11718
11719 #if defined(__VMS_VER) && __VMS_VER >= 60000000
11720
11721   /* find out the space required for the profile */
11722   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11723                                     &usrprodsc.dsc$w_length,&profile_context));
11724
11725   /* allocate space for the profile and get it filled in */
11726   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11727   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
11728   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11729                                     &usrprodsc.dsc$w_length,&profile_context));
11730
11731   /* use the profile to check access to the file; free profile & analyze results */
11732   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
11733   PerlMem_free(usrprodsc.dsc$a_pointer);
11734   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11735
11736 #else
11737
11738   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11739
11740 #endif
11741
11742   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
11743       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11744       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11745     set_vaxc_errno(retsts);
11746     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11747     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11748     else set_errno(ENOENT);
11749     if (fileified != NULL)
11750       PerlMem_free(fileified);
11751     if (vmsname != NULL)
11752       PerlMem_free(vmsname);
11753     return FALSE;
11754   }
11755   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11756     if (fileified != NULL)
11757       PerlMem_free(fileified);
11758     if (vmsname != NULL)
11759       PerlMem_free(vmsname);
11760     return TRUE;
11761   }
11762   _ckvmssts(retsts);
11763
11764   if (fileified != NULL)
11765     PerlMem_free(fileified);
11766   if (vmsname != NULL)
11767     PerlMem_free(vmsname);
11768   return FALSE;  /* Should never get here */
11769
11770 }
11771
11772 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
11773 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11774  * subset of the applicable information.
11775  */
11776 bool
11777 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11778 {
11779   return cando_by_name_int
11780         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11781 }  /* end of cando() */
11782 /*}}}*/
11783
11784
11785 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11786 I32
11787 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11788 {
11789    return cando_by_name_int(bit, effective, fname, 0);
11790
11791 }  /* end of cando_by_name() */
11792 /*}}}*/
11793
11794
11795 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
11796 int
11797 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
11798 {
11799   if (!fstat(fd,(stat_t *) statbufp)) {
11800     char *cptr;
11801     char *vms_filename;
11802     vms_filename = PerlMem_malloc(VMS_MAXRSS);
11803     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
11804
11805     /* Save name for cando by name in VMS format */
11806     cptr = getname(fd, vms_filename, 1);
11807
11808     /* This should not happen, but just in case */
11809     if (cptr == NULL) {
11810         statbufp->st_devnam[0] = 0;
11811     }
11812     else {
11813         /* Make sure that the saved name fits in 255 characters */
11814         cptr = do_rmsexpand
11815                        (vms_filename,
11816                         statbufp->st_devnam,
11817                         0,
11818                         NULL,
11819                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
11820                         NULL,
11821                         NULL);
11822         if (cptr == NULL)
11823             statbufp->st_devnam[0] = 0;
11824     }
11825     PerlMem_free(vms_filename);
11826
11827     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11828     VMS_DEVICE_ENCODE
11829         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11830
11831 #   ifdef RTL_USES_UTC
11832 #   ifdef VMSISH_TIME
11833     if (VMSISH_TIME) {
11834       statbufp->st_mtime = _toloc(statbufp->st_mtime);
11835       statbufp->st_atime = _toloc(statbufp->st_atime);
11836       statbufp->st_ctime = _toloc(statbufp->st_ctime);
11837     }
11838 #   endif
11839 #   else
11840 #   ifdef VMSISH_TIME
11841     if (!VMSISH_TIME) { /* Return UTC instead of local time */
11842 #   else
11843     if (1) {
11844 #   endif
11845       statbufp->st_mtime = _toutc(statbufp->st_mtime);
11846       statbufp->st_atime = _toutc(statbufp->st_atime);
11847       statbufp->st_ctime = _toutc(statbufp->st_ctime);
11848     }
11849 #endif
11850     return 0;
11851   }
11852   return -1;
11853
11854 }  /* end of flex_fstat() */
11855 /*}}}*/
11856
11857 #if !defined(__VAX) && __CRTL_VER >= 80200000
11858 #ifdef lstat
11859 #undef lstat
11860 #endif
11861 #else
11862 #ifdef lstat
11863 #undef lstat
11864 #endif
11865 #define lstat(_x, _y) stat(_x, _y)
11866 #endif
11867
11868 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11869
11870 static int
11871 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
11872 {
11873     char fileified[VMS_MAXRSS];
11874     char temp_fspec[VMS_MAXRSS];
11875     char *save_spec;
11876     int retval = -1;
11877     int saved_errno, saved_vaxc_errno;
11878
11879     if (!fspec) return retval;
11880     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
11881     strcpy(temp_fspec, fspec);
11882
11883     if (decc_bug_devnull != 0) {
11884       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
11885         memset(statbufp,0,sizeof *statbufp);
11886         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
11887         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
11888         statbufp->st_uid = 0x00010001;
11889         statbufp->st_gid = 0x0001;
11890         time((time_t *)&statbufp->st_mtime);
11891         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
11892         return 0;
11893       }
11894     }
11895
11896     /* Try for a directory name first.  If fspec contains a filename without
11897      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
11898      * and sea:[wine.dark]water. exist, we prefer the directory here.
11899      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
11900      * not sea:[wine.dark]., if the latter exists.  If the intended target is
11901      * the file with null type, specify this by calling flex_stat() with
11902      * a '.' at the end of fspec.
11903      *
11904      * If we are in Posix filespec mode, accept the filename as is.
11905      */
11906
11907
11908 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11909   /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
11910    * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
11911    */
11912   if (!decc_efs_charset)
11913     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
11914 #endif
11915
11916 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11917   if (decc_posix_compliant_pathnames == 0) {
11918 #endif
11919     if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
11920       if (lstat_flag == 0)
11921         retval = stat(fileified,(stat_t *) statbufp);
11922       else
11923         retval = lstat(fileified,(stat_t *) statbufp);
11924       save_spec = fileified;
11925     }
11926     if (retval) {
11927       if (lstat_flag == 0)
11928         retval = stat(temp_fspec,(stat_t *) statbufp);
11929       else
11930         retval = lstat(temp_fspec,(stat_t *) statbufp);
11931       save_spec = temp_fspec;
11932     }
11933 /*
11934  * In debugging, on 8.3 Alpha, I found a case where stat was returning a
11935  * file not found error for a directory named foo:[bar.t] or /foo/bar/t
11936  * and lstat was working correctly for the same file.
11937  * The only syntax that was working for stat was "foo:[bar]t.dir".
11938  *
11939  * Other directories with the same syntax worked fine.
11940  * So work around the problem when it shows up here.
11941  */
11942     if (retval) {
11943         int save_errno = errno;
11944         if (do_tovmsspec(fspec, temp_fspec, 0, NULL) != NULL) {
11945             if (do_fileify_dirspec(temp_fspec, fileified, 0, NULL) != NULL) {
11946                 retval = stat(fileified, (stat_t *) statbufp);
11947                 save_spec = fileified;
11948             }
11949         }
11950         /* Restore the errno value if third stat does not succeed */
11951         if (retval != 0)
11952             errno = save_errno;
11953     }
11954 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11955   } else {
11956     if (lstat_flag == 0)
11957       retval = stat(temp_fspec,(stat_t *) statbufp);
11958     else
11959       retval = lstat(temp_fspec,(stat_t *) statbufp);
11960       save_spec = temp_fspec;
11961   }
11962 #endif
11963
11964 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11965   /* As you were... */
11966   if (!decc_efs_charset)
11967     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
11968 #endif
11969
11970     if (!retval) {
11971     char * cptr;
11972     int rmsex_flags = PERL_RMSEXPAND_M_VMS;
11973
11974       /* If this is an lstat, do not follow the link */
11975       if (lstat_flag)
11976         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
11977
11978       cptr = do_rmsexpand
11979        (save_spec, statbufp->st_devnam, 0, NULL, rmsex_flags, NULL, NULL);
11980       if (cptr == NULL)
11981         statbufp->st_devnam[0] = 0;
11982
11983       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11984       VMS_DEVICE_ENCODE
11985         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11986 #     ifdef RTL_USES_UTC
11987 #     ifdef VMSISH_TIME
11988       if (VMSISH_TIME) {
11989         statbufp->st_mtime = _toloc(statbufp->st_mtime);
11990         statbufp->st_atime = _toloc(statbufp->st_atime);
11991         statbufp->st_ctime = _toloc(statbufp->st_ctime);
11992       }
11993 #     endif
11994 #     else
11995 #     ifdef VMSISH_TIME
11996       if (!VMSISH_TIME) { /* Return UTC instead of local time */
11997 #     else
11998       if (1) {
11999 #     endif
12000         statbufp->st_mtime = _toutc(statbufp->st_mtime);
12001         statbufp->st_atime = _toutc(statbufp->st_atime);
12002         statbufp->st_ctime = _toutc(statbufp->st_ctime);
12003       }
12004 #     endif
12005     }
12006     /* If we were successful, leave errno where we found it */
12007     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
12008     return retval;
12009
12010 }  /* end of flex_stat_int() */
12011
12012
12013 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12014 int
12015 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12016 {
12017    return flex_stat_int(fspec, statbufp, 0);
12018 }
12019 /*}}}*/
12020
12021 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12022 int
12023 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12024 {
12025    return flex_stat_int(fspec, statbufp, 1);
12026 }
12027 /*}}}*/
12028
12029
12030 /*{{{char *my_getlogin()*/
12031 /* VMS cuserid == Unix getlogin, except calling sequence */
12032 char *
12033 my_getlogin(void)
12034 {
12035     static char user[L_cuserid];
12036     return cuserid(user);
12037 }
12038 /*}}}*/
12039
12040
12041 /*  rmscopy - copy a file using VMS RMS routines
12042  *
12043  *  Copies contents and attributes of spec_in to spec_out, except owner
12044  *  and protection information.  Name and type of spec_in are used as
12045  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
12046  *  should try to propagate timestamps from the input file to the output file.
12047  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
12048  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
12049  *  propagated to the output file at creation iff the output file specification
12050  *  did not contain an explicit name or type, and the revision date is always
12051  *  updated at the end of the copy operation.  If it is greater than 0, then
12052  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12053  *  other than the revision date should be propagated, and bit 1 indicates
12054  *  that the revision date should be propagated.
12055  *
12056  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12057  *
12058  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12059  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
12060  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
12061  * as part of the Perl standard distribution under the terms of the
12062  * GNU General Public License or the Perl Artistic License.  Copies
12063  * of each may be found in the Perl standard distribution.
12064  */ /* FIXME */
12065 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12066 int
12067 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12068 {
12069     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12070          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12071     unsigned long int i, sts, sts2;
12072     int dna_len;
12073     struct FAB fab_in, fab_out;
12074     struct RAB rab_in, rab_out;
12075     rms_setup_nam(nam);
12076     rms_setup_nam(nam_out);
12077     struct XABDAT xabdat;
12078     struct XABFHC xabfhc;
12079     struct XABRDT xabrdt;
12080     struct XABSUM xabsum;
12081
12082     vmsin = PerlMem_malloc(VMS_MAXRSS);
12083     if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
12084     vmsout = PerlMem_malloc(VMS_MAXRSS);
12085     if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
12086     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
12087         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
12088       PerlMem_free(vmsin);
12089       PerlMem_free(vmsout);
12090       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12091       return 0;
12092     }
12093
12094     esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
12095     if (esa == NULL) _ckvmssts(SS$_INSFMEM);
12096     esal = NULL;
12097 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12098     esal = PerlMem_malloc(VMS_MAXRSS);
12099     if (esal == NULL) _ckvmssts(SS$_INSFMEM);
12100 #endif
12101     fab_in = cc$rms_fab;
12102     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12103     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12104     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12105     fab_in.fab$l_fop = FAB$M_SQO;
12106     rms_bind_fab_nam(fab_in, nam);
12107     fab_in.fab$l_xab = (void *) &xabdat;
12108
12109     rsa = PerlMem_malloc(NAML$C_MAXRSS);
12110     if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
12111     rsal = NULL;
12112 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12113     rsal = PerlMem_malloc(VMS_MAXRSS);
12114     if (rsal == NULL) _ckvmssts(SS$_INSFMEM);
12115 #endif
12116     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12117     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12118     rms_nam_esl(nam) = 0;
12119     rms_nam_rsl(nam) = 0;
12120     rms_nam_esll(nam) = 0;
12121     rms_nam_rsll(nam) = 0;
12122 #ifdef NAM$M_NO_SHORT_UPCASE
12123     if (decc_efs_case_preserve)
12124         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12125 #endif
12126
12127     xabdat = cc$rms_xabdat;        /* To get creation date */
12128     xabdat.xab$l_nxt = (void *) &xabfhc;
12129
12130     xabfhc = cc$rms_xabfhc;        /* To get record length */
12131     xabfhc.xab$l_nxt = (void *) &xabsum;
12132
12133     xabsum = cc$rms_xabsum;        /* To get key and area information */
12134
12135     if (!((sts = sys$open(&fab_in)) & 1)) {
12136       PerlMem_free(vmsin);
12137       PerlMem_free(vmsout);
12138       PerlMem_free(esa);
12139       if (esal != NULL)
12140         PerlMem_free(esal);
12141       PerlMem_free(rsa);
12142       if (rsal != NULL)
12143         PerlMem_free(rsal);
12144       set_vaxc_errno(sts);
12145       switch (sts) {
12146         case RMS$_FNF: case RMS$_DNF:
12147           set_errno(ENOENT); break;
12148         case RMS$_DIR:
12149           set_errno(ENOTDIR); break;
12150         case RMS$_DEV:
12151           set_errno(ENODEV); break;
12152         case RMS$_SYN:
12153           set_errno(EINVAL); break;
12154         case RMS$_PRV:
12155           set_errno(EACCES); break;
12156         default:
12157           set_errno(EVMSERR);
12158       }
12159       return 0;
12160     }
12161
12162     nam_out = nam;
12163     fab_out = fab_in;
12164     fab_out.fab$w_ifi = 0;
12165     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12166     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12167     fab_out.fab$l_fop = FAB$M_SQO;
12168     rms_bind_fab_nam(fab_out, nam_out);
12169     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12170     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12171     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12172     esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12173     if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
12174     rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12175     if (rsa_out == NULL) _ckvmssts(SS$_INSFMEM);
12176     esal_out = NULL;
12177     rsal_out = NULL;
12178 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12179     esal_out = PerlMem_malloc(VMS_MAXRSS);
12180     if (esal_out == NULL) _ckvmssts(SS$_INSFMEM);
12181     rsal_out = PerlMem_malloc(VMS_MAXRSS);
12182     if (rsal_out == NULL) _ckvmssts(SS$_INSFMEM);
12183 #endif
12184     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12185     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12186
12187     if (preserve_dates == 0) {  /* Act like DCL COPY */
12188       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12189       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
12190       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12191         PerlMem_free(vmsin);
12192         PerlMem_free(vmsout);
12193         PerlMem_free(esa);
12194         if (esal != NULL)
12195             PerlMem_free(esal);
12196         PerlMem_free(rsa);
12197         if (rsal != NULL)
12198             PerlMem_free(rsal);
12199         PerlMem_free(esa_out);
12200         if (esal_out != NULL)
12201             PerlMem_free(esal_out);
12202         PerlMem_free(rsa_out);
12203         if (rsal_out != NULL)
12204             PerlMem_free(rsal_out);
12205         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12206         set_vaxc_errno(sts);
12207         return 0;
12208       }
12209       fab_out.fab$l_xab = (void *) &xabdat;
12210       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12211         preserve_dates = 1;
12212     }
12213     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
12214       preserve_dates =0;      /* bitmask from this point forward   */
12215
12216     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12217     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12218       PerlMem_free(vmsin);
12219       PerlMem_free(vmsout);
12220       PerlMem_free(esa);
12221       if (esal != NULL)
12222           PerlMem_free(esal);
12223       PerlMem_free(rsa);
12224       if (rsal != NULL)
12225           PerlMem_free(rsal);
12226       PerlMem_free(esa_out);
12227       if (esal_out != NULL)
12228           PerlMem_free(esal_out);
12229       PerlMem_free(rsa_out);
12230       if (rsal_out != NULL)
12231           PerlMem_free(rsal_out);
12232       set_vaxc_errno(sts);
12233       switch (sts) {
12234         case RMS$_DNF:
12235           set_errno(ENOENT); break;
12236         case RMS$_DIR:
12237           set_errno(ENOTDIR); break;
12238         case RMS$_DEV:
12239           set_errno(ENODEV); break;
12240         case RMS$_SYN:
12241           set_errno(EINVAL); break;
12242         case RMS$_PRV:
12243           set_errno(EACCES); break;
12244         default:
12245           set_errno(EVMSERR);
12246       }
12247       return 0;
12248     }
12249     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
12250     if (preserve_dates & 2) {
12251       /* sys$close() will process xabrdt, not xabdat */
12252       xabrdt = cc$rms_xabrdt;
12253 #ifndef __GNUC__
12254       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12255 #else
12256       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12257        * is unsigned long[2], while DECC & VAXC use a struct */
12258       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12259 #endif
12260       fab_out.fab$l_xab = (void *) &xabrdt;
12261     }
12262
12263     ubf = PerlMem_malloc(32256);
12264     if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
12265     rab_in = cc$rms_rab;
12266     rab_in.rab$l_fab = &fab_in;
12267     rab_in.rab$l_rop = RAB$M_BIO;
12268     rab_in.rab$l_ubf = ubf;
12269     rab_in.rab$w_usz = 32256;
12270     if (!((sts = sys$connect(&rab_in)) & 1)) {
12271       sys$close(&fab_in); sys$close(&fab_out);
12272       PerlMem_free(vmsin);
12273       PerlMem_free(vmsout);
12274       PerlMem_free(ubf);
12275       PerlMem_free(esa);
12276       if (esal != NULL)
12277           PerlMem_free(esal);
12278       PerlMem_free(rsa);
12279       if (rsal != NULL)
12280           PerlMem_free(rsal);
12281       PerlMem_free(esa_out);
12282       if (esal_out != NULL)
12283           PerlMem_free(esal_out);
12284       PerlMem_free(rsa_out);
12285       if (rsal_out != NULL)
12286           PerlMem_free(rsal_out);
12287       set_errno(EVMSERR); set_vaxc_errno(sts);
12288       return 0;
12289     }
12290
12291     rab_out = cc$rms_rab;
12292     rab_out.rab$l_fab = &fab_out;
12293     rab_out.rab$l_rbf = ubf;
12294     if (!((sts = sys$connect(&rab_out)) & 1)) {
12295       sys$close(&fab_in); sys$close(&fab_out);
12296       PerlMem_free(vmsin);
12297       PerlMem_free(vmsout);
12298       PerlMem_free(ubf);
12299       PerlMem_free(esa);
12300       if (esal != NULL)
12301           PerlMem_free(esal);
12302       PerlMem_free(rsa);
12303       if (rsal != NULL)
12304           PerlMem_free(rsal);
12305       PerlMem_free(esa_out);
12306       if (esal_out != NULL)
12307           PerlMem_free(esal_out);
12308       PerlMem_free(rsa_out);
12309       if (rsal_out != NULL)
12310           PerlMem_free(rsal_out);
12311       set_errno(EVMSERR); set_vaxc_errno(sts);
12312       return 0;
12313     }
12314
12315     while ((sts = sys$read(&rab_in))) {  /* always true  */
12316       if (sts == RMS$_EOF) break;
12317       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12318       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12319         sys$close(&fab_in); sys$close(&fab_out);
12320         PerlMem_free(vmsin);
12321         PerlMem_free(vmsout);
12322         PerlMem_free(ubf);
12323         PerlMem_free(esa);
12324         if (esal != NULL)
12325             PerlMem_free(esal);
12326         PerlMem_free(rsa);
12327         if (rsal != NULL)
12328             PerlMem_free(rsal);
12329         PerlMem_free(esa_out);
12330         if (esal_out != NULL)
12331             PerlMem_free(esal_out);
12332         PerlMem_free(rsa_out);
12333         if (rsal_out != NULL)
12334             PerlMem_free(rsal_out);
12335         set_errno(EVMSERR); set_vaxc_errno(sts);
12336         return 0;
12337       }
12338     }
12339
12340
12341     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
12342     sys$close(&fab_in);  sys$close(&fab_out);
12343     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12344
12345     PerlMem_free(vmsin);
12346     PerlMem_free(vmsout);
12347     PerlMem_free(ubf);
12348     PerlMem_free(esa);
12349     if (esal != NULL)
12350         PerlMem_free(esal);
12351     PerlMem_free(rsa);
12352     if (rsal != NULL)
12353         PerlMem_free(rsal);
12354     PerlMem_free(esa_out);
12355     if (esal_out != NULL)
12356         PerlMem_free(esal_out);
12357     PerlMem_free(rsa_out);
12358     if (rsal_out != NULL)
12359         PerlMem_free(rsal_out);
12360
12361     if (!(sts & 1)) {
12362       set_errno(EVMSERR); set_vaxc_errno(sts);
12363       return 0;
12364     }
12365
12366     return 1;
12367
12368 }  /* end of rmscopy() */
12369 /*}}}*/
12370
12371
12372 /***  The following glue provides 'hooks' to make some of the routines
12373  * from this file available from Perl.  These routines are sufficiently
12374  * basic, and are required sufficiently early in the build process,
12375  * that's it's nice to have them available to miniperl as well as the
12376  * full Perl, so they're set up here instead of in an extension.  The
12377  * Perl code which handles importation of these names into a given
12378  * package lives in [.VMS]Filespec.pm in @INC.
12379  */
12380
12381 void
12382 rmsexpand_fromperl(pTHX_ CV *cv)
12383 {
12384   dXSARGS;
12385   char *fspec, *defspec = NULL, *rslt;
12386   STRLEN n_a;
12387   int fs_utf8, dfs_utf8;
12388
12389   fs_utf8 = 0;
12390   dfs_utf8 = 0;
12391   if (!items || items > 2)
12392     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12393   fspec = SvPV(ST(0),n_a);
12394   fs_utf8 = SvUTF8(ST(0));
12395   if (!fspec || !*fspec) XSRETURN_UNDEF;
12396   if (items == 2) {
12397     defspec = SvPV(ST(1),n_a);
12398     dfs_utf8 = SvUTF8(ST(1));
12399   }
12400   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12401   ST(0) = sv_newmortal();
12402   if (rslt != NULL) {
12403     sv_usepvn(ST(0),rslt,strlen(rslt));
12404     if (fs_utf8) {
12405         SvUTF8_on(ST(0));
12406     }
12407   }
12408   XSRETURN(1);
12409 }
12410
12411 void
12412 vmsify_fromperl(pTHX_ CV *cv)
12413 {
12414   dXSARGS;
12415   char *vmsified;
12416   STRLEN n_a;
12417   int utf8_fl;
12418
12419   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12420   utf8_fl = SvUTF8(ST(0));
12421   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12422   ST(0) = sv_newmortal();
12423   if (vmsified != NULL) {
12424     sv_usepvn(ST(0),vmsified,strlen(vmsified));
12425     if (utf8_fl) {
12426         SvUTF8_on(ST(0));
12427     }
12428   }
12429   XSRETURN(1);
12430 }
12431
12432 void
12433 unixify_fromperl(pTHX_ CV *cv)
12434 {
12435   dXSARGS;
12436   char *unixified;
12437   STRLEN n_a;
12438   int utf8_fl;
12439
12440   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12441   utf8_fl = SvUTF8(ST(0));
12442   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12443   ST(0) = sv_newmortal();
12444   if (unixified != NULL) {
12445     sv_usepvn(ST(0),unixified,strlen(unixified));
12446     if (utf8_fl) {
12447         SvUTF8_on(ST(0));
12448     }
12449   }
12450   XSRETURN(1);
12451 }
12452
12453 void
12454 fileify_fromperl(pTHX_ CV *cv)
12455 {
12456   dXSARGS;
12457   char *fileified;
12458   STRLEN n_a;
12459   int utf8_fl;
12460
12461   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12462   utf8_fl = SvUTF8(ST(0));
12463   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12464   ST(0) = sv_newmortal();
12465   if (fileified != NULL) {
12466     sv_usepvn(ST(0),fileified,strlen(fileified));
12467     if (utf8_fl) {
12468         SvUTF8_on(ST(0));
12469     }
12470   }
12471   XSRETURN(1);
12472 }
12473
12474 void
12475 pathify_fromperl(pTHX_ CV *cv)
12476 {
12477   dXSARGS;
12478   char *pathified;
12479   STRLEN n_a;
12480   int utf8_fl;
12481
12482   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12483   utf8_fl = SvUTF8(ST(0));
12484   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12485   ST(0) = sv_newmortal();
12486   if (pathified != NULL) {
12487     sv_usepvn(ST(0),pathified,strlen(pathified));
12488     if (utf8_fl) {
12489         SvUTF8_on(ST(0));
12490     }
12491   }
12492   XSRETURN(1);
12493 }
12494
12495 void
12496 vmspath_fromperl(pTHX_ CV *cv)
12497 {
12498   dXSARGS;
12499   char *vmspath;
12500   STRLEN n_a;
12501   int utf8_fl;
12502
12503   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12504   utf8_fl = SvUTF8(ST(0));
12505   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12506   ST(0) = sv_newmortal();
12507   if (vmspath != NULL) {
12508     sv_usepvn(ST(0),vmspath,strlen(vmspath));
12509     if (utf8_fl) {
12510         SvUTF8_on(ST(0));
12511     }
12512   }
12513   XSRETURN(1);
12514 }
12515
12516 void
12517 unixpath_fromperl(pTHX_ CV *cv)
12518 {
12519   dXSARGS;
12520   char *unixpath;
12521   STRLEN n_a;
12522   int utf8_fl;
12523
12524   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12525   utf8_fl = SvUTF8(ST(0));
12526   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12527   ST(0) = sv_newmortal();
12528   if (unixpath != NULL) {
12529     sv_usepvn(ST(0),unixpath,strlen(unixpath));
12530     if (utf8_fl) {
12531         SvUTF8_on(ST(0));
12532     }
12533   }
12534   XSRETURN(1);
12535 }
12536
12537 void
12538 candelete_fromperl(pTHX_ CV *cv)
12539 {
12540   dXSARGS;
12541   char *fspec, *fsp;
12542   SV *mysv;
12543   IO *io;
12544   STRLEN n_a;
12545
12546   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12547
12548   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12549   Newx(fspec, VMS_MAXRSS, char);
12550   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12551   if (SvTYPE(mysv) == SVt_PVGV) {
12552     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12553       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12554       ST(0) = &PL_sv_no;
12555       Safefree(fspec);
12556       XSRETURN(1);
12557     }
12558     fsp = fspec;
12559   }
12560   else {
12561     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12562       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12563       ST(0) = &PL_sv_no;
12564       Safefree(fspec);
12565       XSRETURN(1);
12566     }
12567   }
12568
12569   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12570   Safefree(fspec);
12571   XSRETURN(1);
12572 }
12573
12574 void
12575 rmscopy_fromperl(pTHX_ CV *cv)
12576 {
12577   dXSARGS;
12578   char *inspec, *outspec, *inp, *outp;
12579   int date_flag;
12580   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
12581                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12582   unsigned long int sts;
12583   SV *mysv;
12584   IO *io;
12585   STRLEN n_a;
12586
12587   if (items < 2 || items > 3)
12588     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12589
12590   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12591   Newx(inspec, VMS_MAXRSS, char);
12592   if (SvTYPE(mysv) == SVt_PVGV) {
12593     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12594       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12595       ST(0) = &PL_sv_no;
12596       Safefree(inspec);
12597       XSRETURN(1);
12598     }
12599     inp = inspec;
12600   }
12601   else {
12602     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12603       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12604       ST(0) = &PL_sv_no;
12605       Safefree(inspec);
12606       XSRETURN(1);
12607     }
12608   }
12609   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12610   Newx(outspec, VMS_MAXRSS, char);
12611   if (SvTYPE(mysv) == SVt_PVGV) {
12612     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12613       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12614       ST(0) = &PL_sv_no;
12615       Safefree(inspec);
12616       Safefree(outspec);
12617       XSRETURN(1);
12618     }
12619     outp = outspec;
12620   }
12621   else {
12622     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12623       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12624       ST(0) = &PL_sv_no;
12625       Safefree(inspec);
12626       Safefree(outspec);
12627       XSRETURN(1);
12628     }
12629   }
12630   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12631
12632   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
12633   Safefree(inspec);
12634   Safefree(outspec);
12635   XSRETURN(1);
12636 }
12637
12638 /* The mod2fname is limited to shorter filenames by design, so it should
12639  * not be modified to support longer EFS pathnames
12640  */
12641 void
12642 mod2fname(pTHX_ CV *cv)
12643 {
12644   dXSARGS;
12645   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12646        workbuff[NAM$C_MAXRSS*1 + 1];
12647   int total_namelen = 3, counter, num_entries;
12648   /* ODS-5 ups this, but we want to be consistent, so... */
12649   int max_name_len = 39;
12650   AV *in_array = (AV *)SvRV(ST(0));
12651
12652   num_entries = av_len(in_array);
12653
12654   /* All the names start with PL_. */
12655   strcpy(ultimate_name, "PL_");
12656
12657   /* Clean up our working buffer */
12658   Zero(work_name, sizeof(work_name), char);
12659
12660   /* Run through the entries and build up a working name */
12661   for(counter = 0; counter <= num_entries; counter++) {
12662     /* If it's not the first name then tack on a __ */
12663     if (counter) {
12664       strcat(work_name, "__");
12665     }
12666     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
12667                            PL_na));
12668   }
12669
12670   /* Check to see if we actually have to bother...*/
12671   if (strlen(work_name) + 3 <= max_name_len) {
12672     strcat(ultimate_name, work_name);
12673   } else {
12674     /* It's too darned big, so we need to go strip. We use the same */
12675     /* algorithm as xsubpp does. First, strip out doubled __ */
12676     char *source, *dest, last;
12677     dest = workbuff;
12678     last = 0;
12679     for (source = work_name; *source; source++) {
12680       if (last == *source && last == '_') {
12681         continue;
12682       }
12683       *dest++ = *source;
12684       last = *source;
12685     }
12686     /* Go put it back */
12687     strcpy(work_name, workbuff);
12688     /* Is it still too big? */
12689     if (strlen(work_name) + 3 > max_name_len) {
12690       /* Strip duplicate letters */
12691       last = 0;
12692       dest = workbuff;
12693       for (source = work_name; *source; source++) {
12694         if (last == toupper(*source)) {
12695         continue;
12696         }
12697         *dest++ = *source;
12698         last = toupper(*source);
12699       }
12700       strcpy(work_name, workbuff);
12701     }
12702
12703     /* Is it *still* too big? */
12704     if (strlen(work_name) + 3 > max_name_len) {
12705       /* Too bad, we truncate */
12706       work_name[max_name_len - 2] = 0;
12707     }
12708     strcat(ultimate_name, work_name);
12709   }
12710
12711   /* Okay, return it */
12712   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
12713   XSRETURN(1);
12714 }
12715
12716 void
12717 hushexit_fromperl(pTHX_ CV *cv)
12718 {
12719     dXSARGS;
12720
12721     if (items > 0) {
12722         VMSISH_HUSHED = SvTRUE(ST(0));
12723     }
12724     ST(0) = boolSV(VMSISH_HUSHED);
12725     XSRETURN(1);
12726 }
12727
12728
12729 PerlIO *
12730 Perl_vms_start_glob
12731    (pTHX_ SV *tmpglob,
12732     IO *io)
12733 {
12734     PerlIO *fp;
12735     struct vs_str_st *rslt;
12736     char *vmsspec;
12737     char *rstr;
12738     char *begin, *cp;
12739     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
12740     PerlIO *tmpfp;
12741     STRLEN i;
12742     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12743     struct dsc$descriptor_vs rsdsc;
12744     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
12745     unsigned long hasver = 0, isunix = 0;
12746     unsigned long int lff_flags = 0;
12747     int rms_sts;
12748
12749 #ifdef VMS_LONGNAME_SUPPORT
12750     lff_flags = LIB$M_FIL_LONG_NAMES;
12751 #endif
12752     /* The Newx macro will not allow me to assign a smaller array
12753      * to the rslt pointer, so we will assign it to the begin char pointer
12754      * and then copy the value into the rslt pointer.
12755      */
12756     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
12757     rslt = (struct vs_str_st *)begin;
12758     rslt->length = 0;
12759     rstr = &rslt->str[0];
12760     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
12761     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
12762     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
12763     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
12764
12765     Newx(vmsspec, VMS_MAXRSS, char);
12766
12767         /* We could find out if there's an explicit dev/dir or version
12768            by peeking into lib$find_file's internal context at
12769            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
12770            but that's unsupported, so I don't want to do it now and
12771            have it bite someone in the future. */
12772         /* Fix-me: vms_split_path() is the only way to do this, the
12773            existing method will fail with many legal EFS or UNIX specifications
12774          */
12775
12776     cp = SvPV(tmpglob,i);
12777
12778     for (; i; i--) {
12779         if (cp[i] == ';') hasver = 1;
12780         if (cp[i] == '.') {
12781             if (sts) hasver = 1;
12782             else sts = 1;
12783         }
12784         if (cp[i] == '/') {
12785             hasdir = isunix = 1;
12786             break;
12787         }
12788         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
12789             hasdir = 1;
12790             break;
12791         }
12792     }
12793     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
12794         int found = 0;
12795         Stat_t st;
12796         int stat_sts;
12797         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
12798         if (!stat_sts && S_ISDIR(st.st_mode)) {
12799             wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
12800             ok = (wilddsc.dsc$a_pointer != NULL);
12801             /* maybe passed 'foo' rather than '[.foo]', thus not detected above */
12802             hasdir = 1;
12803         }
12804         else {
12805             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
12806             ok = (wilddsc.dsc$a_pointer != NULL);
12807         }
12808         if (ok)
12809             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
12810
12811         /* If not extended character set, replace ? with % */
12812         /* With extended character set, ? is a wildcard single character */
12813         if (!decc_efs_case_preserve) {
12814             for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
12815                 if (*cp == '?') *cp = '%';
12816         }
12817         sts = SS$_NORMAL;
12818         while (ok && $VMS_STATUS_SUCCESS(sts)) {
12819          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
12820          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
12821
12822             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
12823                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
12824             if (!$VMS_STATUS_SUCCESS(sts))
12825                 break;
12826
12827             found++;
12828
12829             /* with varying string, 1st word of buffer contains result length */
12830             rstr[rslt->length] = '\0';
12831
12832              /* Find where all the components are */
12833              v_sts = vms_split_path
12834                        (rstr,
12835                         &v_spec,
12836                         &v_len,
12837                         &r_spec,
12838                         &r_len,
12839                         &d_spec,
12840                         &d_len,
12841                         &n_spec,
12842                         &n_len,
12843                         &e_spec,
12844                         &e_len,
12845                         &vs_spec,
12846                         &vs_len);
12847
12848             /* If no version on input, truncate the version on output */
12849             if (!hasver && (vs_len > 0)) {
12850                 *vs_spec = '\0';
12851                 vs_len = 0;
12852
12853                 /* No version & a null extension on UNIX handling */
12854                 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
12855                     e_len = 0;
12856                     *e_spec = '\0';
12857                 }
12858             }
12859
12860             if (!decc_efs_case_preserve) {
12861                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
12862             }
12863
12864             if (hasdir) {
12865                 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
12866                 begin = rstr;
12867             }
12868             else {
12869                 /* Start with the name */
12870                 begin = n_spec;
12871             }
12872             strcat(begin,"\n");
12873             ok = (PerlIO_puts(tmpfp,begin) != EOF);
12874         }
12875         if (cxt) (void)lib$find_file_end(&cxt);
12876
12877         if (!found) {
12878             /* Be POSIXish: return the input pattern when no matches */
12879             begin = SvPVX(tmpglob);
12880             strcat(begin,"\n");
12881             ok = (PerlIO_puts(tmpfp,begin) != EOF);
12882         }
12883
12884         if (ok && sts != RMS$_NMF &&
12885             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
12886         if (!ok) {
12887             if (!(sts & 1)) {
12888                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
12889             }
12890             PerlIO_close(tmpfp);
12891             fp = NULL;
12892         }
12893         else {
12894             PerlIO_rewind(tmpfp);
12895             IoTYPE(io) = IoTYPE_RDONLY;
12896             IoIFP(io) = fp = tmpfp;
12897             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
12898         }
12899     }
12900     Safefree(vmsspec);
12901     Safefree(rslt);
12902     return fp;
12903 }
12904
12905
12906 #ifdef HAS_SYMLINK
12907 static char *
12908 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
12909                    int *utf8_fl);
12910
12911 void
12912 vms_realpath_fromperl(pTHX_ CV *cv)
12913 {
12914     dXSARGS;
12915     char *fspec, *rslt_spec, *rslt;
12916     STRLEN n_a;
12917
12918     if (!items || items != 1)
12919         Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
12920
12921     fspec = SvPV(ST(0),n_a);
12922     if (!fspec || !*fspec) XSRETURN_UNDEF;
12923
12924     Newx(rslt_spec, VMS_MAXRSS + 1, char);
12925     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
12926
12927     ST(0) = sv_newmortal();
12928     if (rslt != NULL)
12929         sv_usepvn(ST(0),rslt,strlen(rslt));
12930     else
12931         Safefree(rslt_spec);
12932         XSRETURN(1);
12933 }
12934
12935 /*
12936  * A thin wrapper around decc$symlink to make sure we follow the
12937  * standard and do not create a symlink with a zero-length name.
12938  */
12939 /*{{{ int my_symlink(const char *path1, const char *path2)*/
12940 int my_symlink(const char *path1, const char *path2) {
12941   if (!path2 || !*path2) {
12942     SETERRNO(ENOENT, SS$_NOSUCHFILE);
12943     return -1;
12944   }
12945   return symlink(path1, path2);
12946 }
12947 /*}}}*/
12948
12949 #endif /* HAS_SYMLINK */
12950
12951 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12952 int do_vms_case_tolerant(void);
12953
12954 void
12955 vms_case_tolerant_fromperl(pTHX_ CV *cv)
12956 {
12957   dXSARGS;
12958   ST(0) = boolSV(do_vms_case_tolerant());
12959   XSRETURN(1);
12960 }
12961 #endif
12962
12963 void
12964 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
12965                           struct interp_intern *dst)
12966 {
12967     memcpy(dst,src,sizeof(struct interp_intern));
12968 }
12969
12970 void
12971 Perl_sys_intern_clear(pTHX)
12972 {
12973 }
12974
12975 void
12976 Perl_sys_intern_init(pTHX)
12977 {
12978     unsigned int ix = RAND_MAX;
12979     double x;
12980
12981     VMSISH_HUSHED = 0;
12982
12983     /* fix me later to track running under GNV */
12984     /* this allows some limited testing */
12985     MY_POSIX_EXIT = decc_filename_unix_report;
12986
12987     x = (float)ix;
12988     MY_INV_RAND_MAX = 1./x;
12989 }
12990
12991 void
12992 init_os_extras(void)
12993 {
12994   dTHX;
12995   char* file = __FILE__;
12996   if (decc_disable_to_vms_logname_translation) {
12997     no_translate_barewords = TRUE;
12998   } else {
12999     no_translate_barewords = FALSE;
13000   }
13001
13002   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13003   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13004   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13005   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13006   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13007   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13008   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13009   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13010   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13011   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13012   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13013 #ifdef HAS_SYMLINK
13014   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
13015 #endif
13016 #if __CRTL_VER >= 70301000 && !defined(__VAX)
13017   newXSproto("VMS::Filepec::vms_case_tolerant",
13018              vms_case_tolerant_fromperl, file, "$");
13019 #endif
13020
13021   store_pipelocs(aTHX);         /* will redo any earlier attempts */
13022
13023   return;
13024 }
13025
13026 #ifdef HAS_SYMLINK
13027
13028 #if __CRTL_VER == 80200000
13029 /* This missed getting in to the DECC SDK for 8.2 */
13030 char *realpath(const char *file_name, char * resolved_name, ...);
13031 #endif
13032
13033 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13034 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13035  * The perl fallback routine to provide realpath() is not as efficient
13036  * on OpenVMS.
13037  */
13038
13039 /* Hack, use old stat() as fastest way of getting ino_t and device */
13040 int decc$stat(const char *name, void * statbuf);
13041
13042
13043 /* Realpath is fragile.  In 8.3 it does not work if the feature
13044  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13045  * links are implemented in RMS, not the CRTL. It also can fail if the
13046  * user does not have read/execute access to some of the directories.
13047  * So in order for Do What I Mean mode to work, if realpath() fails,
13048  * fall back to looking up the filename by the device name and FID.
13049  */
13050
13051 int vms_fid_to_name(char * outname, int outlen, const char * name)
13052 {
13053 struct statbuf_t {
13054     char           * st_dev;
13055     __ino16_t      st_ino[3];
13056     unsigned short padw;
13057     unsigned long  padl[30];  /* plenty of room */
13058 } statbuf;
13059 int sts;
13060 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13061 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13062
13063     sts = decc$stat(name, &statbuf);
13064     if (sts == 0) {
13065
13066         dvidsc.dsc$a_pointer=statbuf.st_dev;
13067        dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13068
13069         specdsc.dsc$a_pointer = outname;
13070         specdsc.dsc$w_length = outlen-1;
13071
13072        sts = lib$fid_to_name
13073             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13074        if ($VMS_STATUS_SUCCESS(sts)) {
13075             outname[specdsc.dsc$w_length] = 0;
13076             return 0;
13077         }
13078     }
13079     return sts;
13080 }
13081
13082
13083
13084 static char *
13085 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13086                    int *utf8_fl)
13087 {
13088     char * rslt = NULL;
13089
13090     if (decc_posix_compliant_pathnames)
13091         rslt = realpath(filespec, outbuf);
13092
13093     if (rslt == NULL) {
13094         char * vms_spec;
13095         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13096         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13097         int file_len;
13098
13099         /* Fall back to fid_to_name */
13100
13101         Newx(vms_spec, VMS_MAXRSS + 1, char);
13102
13103          sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec);
13104          if (sts == 0) {
13105
13106
13107             /* Now need to trim the version off */
13108             sts = vms_split_path
13109                   (vms_spec,
13110                    &v_spec,
13111                    &v_len,
13112                    &r_spec,
13113                    &r_len,
13114                    &d_spec,
13115                    &d_len,
13116                    &n_spec,
13117                    &n_len,
13118                    &e_spec,
13119                    &e_len,
13120                    &vs_spec,
13121                    &vs_len);
13122
13123
13124              if (sts == 0) {
13125                 int file_len;
13126
13127                 /* Trim off the version */
13128                 file_len = v_len + r_len + d_len + n_len + e_len;
13129                 vms_spec[file_len] = 0;
13130
13131                 /* The result is expected to be in UNIX format */
13132                 rslt = do_tounixspec(vms_spec, outbuf, 0, utf8_fl);
13133              }
13134          }
13135
13136         Safefree(vms_spec);
13137     }
13138     return rslt;
13139 }
13140
13141 /*}}}*/
13142 /* External entry points */
13143 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13144 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
13145 #else
13146 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13147 { return NULL; }
13148 #endif
13149
13150
13151 #if __CRTL_VER >= 70301000 && !defined(__VAX)
13152 /* case_tolerant */
13153
13154 /*{{{int do_vms_case_tolerant(void)*/
13155 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13156  * controlled by a process setting.
13157  */
13158 int do_vms_case_tolerant(void)
13159 {
13160     return vms_process_case_tolerant;
13161 }
13162 /*}}}*/
13163 /* External entry points */
13164 int Perl_vms_case_tolerant(void)
13165 { return do_vms_case_tolerant(); }
13166 #else
13167 int Perl_vms_case_tolerant(void)
13168 { return vms_process_case_tolerant; }
13169 #endif
13170
13171
13172  /* Start of DECC RTL Feature handling */
13173
13174 static int sys_trnlnm
13175    (const char * logname,
13176     char * value,
13177     int value_len)
13178 {
13179     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
13180     const unsigned long attr = LNM$M_CASE_BLIND;
13181     struct dsc$descriptor_s name_dsc;
13182     int status;
13183     unsigned short result;
13184     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
13185                                 {0, 0, 0, 0}};
13186
13187     name_dsc.dsc$w_length = strlen(logname);
13188     name_dsc.dsc$a_pointer = (char *)logname;
13189     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13190     name_dsc.dsc$b_class = DSC$K_CLASS_S;
13191
13192     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
13193
13194     if ($VMS_STATUS_SUCCESS(status)) {
13195
13196          /* Null terminate and return the string */
13197         /*--------------------------------------*/
13198         value[result] = 0;
13199     }
13200
13201     return status;
13202 }
13203
13204 static int sys_crelnm
13205    (const char * logname,
13206     const char * value)
13207 {
13208     int ret_val;
13209     const char * proc_table = "LNM$PROCESS_TABLE";
13210     struct dsc$descriptor_s proc_table_dsc;
13211     struct dsc$descriptor_s logname_dsc;
13212     struct itmlst_3 item_list[2];
13213
13214     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
13215     proc_table_dsc.dsc$w_length = strlen(proc_table);
13216     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13217     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
13218
13219     logname_dsc.dsc$a_pointer = (char *) logname;
13220     logname_dsc.dsc$w_length = strlen(logname);
13221     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13222     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
13223
13224     item_list[0].buflen = strlen(value);
13225     item_list[0].itmcode = LNM$_STRING;
13226     item_list[0].bufadr = (char *)value;
13227     item_list[0].retlen = NULL;
13228
13229     item_list[1].buflen = 0;
13230     item_list[1].itmcode = 0;
13231
13232     ret_val = sys$crelnm
13233                        (NULL,
13234                         (const struct dsc$descriptor_s *)&proc_table_dsc,
13235                         (const struct dsc$descriptor_s *)&logname_dsc,
13236                         NULL,
13237                         (const struct item_list_3 *) item_list);
13238
13239     return ret_val;
13240 }
13241
13242 /* C RTL Feature settings */
13243
13244 static int set_features
13245    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
13246     int (* cli_routine)(void),  /* Not documented */
13247     void *image_info)           /* Not documented */
13248 {
13249     int status;
13250     int s;
13251     int dflt;
13252     char* str;
13253     char val_str[10];
13254 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13255     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13256     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13257     unsigned long case_perm;
13258     unsigned long case_image;
13259 #endif
13260
13261     /* Allow an exception to bring Perl into the VMS debugger */
13262     vms_debug_on_exception = 0;
13263     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
13264     if ($VMS_STATUS_SUCCESS(status)) {
13265        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13266          vms_debug_on_exception = 1;
13267        else
13268          vms_debug_on_exception = 0;
13269     }
13270
13271     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
13272     vms_vtf7_filenames = 0;
13273     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
13274     if ($VMS_STATUS_SUCCESS(status)) {
13275        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13276          vms_vtf7_filenames = 1;
13277        else
13278          vms_vtf7_filenames = 0;
13279     }
13280
13281
13282     /* unlink all versions on unlink() or rename() */
13283     vms_unlink_all_versions = 0;
13284     status = sys_trnlnm
13285         ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13286     if ($VMS_STATUS_SUCCESS(status)) {
13287        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13288          vms_unlink_all_versions = 1;
13289        else
13290          vms_unlink_all_versions = 0;
13291     }
13292
13293     /* Dectect running under GNV Bash or other UNIX like shell */
13294 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13295     gnv_unix_shell = 0;
13296     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
13297     if ($VMS_STATUS_SUCCESS(status)) {
13298        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13299          gnv_unix_shell = 1;
13300          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
13301          set_feature_default("DECC$EFS_CHARSET", 1);
13302          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
13303          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
13304          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
13305          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
13306          vms_unlink_all_versions = 1;
13307        }
13308        else
13309          gnv_unix_shell = 0;
13310     }
13311 #endif
13312
13313     /* hacks to see if known bugs are still present for testing */
13314
13315     /* Readdir is returning filenames in VMS syntax always */
13316     decc_bug_readdir_efs1 = 1;
13317     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
13318     if ($VMS_STATUS_SUCCESS(status)) {
13319        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13320          decc_bug_readdir_efs1 = 1;
13321        else
13322          decc_bug_readdir_efs1 = 0;
13323     }
13324
13325     /* PCP mode requires creating /dev/null special device file */
13326     decc_bug_devnull = 0;
13327     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
13328     if ($VMS_STATUS_SUCCESS(status)) {
13329        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13330           decc_bug_devnull = 1;
13331        else
13332           decc_bug_devnull = 0;
13333     }
13334
13335     /* fgetname returning a VMS name in UNIX mode */
13336     decc_bug_fgetname = 1;
13337     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
13338     if ($VMS_STATUS_SUCCESS(status)) {
13339       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13340         decc_bug_fgetname = 1;
13341       else
13342         decc_bug_fgetname = 0;
13343     }
13344
13345     /* UNIX directory names with no paths are broken in a lot of places */
13346     decc_dir_barename = 1;
13347     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
13348     if ($VMS_STATUS_SUCCESS(status)) {
13349       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13350         decc_dir_barename = 1;
13351       else
13352         decc_dir_barename = 0;
13353     }
13354
13355 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13356     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
13357     if (s >= 0) {
13358         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
13359         if (decc_disable_to_vms_logname_translation < 0)
13360             decc_disable_to_vms_logname_translation = 0;
13361     }
13362
13363     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
13364     if (s >= 0) {
13365         decc_efs_case_preserve = decc$feature_get_value(s, 1);
13366         if (decc_efs_case_preserve < 0)
13367             decc_efs_case_preserve = 0;
13368     }
13369
13370     s = decc$feature_get_index("DECC$EFS_CHARSET");
13371     if (s >= 0) {
13372         decc_efs_charset = decc$feature_get_value(s, 1);
13373         if (decc_efs_charset < 0)
13374             decc_efs_charset = 0;
13375     }
13376
13377     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
13378     if (s >= 0) {
13379         decc_filename_unix_report = decc$feature_get_value(s, 1);
13380         if (decc_filename_unix_report > 0)
13381             decc_filename_unix_report = 1;
13382         else
13383             decc_filename_unix_report = 0;
13384     }
13385
13386     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
13387     if (s >= 0) {
13388         decc_filename_unix_only = decc$feature_get_value(s, 1);
13389         if (decc_filename_unix_only > 0) {
13390             decc_filename_unix_only = 1;
13391         }
13392         else {
13393             decc_filename_unix_only = 0;
13394         }
13395     }
13396
13397     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
13398     if (s >= 0) {
13399         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
13400         if (decc_filename_unix_no_version < 0)
13401             decc_filename_unix_no_version = 0;
13402     }
13403
13404     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
13405     if (s >= 0) {
13406         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
13407         if (decc_readdir_dropdotnotype < 0)
13408             decc_readdir_dropdotnotype = 0;
13409     }
13410
13411     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
13412     if ($VMS_STATUS_SUCCESS(status)) {
13413         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
13414         if (s >= 0) {
13415             dflt = decc$feature_get_value(s, 4);
13416             if (dflt > 0) {
13417                 decc_disable_posix_root = decc$feature_get_value(s, 1);
13418                 if (decc_disable_posix_root <= 0) {
13419                     decc$feature_set_value(s, 1, 1);
13420                     decc_disable_posix_root = 1;
13421                 }
13422             }
13423             else {
13424                 /* Traditionally Perl assumes this is off */
13425                 decc_disable_posix_root = 1;
13426                 decc$feature_set_value(s, 1, 1);
13427             }
13428         }
13429     }
13430
13431 #if __CRTL_VER >= 80200000
13432     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
13433     if (s >= 0) {
13434         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
13435         if (decc_posix_compliant_pathnames < 0)
13436             decc_posix_compliant_pathnames = 0;
13437         if (decc_posix_compliant_pathnames > 4)
13438             decc_posix_compliant_pathnames = 0;
13439     }
13440
13441 #endif
13442 #else
13443     status = sys_trnlnm
13444         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
13445     if ($VMS_STATUS_SUCCESS(status)) {
13446         val_str[0] = _toupper(val_str[0]);
13447         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13448            decc_disable_to_vms_logname_translation = 1;
13449         }
13450     }
13451
13452 #ifndef __VAX
13453     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
13454     if ($VMS_STATUS_SUCCESS(status)) {
13455         val_str[0] = _toupper(val_str[0]);
13456         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13457            decc_efs_case_preserve = 1;
13458         }
13459     }
13460 #endif
13461
13462     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
13463     if ($VMS_STATUS_SUCCESS(status)) {
13464         val_str[0] = _toupper(val_str[0]);
13465         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13466            decc_filename_unix_report = 1;
13467         }
13468     }
13469     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
13470     if ($VMS_STATUS_SUCCESS(status)) {
13471         val_str[0] = _toupper(val_str[0]);
13472         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13473            decc_filename_unix_only = 1;
13474            decc_filename_unix_report = 1;
13475         }
13476     }
13477     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
13478     if ($VMS_STATUS_SUCCESS(status)) {
13479         val_str[0] = _toupper(val_str[0]);
13480         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13481            decc_filename_unix_no_version = 1;
13482         }
13483     }
13484     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
13485     if ($VMS_STATUS_SUCCESS(status)) {
13486         val_str[0] = _toupper(val_str[0]);
13487         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13488            decc_readdir_dropdotnotype = 1;
13489         }
13490     }
13491 #endif
13492
13493 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13494
13495      /* Report true case tolerance */
13496     /*----------------------------*/
13497     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
13498     if (!$VMS_STATUS_SUCCESS(status))
13499         case_perm = PPROP$K_CASE_BLIND;
13500     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
13501     if (!$VMS_STATUS_SUCCESS(status))
13502         case_image = PPROP$K_CASE_BLIND;
13503     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
13504         (case_image == PPROP$K_CASE_SENSITIVE))
13505         vms_process_case_tolerant = 0;
13506
13507 #endif
13508
13509
13510     /* CRTL can be initialized past this point, but not before. */
13511 /*    DECC$CRTL_INIT(); */
13512
13513     return SS$_NORMAL;
13514 }
13515
13516 #ifdef __DECC
13517 #pragma nostandard
13518 #pragma extern_model save
13519 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
13520         const __align (LONGWORD) int spare[8] = {0};
13521
13522 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
13523 #if __DECC_VER >= 60560002
13524 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
13525 #else
13526 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
13527 #endif
13528 #endif /* __DECC */
13529
13530 const long vms_cc_features = (const long)set_features;
13531
13532 /*
13533 ** Force a reference to LIB$INITIALIZE to ensure it
13534 ** exists in the image.
13535 */
13536 int lib$initialize(void);
13537 #ifdef __DECC
13538 #pragma extern_model strict_refdef
13539 #endif
13540     int lib_init_ref = (int) lib$initialize;
13541
13542 #ifdef __DECC
13543 #pragma extern_model restore
13544 #pragma standard
13545 #endif
13546
13547 /*  End of vms.c */