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_vms_realname(a,b,c)          mp_do_vms_realname(aTHX_ a,b,c)
 276 #define do_tounixspec(a,b,c,d)          mp_do_tounixspec(aTHX_ a,b,c,d)
 277 #define do_tounixpath(a,b,c,d)          mp_do_tounixpath(aTHX_ a,b,c,d)
 278 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 279 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 280 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 281
 282 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
 283 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
 284 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
 285 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
 286
 287 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 288 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 289
 290 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 291  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 292  * the Perl facility.
 293  */
 294 #define PERL_LNM_MAX_ITER 10
 295
 296   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 297 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 298 #define MAX_DCL_SYMBOL          (8192)
 299 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 300 #else
 301 #define MAX_DCL_SYMBOL          (1024)
 302 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 303 #endif
 304
 305 static char *__mystrtolower(char *str)
 306 {
 307   if (str) for (; *str; ++str) *str= tolower(*str);
 308   return str;
 309 }
 310
 311 static struct dsc$descriptor_s fildevdsc =
 312   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 313 static struct dsc$descriptor_s crtlenvdsc =
 314   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 315 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 316 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 317 static struct dsc$descriptor_s **env_tables = defenv;
 318 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 319
 320 /* True if we shouldn't treat barewords as logicals during directory */
 321 /* munching */
 322 static int no_translate_barewords;
 323
 324 #ifndef RTL_USES_UTC
 325 static int tz_updated = 1;
 326 #endif
 327
 328 /* DECC Features that may need to affect how Perl interprets
 329  * displays filename information
 330  */
 331 static int decc_disable_to_vms_logname_translation = 1;
 332 static int decc_disable_posix_root = 1;
 333 int decc_efs_case_preserve = 0;
 334 static int decc_efs_charset = 0;
 335 static int decc_filename_unix_no_version = 0;
 336 static int decc_filename_unix_only = 0;
 337 int decc_filename_unix_report = 0;
 338 int decc_posix_compliant_pathnames = 0;
 339 int decc_readdir_dropdotnotype = 0;
 340 static int vms_process_case_tolerant = 1;
 341 int vms_vtf7_filenames = 0;
 342 int gnv_unix_shell = 0;
 343 static int vms_unlink_all_versions = 0;
 344
 345 /* bug workarounds if needed */
 346 int decc_bug_readdir_efs1 = 0;
 347 int decc_bug_devnull = 1;
 348 int decc_bug_fgetname = 0;
 349 int decc_dir_barename = 0;
 350
 351 static int vms_debug_on_exception = 0;
 352
 353 /* Is this a UNIX file specification?
 354  *   No longer a simple check with EFS file specs
 355  *   For now, not a full check, but need to
 356  *   handle POSIX ^UP^ specifications
 357  *   Fixing to handle ^/ cases would require
 358  *   changes to many other conversion routines.
 359  */
 360
 361 static int is_unix_filespec(const char *path)
 362 {
 363 int ret_val;
 364 const char * pch1;
 365
 366     ret_val = 0;
 367     if (strncmp(path,"\"^UP^",5) != 0) {
 368         pch1 = strchr(path, '/');
 369         if (pch1 != NULL)
 370             ret_val = 1;
 371         else {
 372
 373             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 374             if (decc_filename_unix_report || decc_filename_unix_only) {
 375             if (strcmp(path,".") == 0)
 376                 ret_val = 1;
 377             }
 378         }
 379     }
 380     return ret_val;
 381 }
 382
 383 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 384  */
 385
 386 static void ucs2_to_vtf7
 387    (char *outspec,
 388     unsigned long ucs2_char,
 389     int * output_cnt)
 390 {
 391 unsigned char * ucs_ptr;
 392 int hex;
 393
 394     ucs_ptr = (unsigned char *)&ucs2_char;
 395
 396     outspec[0] = '^';
 397     outspec[1] = 'U';
 398     hex = (ucs_ptr[1] >> 4) & 0xf;
 399     if (hex < 0xA)
 400         outspec[2] = hex + '0';
 401     else
 402         outspec[2] = (hex - 9) + 'A';
 403     hex = ucs_ptr[1] & 0xF;
 404     if (hex < 0xA)
 405         outspec[3] = hex + '0';
 406     else {
 407         outspec[3] = (hex - 9) + 'A';
 408     }
 409     hex = (ucs_ptr[0] >> 4) & 0xf;
 410     if (hex < 0xA)
 411         outspec[4] = hex + '0';
 412     else
 413         outspec[4] = (hex - 9) + 'A';
 414     hex = ucs_ptr[1] & 0xF;
 415     if (hex < 0xA)
 416         outspec[5] = hex + '0';
 417     else {
 418         outspec[5] = (hex - 9) + 'A';
 419     }
 420     *output_cnt = 6;
 421 }
 422
 423
 424 /* This handles the conversion of a UNIX extended character set to a ^
 425  * escaped VMS character.
 426  * in a UNIX file specification.
 427  *
 428  * The output count variable contains the number of characters added
 429  * to the output string.
 430  *
 431  * The return value is the number of characters read from the input string
 432  */
 433 static int copy_expand_unix_filename_escape
 434   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 435 {
 436 int count;
 437 int scnt;
 438 int utf8_flag;
 439
 440     utf8_flag = 0;
 441     if (utf8_fl)
 442       utf8_flag = *utf8_fl;
 443
 444     count = 0;
 445     *output_cnt = 0;
 446     if (*inspec >= 0x80) {
 447         if (utf8_fl && vms_vtf7_filenames) {
 448         unsigned long ucs_char;
 449
 450             ucs_char = 0;
 451
 452             if ((*inspec & 0xE0) == 0xC0) {
 453                 /* 2 byte Unicode */
 454                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 455                 if (ucs_char >= 0x80) {
 456                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 457                     return 2;
 458                 }
 459             } else if ((*inspec & 0xF0) == 0xE0) {
 460                 /* 3 byte Unicode */
 461                 ucs_char = ((inspec[0] & 0xF) << 12) +
 462                    ((inspec[1] & 0x3f) << 6) +
 463                    (inspec[2] & 0x3f);
 464                 if (ucs_char >= 0x800) {
 465                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 466                     return 3;
 467                 }
 468
 469 #if 0 /* I do not see longer sequences supported by OpenVMS */
 470       /* Maybe some one can fix this later */
 471             } else if ((*inspec & 0xF8) == 0xF0) {
 472                 /* 4 byte Unicode */
 473                 /* UCS-4 to UCS-2 */
 474             } else if ((*inspec & 0xFC) == 0xF8) {
 475                 /* 5 byte Unicode */
 476                 /* UCS-4 to UCS-2 */
 477             } else if ((*inspec & 0xFE) == 0xFC) {
 478                 /* 6 byte Unicode */
 479                 /* UCS-4 to UCS-2 */
 480 #endif
 481             }
 482         }
 483
 484         /* High bit set, but not a Unicode character! */
 485
 486         /* Non printing DECMCS or ISO Latin-1 character? */
 487         if (*inspec <= 0x9F) {
 488         int hex;
 489             outspec[0] = '^';
 490             outspec++;
 491             hex = (*inspec >> 4) & 0xF;
 492             if (hex < 0xA)
 493                 outspec[1] = hex + '0';
 494             else {
 495                 outspec[1] = (hex - 9) + 'A';
 496             }
 497             hex = *inspec & 0xF;
 498             if (hex < 0xA)
 499                 outspec[2] = hex + '0';
 500             else {
 501                 outspec[2] = (hex - 9) + 'A';
 502             }
 503             *output_cnt = 3;
 504             return 1;
 505         } else if (*inspec == 0xA0) {
 506             outspec[0] = '^';
 507             outspec[1] = 'A';
 508             outspec[2] = '0';
 509             *output_cnt = 3;
 510             return 1;
 511         } else if (*inspec == 0xFF) {
 512             outspec[0] = '^';
 513             outspec[1] = 'F';
 514             outspec[2] = 'F';
 515             *output_cnt = 3;
 516             return 1;
 517         }
 518         *outspec = *inspec;
 519         *output_cnt = 1;
 520         return 1;
 521     }
 522
 523     /* Is this a macro that needs to be passed through?
 524      * Macros start with $( and an alpha character, followed
 525      * by a string of alpha numeric characters ending with a )
 526      * If this does not match, then encode it as ODS-5.
 527      */
 528     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 529     int tcnt;
 530
 531         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 532             tcnt = 3;
 533             outspec[0] = inspec[0];
 534             outspec[1] = inspec[1];
 535             outspec[2] = inspec[2];
 536
 537             while(isalnum(inspec[tcnt]) ||
 538                   (inspec[2] == '.') || (inspec[2] == '_')) {
 539                 outspec[tcnt] = inspec[tcnt];
 540                 tcnt++;
 541             }
 542             if (inspec[tcnt] == ')') {
 543                 outspec[tcnt] = inspec[tcnt];
 544                 tcnt++;
 545                 *output_cnt = tcnt;
 546                 return tcnt;
 547             }
 548         }
 549     }
 550
 551     switch (*inspec) {
 552     case 0x7f:
 553         outspec[0] = '^';
 554         outspec[1] = '7';
 555         outspec[2] = 'F';
 556         *output_cnt = 3;
 557         return 1;
 558         break;
 559     case '?':
 560         if (decc_efs_charset == 0)
 561           outspec[0] = '%';
 562         else
 563           outspec[0] = '?';
 564         *output_cnt = 1;
 565         return 1;
 566         break;
 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     case '^':
 586         /* Don't escape again if following character is
 587          * already something we escape.
 588          */
 589         if (strchr(".~!#&\'`()+@{},;[]%^=_", *(inspec+1))) {
 590             *outspec = *inspec;
 591             *output_cnt = 1;
 592             return 1;
 593             break;
 594         }
 595         /* But otherwise fall through and escape it. */
 596     case '=':
 597         /* Assume that this is to be escaped */
 598         outspec[0] = '^';
 599         outspec[1] = *inspec;
 600         *output_cnt = 2;
 601         return 1;
 602         break;
 603     case ' ': /* space */
 604         /* Assume that this is to be escaped */
 605         outspec[0] = '^';
 606         outspec[1] = '_';
 607         *output_cnt = 2;
 608         return 1;
 609         break;
 610     default:
 611         *outspec = *inspec;
 612         *output_cnt = 1;
 613         return 1;
 614         break;
 615     }
 616 }
 617
 618
 619 /* This handles the expansion of a '^' prefix to the proper character
 620  * in a UNIX file specification.
 621  *
 622  * The output count variable contains the number of characters added
 623  * to the output string.
 624  *
 625  * The return value is the number of characters read from the input
 626  * string
 627  */
 628 static int copy_expand_vms_filename_escape
 629   (char *outspec, const char *inspec, int *output_cnt)
 630 {
 631 int count;
 632 int scnt;
 633
 634     count = 0;
 635     *output_cnt = 0;
 636     if (*inspec == '^') {
 637         inspec++;
 638         switch (*inspec) {
 639         /* Spaces and non-trailing dots should just be passed through,
 640          * but eat the escape character.
 641          */
 642         case '.':
 643             *outspec = *inspec;
 644             count += 2;
 645             (*output_cnt)++;
 646             break;
 647         case '_': /* space */
 648             *outspec = ' ';
 649             count += 2;
 650             (*output_cnt)++;
 651             break;
 652         case '^':
 653             /* Hmm.  Better leave the escape escaped. */
 654             outspec[0] = '^';
 655             outspec[1] = '^';
 656             count += 2;
 657             (*output_cnt) += 2;
 658             break;
 659         case 'U': /* Unicode - FIX-ME this is wrong. */
 660             inspec++;
 661             count++;
 662             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 663             if (scnt == 4) {
 664                 unsigned int c1, c2;
 665                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 666                 outspec[0] == c1 & 0xff;
 667                 outspec[1] == c2 & 0xff;
 668                 if (scnt > 1) {
 669                     (*output_cnt) += 2;
 670                     count += 4;
 671                 }
 672             }
 673             else {
 674                 /* Error - do best we can to continue */
 675                 *outspec = 'U';
 676                 outspec++;
 677                 (*output_cnt++);
 678                 *outspec = *inspec;
 679                 count++;
 680                 (*output_cnt++);
 681             }
 682             break;
 683         default:
 684             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 685             if (scnt == 2) {
 686                 /* Hex encoded */
 687                 unsigned int c1;
 688                 scnt = sscanf(inspec, "%2x", &c1);
 689                 outspec[0] = c1 & 0xff;
 690                 if (scnt > 0) {
 691                     (*output_cnt++);
 692                     count += 2;
 693                 }
 694             }
 695             else {
 696                 *outspec = *inspec;
 697                 count++;
 698                 (*output_cnt++);
 699             }
 700         }
 701     }
 702     else {
 703         *outspec = *inspec;
 704         count++;
 705         (*output_cnt)++;
 706     }
 707     return count;
 708 }
 709
 710 #ifdef sys$filescan
 711 #undef sys$filescan
 712 int sys$filescan
 713    (const struct dsc$descriptor_s * srcstr,
 714     struct filescan_itmlst_2 * valuelist,
 715     unsigned long * fldflags,
 716     struct dsc$descriptor_s *auxout,
 717     unsigned short * retlen);
 718 #endif
 719
 720 /* vms_split_path - Verify that the input file specification is a
 721  * VMS format file specification, and provide pointers to the components of
 722  * it.  With EFS format filenames, this is virtually the only way to
 723  * parse a VMS path specification into components.
 724  *
 725  * If the sum of the components do not add up to the length of the
 726  * string, then the passed file specification is probably a UNIX style
 727  * path.
 728  */
 729 static int vms_split_path
 730    (const char * path,
 731     char * * volume,
 732     int * vol_len,
 733     char * * root,
 734     int * root_len,
 735     char * * dir,
 736     int * dir_len,
 737     char * * name,
 738     int * name_len,
 739     char * * ext,
 740     int * ext_len,
 741     char * * version,
 742     int * ver_len)
 743 {
 744 struct dsc$descriptor path_desc;
 745 int status;
 746 unsigned long flags;
 747 int ret_stat;
 748 struct filescan_itmlst_2 item_list[9];
 749 const int filespec = 0;
 750 const int nodespec = 1;
 751 const int devspec = 2;
 752 const int rootspec = 3;
 753 const int dirspec = 4;
 754 const int namespec = 5;
 755 const int typespec = 6;
 756 const int verspec = 7;
 757
 758     /* Assume the worst for an easy exit */
 759     ret_stat = -1;
 760     *volume = NULL;
 761     *vol_len = 0;
 762     *root = NULL;
 763     *root_len = 0;
 764     *dir = NULL;
 765     *dir_len;
 766     *name = NULL;
 767     *name_len = 0;
 768     *ext = NULL;
 769     *ext_len = 0;
 770     *version = NULL;
 771     *ver_len = 0;
 772
 773     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 774     path_desc.dsc$w_length = strlen(path);
 775     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 776     path_desc.dsc$b_class = DSC$K_CLASS_S;
 777
 778     /* Get the total length, if it is shorter than the string passed
 779      * then this was probably not a VMS formatted file specification
 780      */
 781     item_list[filespec].itmcode = FSCN$_FILESPEC;
 782     item_list[filespec].length = 0;
 783     item_list[filespec].component = NULL;
 784
 785     /* If the node is present, then it gets considered as part of the
 786      * volume name to hopefully make things simple.
 787      */
 788     item_list[nodespec].itmcode = FSCN$_NODE;
 789     item_list[nodespec].length = 0;
 790     item_list[nodespec].component = NULL;
 791
 792     item_list[devspec].itmcode = FSCN$_DEVICE;
 793     item_list[devspec].length = 0;
 794     item_list[devspec].component = NULL;
 795
 796     /* root is a special case,  adding it to either the directory or
 797      * the device components will probalby complicate things for the
 798      * callers of this routine, so leave it separate.
 799      */
 800     item_list[rootspec].itmcode = FSCN$_ROOT;
 801     item_list[rootspec].length = 0;
 802     item_list[rootspec].component = NULL;
 803
 804     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 805     item_list[dirspec].length = 0;
 806     item_list[dirspec].component = NULL;
 807
 808     item_list[namespec].itmcode = FSCN$_NAME;
 809     item_list[namespec].length = 0;
 810     item_list[namespec].component = NULL;
 811
 812     item_list[typespec].itmcode = FSCN$_TYPE;
 813     item_list[typespec].length = 0;
 814     item_list[typespec].component = NULL;
 815
 816     item_list[verspec].itmcode = FSCN$_VERSION;
 817     item_list[verspec].length = 0;
 818     item_list[verspec].component = NULL;
 819
 820     item_list[8].itmcode = 0;
 821     item_list[8].length = 0;
 822     item_list[8].component = NULL;
 823
 824     status = sys$filescan
 825        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 826         &flags, NULL, NULL);
 827     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 828
 829     /* If we parsed it successfully these two lengths should be the same */
 830     if (path_desc.dsc$w_length != item_list[filespec].length)
 831         return ret_stat;
 832
 833     /* If we got here, then it is a VMS file specification */
 834     ret_stat = 0;
 835
 836     /* set the volume name */
 837     if (item_list[nodespec].length > 0) {
 838         *volume = item_list[nodespec].component;
 839         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 840     }
 841     else {
 842         *volume = item_list[devspec].component;
 843         *vol_len = item_list[devspec].length;
 844     }
 845
 846     *root = item_list[rootspec].component;
 847     *root_len = item_list[rootspec].length;
 848
 849     *dir = item_list[dirspec].component;
 850     *dir_len = item_list[dirspec].length;
 851
 852     /* Now fun with versions and EFS file specifications
 853      * The parser can not tell the difference when a "." is a version
 854      * delimiter or a part of the file specification.
 855      */
 856     if ((decc_efs_charset) &&
 857         (item_list[verspec].length > 0) &&
 858         (item_list[verspec].component[0] == '.')) {
 859         *name = item_list[namespec].component;
 860         *name_len = item_list[namespec].length + item_list[typespec].length;
 861         *ext = item_list[verspec].component;
 862         *ext_len = item_list[verspec].length;
 863         *version = NULL;
 864         *ver_len = 0;
 865     }
 866     else {
 867         *name = item_list[namespec].component;
 868         *name_len = item_list[namespec].length;
 869         *ext = item_list[typespec].component;
 870         *ext_len = item_list[typespec].length;
 871         *version = item_list[verspec].component;
 872         *ver_len = item_list[verspec].length;
 873     }
 874     return ret_stat;
 875 }
 876
 877
 878 /* my_maxidx
 879  * Routine to retrieve the maximum equivalence index for an input
 880  * logical name.  Some calls to this routine have no knowledge if
 881  * the variable is a logical or not.  So on error we return a max
 882  * index of zero.
 883  */
 884 /*{{{int my_maxidx(const char *lnm) */
 885 static int
 886 my_maxidx(const char *lnm)
 887 {
 888     int status;
 889     int midx;
 890     int attr = LNM$M_CASE_BLIND;
 891     struct dsc$descriptor lnmdsc;
 892     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 893                                 {0, 0, 0, 0}};
 894
 895     lnmdsc.dsc$w_length = strlen(lnm);
 896     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 897     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 898     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 899
 900     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 901     if ((status & 1) == 0)
 902        midx = 0;
 903
 904     return (midx);
 905 }
 906 /*}}}*/
 907
 908 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 909 int
 910 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 911   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 912 {
 913     const char *cp1;
 914     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 915     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 916     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 917     int midx;
 918     unsigned char acmode;
 919     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 920                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 921     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 922                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 923                                  {0, 0, 0, 0}};
 924     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 925 #if defined(PERL_IMPLICIT_CONTEXT)
 926     pTHX = NULL;
 927     if (PL_curinterp) {
 928       aTHX = PERL_GET_INTERP;
 929     } else {
 930       aTHX = NULL;
 931     }
 932 #endif
 933
 934     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 935       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 936     }
 937     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 938       *cp2 = _toupper(*cp1);
 939       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 940         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 941         return 0;
 942       }
 943     }
 944     lnmdsc.dsc$w_length = cp1 - lnm;
 945     lnmdsc.dsc$a_pointer = uplnm;
 946     uplnm[lnmdsc.dsc$w_length] = '\0';
 947     secure = flags & PERL__TRNENV_SECURE;
 948     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 949     if (!tabvec || !*tabvec) tabvec = env_tables;
 950
 951     for (curtab = 0; tabvec[curtab]; curtab++) {
 952       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 953         if (!ivenv && !secure) {
 954           char *eq, *end;
 955           int i;
 956           if (!environ) {
 957             ivenv = 1;
 958             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 959             continue;
 960           }
 961           retsts = SS$_NOLOGNAM;
 962           for (i = 0; environ[i]; i++) {
 963             if ((eq = strchr(environ[i],'=')) &&
 964                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 965                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 966               eq++;
 967               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 968               if (!eqvlen) continue;
 969               retsts = SS$_NORMAL;
 970               break;
 971             }
 972           }
 973           if (retsts != SS$_NOLOGNAM) break;
 974         }
 975       }
 976       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 977                !str$case_blind_compare(&tmpdsc,&clisym)) {
 978         if (!ivsym && !secure) {
 979           unsigned short int deflen = LNM$C_NAMLENGTH;
 980           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 981           /* dynamic dsc to accomodate possible long value */
 982           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 983           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 984           if (retsts & 1) {
 985             if (eqvlen > MAX_DCL_SYMBOL) {
 986               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 987               eqvlen = MAX_DCL_SYMBOL;
 988               /* Special hack--we might be called before the interpreter's */
 989               /* fully initialized, in which case either thr or PL_curcop */
 990               /* might be bogus. We have to check, since ckWARN needs them */
 991               /* both to be valid if running threaded */
 992                 if (ckWARN(WARN_MISC)) {
 993                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 994                 }
 995             }
 996             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 997           }
 998           _ckvmssts(lib$sfree1_dd(&eqvdsc));
 999           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1000           if (retsts == LIB$_NOSUCHSYM) continue;
1001           break;
1002         }
1003       }
1004       else if (!ivlnm) {
1005         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
1006           midx = my_maxidx(lnm);
1007           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1008             lnmlst[1].bufadr = cp2;
1009             eqvlen = 0;
1010             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1011             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1012             if (retsts == SS$_NOLOGNAM) break;
1013             /* PPFs have a prefix */
1014             if (
1015 #if INTSIZE == 4
1016                  *((int *)uplnm) == *((int *)"SYS$")                    &&
1017 #endif
1018                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
1019                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
1020                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
1021                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
1022                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
1023               memmove(eqv,eqv+4,eqvlen-4);
1024               eqvlen -= 4;
1025             }
1026             cp2 += eqvlen;
1027             *cp2 = '\0';
1028           }
1029           if ((retsts == SS$_IVLOGNAM) ||
1030               (retsts == SS$_NOLOGNAM)) { continue; }
1031         }
1032         else {
1033           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1034           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1035           if (retsts == SS$_NOLOGNAM) continue;
1036           eqv[eqvlen] = '\0';
1037         }
1038         eqvlen = strlen(eqv);
1039         break;
1040       }
1041     }
1042     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1043     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1044              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
1045              retsts == SS$_NOLOGNAM) {
1046       set_errno(EINVAL);  set_vaxc_errno(retsts);
1047     }
1048     else _ckvmssts(retsts);
1049     return 0;
1050 }  /* end of vmstrnenv */
1051 /*}}}*/
1052
1053 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1054 /* Define as a function so we can access statics. */
1055 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1056 {
1057   return vmstrnenv(lnm,eqv,idx,fildev,
1058 #ifdef SECURE_INTERNAL_GETENV
1059                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
1060 #else
1061                    0
1062 #endif
1063                                                                               );
1064 }
1065 /*}}}*/
1066
1067 /* my_getenv
1068  * Note: Uses Perl temp to store result so char * can be returned to
1069  * caller; this pointer will be invalidated at next Perl statement
1070  * transition.
1071  * We define this as a function rather than a macro in terms of my_getenv_len()
1072  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1073  * allocate SVs).
1074  */
1075 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1076 char *
1077 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1078 {
1079     const char *cp1;
1080     static char *__my_getenv_eqv = NULL;
1081     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1082     unsigned long int idx = 0;
1083     int trnsuccess, success, secure, saverr, savvmserr;
1084     int midx, flags;
1085     SV *tmpsv;
1086
1087     midx = my_maxidx(lnm) + 1;
1088
1089     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1090       /* Set up a temporary buffer for the return value; Perl will
1091        * clean it up at the next statement transition */
1092       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1093       if (!tmpsv) return NULL;
1094       eqv = SvPVX(tmpsv);
1095     }
1096     else {
1097       /* Assume no interpreter ==> single thread */
1098       if (__my_getenv_eqv != NULL) {
1099         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1100       }
1101       else {
1102         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1103       }
1104       eqv = __my_getenv_eqv;
1105     }
1106
1107     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1108     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1109       int len;
1110       getcwd(eqv,LNM$C_NAMLENGTH);
1111
1112       len = strlen(eqv);
1113
1114       /* Get rid of "000000/ in rooted filespecs */
1115       if (len > 7) {
1116         char * zeros;
1117         zeros = strstr(eqv, "/000000/");
1118         if (zeros != NULL) {
1119           int mlen;
1120           mlen = len - (zeros - eqv) - 7;
1121           memmove(zeros, &zeros[7], mlen);
1122           len = len - 7;
1123           eqv[len] = '\0';
1124         }
1125       }
1126       return eqv;
1127     }
1128     else {
1129       /* Impose security constraints only if tainting */
1130       if (sys) {
1131         /* Impose security constraints only if tainting */
1132         secure = PL_curinterp ? PL_tainting : will_taint;
1133         saverr = errno;  savvmserr = vaxc$errno;
1134       }
1135       else {
1136         secure = 0;
1137       }
1138
1139       flags =
1140 #ifdef SECURE_INTERNAL_GETENV
1141               secure ? PERL__TRNENV_SECURE : 0
1142 #else
1143               0
1144 #endif
1145       ;
1146
1147       /* For the getenv interface we combine all the equivalence names
1148        * of a search list logical into one value to acquire a maximum
1149        * value length of 255*128 (assuming %ENV is using logicals).
1150        */
1151       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1152
1153       /* If the name contains a semicolon-delimited index, parse it
1154        * off and make sure we only retrieve the equivalence name for
1155        * that index.  */
1156       if ((cp2 = strchr(lnm,';')) != NULL) {
1157         strcpy(uplnm,lnm);
1158         uplnm[cp2-lnm] = '\0';
1159         idx = strtoul(cp2+1,NULL,0);
1160         lnm = uplnm;
1161         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1162       }
1163
1164       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1165
1166       /* Discard NOLOGNAM on internal calls since we're often looking
1167        * for an optional name, and this "error" often shows up as the
1168        * (bogus) exit status for a die() call later on.  */
1169       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1170       return success ? eqv : Nullch;
1171     }
1172
1173 }  /* end of my_getenv() */
1174 /*}}}*/
1175
1176
1177 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1178 char *
1179 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1180 {
1181     const char *cp1;
1182     char *buf, *cp2;
1183     unsigned long idx = 0;
1184     int midx, flags;
1185     static char *__my_getenv_len_eqv = NULL;
1186     int secure, saverr, savvmserr;
1187     SV *tmpsv;
1188
1189     midx = my_maxidx(lnm) + 1;
1190
1191     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1192       /* Set up a temporary buffer for the return value; Perl will
1193        * clean it up at the next statement transition */
1194       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1195       if (!tmpsv) return NULL;
1196       buf = SvPVX(tmpsv);
1197     }
1198     else {
1199       /* Assume no interpreter ==> single thread */
1200       if (__my_getenv_len_eqv != NULL) {
1201         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1202       }
1203       else {
1204         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1205       }
1206       buf = __my_getenv_len_eqv;
1207     }
1208
1209     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1210     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1211     char * zeros;
1212
1213       getcwd(buf,LNM$C_NAMLENGTH);
1214       *len = strlen(buf);
1215
1216       /* Get rid of "000000/ in rooted filespecs */
1217       if (*len > 7) {
1218       zeros = strstr(buf, "/000000/");
1219       if (zeros != NULL) {
1220         int mlen;
1221         mlen = *len - (zeros - buf) - 7;
1222         memmove(zeros, &zeros[7], mlen);
1223         *len = *len - 7;
1224         buf[*len] = '\0';
1225         }
1226       }
1227       return buf;
1228     }
1229     else {
1230       if (sys) {
1231         /* Impose security constraints only if tainting */
1232         secure = PL_curinterp ? PL_tainting : will_taint;
1233         saverr = errno;  savvmserr = vaxc$errno;
1234       }
1235       else {
1236         secure = 0;
1237       }
1238
1239       flags =
1240 #ifdef SECURE_INTERNAL_GETENV
1241               secure ? PERL__TRNENV_SECURE : 0
1242 #else
1243               0
1244 #endif
1245       ;
1246
1247       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1248
1249       if ((cp2 = strchr(lnm,';')) != NULL) {
1250         strcpy(buf,lnm);
1251         buf[cp2-lnm] = '\0';
1252         idx = strtoul(cp2+1,NULL,0);
1253         lnm = buf;
1254         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1255       }
1256
1257       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1258
1259       /* Get rid of "000000/ in rooted filespecs */
1260       if (*len > 7) {
1261       char * zeros;
1262         zeros = strstr(buf, "/000000/");
1263         if (zeros != NULL) {
1264           int mlen;
1265           mlen = *len - (zeros - buf) - 7;
1266           memmove(zeros, &zeros[7], mlen);
1267           *len = *len - 7;
1268           buf[*len] = '\0';
1269         }
1270       }
1271
1272       /* Discard NOLOGNAM on internal calls since we're often looking
1273        * for an optional name, and this "error" often shows up as the
1274        * (bogus) exit status for a die() call later on.  */
1275       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1276       return *len ? buf : Nullch;
1277     }
1278
1279 }  /* end of my_getenv_len() */
1280 /*}}}*/
1281
1282 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
1283
1284 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1285
1286 /*{{{ void prime_env_iter() */
1287 void
1288 prime_env_iter(void)
1289 /* Fill the %ENV associative array with all logical names we can
1290  * find, in preparation for iterating over it.
1291  */
1292 {
1293   static int primed = 0;
1294   HV *seenhv = NULL, *envhv;
1295   SV *sv = NULL;
1296   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
1297   unsigned short int chan;
1298 #ifndef CLI$M_TRUSTED
1299 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1300 #endif
1301   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1302   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1303   long int i;
1304   bool have_sym = FALSE, have_lnm = FALSE;
1305   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1306   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1307   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1308   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1309   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1310 #if defined(PERL_IMPLICIT_CONTEXT)
1311   pTHX;
1312 #endif
1313 #if defined(USE_ITHREADS)
1314   static perl_mutex primenv_mutex;
1315   MUTEX_INIT(&primenv_mutex);
1316 #endif
1317
1318 #if defined(PERL_IMPLICIT_CONTEXT)
1319     /* We jump through these hoops because we can be called at */
1320     /* platform-specific initialization time, which is before anything is */
1321     /* set up--we can't even do a plain dTHX since that relies on the */
1322     /* interpreter structure to be initialized */
1323     if (PL_curinterp) {
1324       aTHX = PERL_GET_INTERP;
1325     } else {
1326       aTHX = NULL;
1327     }
1328 #endif
1329
1330   if (primed || !PL_envgv) return;
1331   MUTEX_LOCK(&primenv_mutex);
1332   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1333   envhv = GvHVn(PL_envgv);
1334   /* Perform a dummy fetch as an lval to insure that the hash table is
1335    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1336   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1337
1338   for (i = 0; env_tables[i]; i++) {
1339      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1340          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1341      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1342   }
1343   if (have_sym || have_lnm) {
1344     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1345     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1346     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1347     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1348   }
1349
1350   for (i--; i >= 0; i--) {
1351     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1352       char *start;
1353       int j;
1354       for (j = 0; environ[j]; j++) {
1355         if (!(start = strchr(environ[j],'='))) {
1356           if (ckWARN(WARN_INTERNAL))
1357             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1358         }
1359         else {
1360           start++;
1361           sv = newSVpv(start,0);
1362           SvTAINTED_on(sv);
1363           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1364         }
1365       }
1366       continue;
1367     }
1368     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1369              !str$case_blind_compare(&tmpdsc,&clisym)) {
1370       strcpy(cmd,"Show Symbol/Global *");
1371       cmddsc.dsc$w_length = 20;
1372       if (env_tables[i]->dsc$w_length == 12 &&
1373           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1374           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1375       flags = defflags | CLI$M_NOLOGNAM;
1376     }
1377     else {
1378       strcpy(cmd,"Show Logical *");
1379       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1380         strcat(cmd," /Table=");
1381         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1382         cmddsc.dsc$w_length = strlen(cmd);
1383       }
1384       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1385       flags = defflags | CLI$M_NOCLISYM;
1386     }
1387
1388     /* Create a new subprocess to execute each command, to exclude the
1389      * remote possibility that someone could subvert a mbx or file used
1390      * to write multiple commands to a single subprocess.
1391      */
1392     do {
1393       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1394                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1395       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1396       defflags &= ~CLI$M_TRUSTED;
1397     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1398     _ckvmssts(retsts);
1399     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1400     if (seenhv) SvREFCNT_dec(seenhv);
1401     seenhv = newHV();
1402     while (1) {
1403       char *cp1, *cp2, *key;
1404       unsigned long int sts, iosb[2], retlen, keylen;
1405       register U32 hash;
1406
1407       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1408       if (sts & 1) sts = iosb[0] & 0xffff;
1409       if (sts == SS$_ENDOFFILE) {
1410         int wakect = 0;
1411         while (substs == 0) { sys$hiber(); wakect++;}
1412         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1413         _ckvmssts(substs);
1414         break;
1415       }
1416       _ckvmssts(sts);
1417       retlen = iosb[0] >> 16;
1418       if (!retlen) continue;  /* blank line */
1419       buf[retlen] = '\0';
1420       if (iosb[1] != subpid) {
1421         if (iosb[1]) {
1422           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1423         }
1424         continue;
1425       }
1426       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1427         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1428
1429       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1430       if (*cp1 == '(' || /* Logical name table name */
1431           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1432       if (*cp1 == '"') cp1++;
1433       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1434       key = cp1;  keylen = cp2 - cp1;
1435       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1436       while (*cp2 && *cp2 != '=') cp2++;
1437       while (*cp2 && *cp2 == '=') cp2++;
1438       while (*cp2 && *cp2 == ' ') cp2++;
1439       if (*cp2 == '"') {  /* String translation; may embed "" */
1440         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1441         cp2++;  cp1--; /* Skip "" surrounding translation */
1442       }
1443       else {  /* Numeric translation */
1444         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1445         cp1--;  /* stop on last non-space char */
1446       }
1447       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1448         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1449         continue;
1450       }
1451       PERL_HASH(hash,key,keylen);
1452
1453       if (cp1 == cp2 && *cp2 == '.') {
1454         /* A single dot usually means an unprintable character, such as a null
1455          * to indicate a zero-length value.  Get the actual value to make sure.
1456          */
1457         char lnm[LNM$C_NAMLENGTH+1];
1458         char eqv[MAX_DCL_SYMBOL+1];
1459         int trnlen;
1460         strncpy(lnm, key, keylen);
1461         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1462         sv = newSVpvn(eqv, strlen(eqv));
1463       }
1464       else {
1465         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1466       }
1467
1468       SvTAINTED_on(sv);
1469       hv_store(envhv,key,keylen,sv,hash);
1470       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1471     }
1472     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1473       /* get the PPFs for this process, not the subprocess */
1474       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1475       char eqv[LNM$C_NAMLENGTH+1];
1476       int trnlen, i;
1477       for (i = 0; ppfs[i]; i++) {
1478         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1479         sv = newSVpv(eqv,trnlen);
1480         SvTAINTED_on(sv);
1481         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1482       }
1483     }
1484   }
1485   primed = 1;
1486   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1487   if (buf) Safefree(buf);
1488   if (seenhv) SvREFCNT_dec(seenhv);
1489   MUTEX_UNLOCK(&primenv_mutex);
1490   return;
1491
1492 }  /* end of prime_env_iter */
1493 /*}}}*/
1494
1495
1496 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1497 /* Define or delete an element in the same "environment" as
1498  * vmstrnenv().  If an element is to be deleted, it's removed from
1499  * the first place it's found.  If it's to be set, it's set in the
1500  * place designated by the first element of the table vector.
1501  * Like setenv() returns 0 for success, non-zero on error.
1502  */
1503 int
1504 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1505 {
1506     const char *cp1;
1507     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1508     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1509     int nseg = 0, j;
1510     unsigned long int retsts, usermode = PSL$C_USER;
1511     struct itmlst_3 *ile, *ilist;
1512     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1513                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1514                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1515     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1516     $DESCRIPTOR(local,"_LOCAL");
1517
1518     if (!lnm) {
1519         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1520         return SS$_IVLOGNAM;
1521     }
1522
1523     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1524       *cp2 = _toupper(*cp1);
1525       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1526         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1527         return SS$_IVLOGNAM;
1528       }
1529     }
1530     lnmdsc.dsc$w_length = cp1 - lnm;
1531     if (!tabvec || !*tabvec) tabvec = env_tables;
1532
1533     if (!eqv) {  /* we're deleting n element */
1534       for (curtab = 0; tabvec[curtab]; curtab++) {
1535         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1536         int i;
1537           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1538             if ((cp1 = strchr(environ[i],'=')) &&
1539                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1540                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1541 #ifdef HAS_SETENV
1542               return setenv(lnm,"",1) ? vaxc$errno : 0;
1543             }
1544           }
1545           ivenv = 1; retsts = SS$_NOLOGNAM;
1546 #else
1547               if (ckWARN(WARN_INTERNAL))
1548                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1549               ivenv = 1; retsts = SS$_NOSUCHPGM;
1550               break;
1551             }
1552           }
1553 #endif
1554         }
1555         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1556                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1557           unsigned int symtype;
1558           if (tabvec[curtab]->dsc$w_length == 12 &&
1559               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1560               !str$case_blind_compare(&tmpdsc,&local))
1561             symtype = LIB$K_CLI_LOCAL_SYM;
1562           else symtype = LIB$K_CLI_GLOBAL_SYM;
1563           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1564           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1565           if (retsts == LIB$_NOSUCHSYM) continue;
1566           break;
1567         }
1568         else if (!ivlnm) {
1569           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1570           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1571           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1572           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1573           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1574         }
1575       }
1576     }
1577     else {  /* we're defining a value */
1578       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1579 #ifdef HAS_SETENV
1580         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1581 #else
1582         if (ckWARN(WARN_INTERNAL))
1583           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1584         retsts = SS$_NOSUCHPGM;
1585 #endif
1586       }
1587       else {
1588         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1589         eqvdsc.dsc$w_length  = strlen(eqv);
1590         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1591             !str$case_blind_compare(&tmpdsc,&clisym)) {
1592           unsigned int symtype;
1593           if (tabvec[0]->dsc$w_length == 12 &&
1594               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1595                !str$case_blind_compare(&tmpdsc,&local))
1596             symtype = LIB$K_CLI_LOCAL_SYM;
1597           else symtype = LIB$K_CLI_GLOBAL_SYM;
1598           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1599         }
1600         else {
1601           if (!*eqv) eqvdsc.dsc$w_length = 1;
1602           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1603
1604             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1605             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1606               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1607                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1608               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1609               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1610             }
1611
1612             Newx(ilist,nseg+1,struct itmlst_3);
1613             ile = ilist;
1614             if (!ile) {
1615               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1616               return SS$_INSFMEM;
1617             }
1618             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1619
1620             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1621               ile->itmcode = LNM$_STRING;
1622               ile->bufadr = c;
1623               if ((j+1) == nseg) {
1624                 ile->buflen = strlen(c);
1625                 /* in case we are truncating one that's too long */
1626                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1627               }
1628               else {
1629                 ile->buflen = LNM$C_NAMLENGTH;
1630               }
1631             }
1632
1633             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1634             Safefree (ilist);
1635           }
1636           else {
1637             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1638           }
1639         }
1640       }
1641     }
1642     if (!(retsts & 1)) {
1643       switch (retsts) {
1644         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1645         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1646           set_errno(EVMSERR); break;
1647         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1648         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1649           set_errno(EINVAL); break;
1650         case SS$_NOPRIV:
1651           set_errno(EACCES); break;
1652         default:
1653           _ckvmssts(retsts);
1654           set_errno(EVMSERR);
1655        }
1656        set_vaxc_errno(retsts);
1657        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1658     }
1659     else {
1660       /* We reset error values on success because Perl does an hv_fetch()
1661        * before each hv_store(), and if the thing we're setting didn't
1662        * previously exist, we've got a leftover error message.  (Of course,
1663        * this fails in the face of
1664        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1665        * in that the error reported in $! isn't spurious,
1666        * but it's right more often than not.)
1667        */
1668       set_errno(0); set_vaxc_errno(retsts);
1669       return 0;
1670     }
1671
1672 }  /* end of vmssetenv() */
1673 /*}}}*/
1674
1675 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1676 /* This has to be a function since there's a prototype for it in proto.h */
1677 void
1678 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1679 {
1680     if (lnm && *lnm) {
1681       int len = strlen(lnm);
1682       if  (len == 7) {
1683         char uplnm[8];
1684         int i;
1685         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1686         if (!strcmp(uplnm,"DEFAULT")) {
1687           if (eqv && *eqv) my_chdir(eqv);
1688           return;
1689         }
1690     }
1691 #ifndef RTL_USES_UTC
1692     if (len == 6 || len == 2) {
1693       char uplnm[7];
1694       int i;
1695       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1696       uplnm[len] = '\0';
1697       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1698       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1699     }
1700 #endif
1701   }
1702   (void) vmssetenv(lnm,eqv,NULL);
1703 }
1704 /*}}}*/
1705
1706 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1707 /*  vmssetuserlnm
1708  *  sets a user-mode logical in the process logical name table
1709  *  used for redirection of sys$error
1710  */
1711 void
1712 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1713 {
1714     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1715     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1716     unsigned long int iss, attr = LNM$M_CONFINE;
1717     unsigned char acmode = PSL$C_USER;
1718     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1719                                  {0, 0, 0, 0}};
1720     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1721     d_name.dsc$w_length = strlen(name);
1722
1723     lnmlst[0].buflen = strlen(eqv);
1724     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1725
1726     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1727     if (!(iss&1)) lib$signal(iss);
1728 }
1729 /*}}}*/
1730
1731
1732 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1733 /* my_crypt - VMS password hashing
1734  * my_crypt() provides an interface compatible with the Unix crypt()
1735  * C library function, and uses sys$hash_password() to perform VMS
1736  * password hashing.  The quadword hashed password value is returned
1737  * as a NUL-terminated 8 character string.  my_crypt() does not change
1738  * the case of its string arguments; in order to match the behavior
1739  * of LOGINOUT et al., alphabetic characters in both arguments must
1740  *  be upcased by the caller.
1741  *
1742  * - fix me to call ACM services when available
1743  */
1744 char *
1745 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1746 {
1747 #   ifndef UAI$C_PREFERRED_ALGORITHM
1748 #     define UAI$C_PREFERRED_ALGORITHM 127
1749 #   endif
1750     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1751     unsigned short int salt = 0;
1752     unsigned long int sts;
1753     struct const_dsc {
1754         unsigned short int dsc$w_length;
1755         unsigned char      dsc$b_type;
1756         unsigned char      dsc$b_class;
1757         const char *       dsc$a_pointer;
1758     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1759        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1760     struct itmlst_3 uailst[3] = {
1761         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1762         { sizeof salt, UAI$_SALT,    &salt, 0},
1763         { 0,           0,            NULL,  NULL}};
1764     static char hash[9];
1765
1766     usrdsc.dsc$w_length = strlen(usrname);
1767     usrdsc.dsc$a_pointer = usrname;
1768     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1769       switch (sts) {
1770         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1771           set_errno(EACCES);
1772           break;
1773         case RMS$_RNF:
1774           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1775           break;
1776         default:
1777           set_errno(EVMSERR);
1778       }
1779       set_vaxc_errno(sts);
1780       if (sts != RMS$_RNF) return NULL;
1781     }
1782
1783     txtdsc.dsc$w_length = strlen(textpasswd);
1784     txtdsc.dsc$a_pointer = textpasswd;
1785     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1786       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1787     }
1788
1789     return (char *) hash;
1790
1791 }  /* end of my_crypt() */
1792 /*}}}*/
1793
1794
1795 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1796 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1797 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1798
1799 /* fixup barenames that are directories for internal use.
1800  * There have been problems with the consistent handling of UNIX
1801  * style directory names when routines are presented with a name that
1802  * has no directory delimitors at all.  So this routine will eventually
1803  * fix the issue.
1804  */
1805 static char * fixup_bare_dirnames(const char * name)
1806 {
1807   if (decc_disable_to_vms_logname_translation) {
1808 /* fix me */
1809   }
1810   return NULL;
1811 }
1812
1813 /* 8.3, remove() is now broken on symbolic links */
1814 static int rms_erase(const char * vmsname);
1815
1816
1817 /* mp_do_kill_file
1818  * A little hack to get around a bug in some implemenation of remove()
1819  * that do not know how to delete a directory
1820  *
1821  * Delete any file to which user has control access, regardless of whether
1822  * delete access is explicitly allowed.
1823  * Limitations: User must have write access to parent directory.
1824  *              Does not block signals or ASTs; if interrupted in midstream
1825  *              may leave file with an altered ACL.
1826  * HANDLE WITH CARE!
1827  */
1828 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1829 static int
1830 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1831 {
1832     char *vmsname;
1833     char *rslt;
1834     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1835     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1836     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1837     struct myacedef {
1838       unsigned char myace$b_length;
1839       unsigned char myace$b_type;
1840       unsigned short int myace$w_flags;
1841       unsigned long int myace$l_access;
1842       unsigned long int myace$l_ident;
1843     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1844                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1845       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1846      struct itmlst_3
1847        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1848                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1849        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1850        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1851        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1852        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1853
1854     /* Expand the input spec using RMS, since the CRTL remove() and
1855      * system services won't do this by themselves, so we may miss
1856      * a file "hiding" behind a logical name or search list. */
1857     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1858     if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1859
1860     rslt = do_rmsexpand(name,
1861                         vmsname,
1862                         0,
1863                         NULL,
1864                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
1865                         NULL,
1866                         NULL);
1867     if (rslt == NULL) {
1868         PerlMem_free(vmsname);
1869         return -1;
1870       }
1871
1872     /* Erase the file */
1873     rmsts = rms_erase(vmsname);
1874
1875     /* Did it succeed */
1876     if ($VMS_STATUS_SUCCESS(rmsts)) {
1877         PerlMem_free(vmsname);
1878         return 0;
1879       }
1880
1881     /* If not, can changing protections help? */
1882     if (rmsts != RMS$_PRV) {
1883       set_vaxc_errno(rmsts);
1884       PerlMem_free(vmsname);
1885       return -1;
1886     }
1887
1888     /* No, so we get our own UIC to use as a rights identifier,
1889      * and the insert an ACE at the head of the ACL which allows us
1890      * to delete the file.
1891      */
1892     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1893     fildsc.dsc$w_length = strlen(vmsname);
1894     fildsc.dsc$a_pointer = vmsname;
1895     cxt = 0;
1896     newace.myace$l_ident = oldace.myace$l_ident;
1897     rmsts = -1;
1898     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1899       switch (aclsts) {
1900         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1901           set_errno(ENOENT); break;
1902         case RMS$_DIR:
1903           set_errno(ENOTDIR); break;
1904         case RMS$_DEV:
1905           set_errno(ENODEV); break;
1906         case RMS$_SYN: case SS$_INVFILFOROP:
1907           set_errno(EINVAL); break;
1908         case RMS$_PRV:
1909           set_errno(EACCES); break;
1910         default:
1911           _ckvmssts(aclsts);
1912       }
1913       set_vaxc_errno(aclsts);
1914       PerlMem_free(vmsname);
1915       return -1;
1916     }
1917     /* Grab any existing ACEs with this identifier in case we fail */
1918     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1919     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1920                     || fndsts == SS$_NOMOREACE ) {
1921       /* Add the new ACE . . . */
1922       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1923         goto yourroom;
1924
1925       rmsts = rms_erase(vmsname);
1926       if ($VMS_STATUS_SUCCESS(rmsts)) {
1927         rmsts = 0;
1928         }
1929         else {
1930         rmsts = -1;
1931         /* We blew it - dir with files in it, no write priv for
1932          * parent directory, etc.  Put things back the way they were. */
1933         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1934           goto yourroom;
1935         if (fndsts & 1) {
1936           addlst[0].bufadr = &oldace;
1937           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1938             goto yourroom;
1939         }
1940       }
1941     }
1942
1943     yourroom:
1944     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1945     /* We just deleted it, so of course it's not there.  Some versions of
1946      * VMS seem to return success on the unlock operation anyhow (after all
1947      * the unlock is successful), but others don't.
1948      */
1949     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1950     if (aclsts & 1) aclsts = fndsts;
1951     if (!(aclsts & 1)) {
1952       set_errno(EVMSERR);
1953       set_vaxc_errno(aclsts);
1954     }
1955
1956     PerlMem_free(vmsname);
1957     return rmsts;
1958
1959 }  /* end of kill_file() */
1960 /*}}}*/
1961
1962
1963 /*{{{int do_rmdir(char *name)*/
1964 int
1965 Perl_do_rmdir(pTHX_ const char *name)
1966 {
1967     char * dirfile;
1968     int retval;
1969     Stat_t st;
1970
1971     dirfile = PerlMem_malloc(VMS_MAXRSS + 1);
1972     if (dirfile == NULL)
1973         _ckvmssts(SS$_INSFMEM);
1974
1975     /* Force to a directory specification */
1976     if (do_fileify_dirspec(name, dirfile, 0, NULL) == NULL) {
1977         PerlMem_free(dirfile);
1978         return -1;
1979     }
1980     if (Perl_flex_lstat(aTHX_ dirfile, &st) || !S_ISDIR(st.st_mode)) {
1981         errno = ENOTDIR;
1982         retval = -1;
1983     }
1984     else
1985         retval = mp_do_kill_file(aTHX_ dirfile, 1);
1986
1987     PerlMem_free(dirfile);
1988     return retval;
1989
1990 }  /* end of do_rmdir */
1991 /*}}}*/
1992
1993 /* kill_file
1994  * Delete any file to which user has control access, regardless of whether
1995  * delete access is explicitly allowed.
1996  * Limitations: User must have write access to parent directory.
1997  *              Does not block signals or ASTs; if interrupted in midstream
1998  *              may leave file with an altered ACL.
1999  * HANDLE WITH CARE!
2000  */
2001 /*{{{int kill_file(char *name)*/
2002 int
2003 Perl_kill_file(pTHX_ const char *name)
2004 {
2005     char rspec[NAM$C_MAXRSS+1];
2006     char *tspec;
2007     Stat_t st;
2008     int rmsts;
2009
2010    /* Remove() is allowed to delete directories, according to the X/Open
2011     * specifications.
2012     * This may need special handling to work with the ACL hacks.
2013      */
2014    if ((flex_lstat(name, &st) == 0) && S_ISDIR(st.st_mode)) {
2015         rmsts = Perl_do_rmdir(aTHX_ name);
2016         return rmsts;
2017     }
2018
2019    rmsts = mp_do_kill_file(aTHX_ name, 0);
2020
2021     return rmsts;
2022
2023 }  /* end of kill_file() */
2024 /*}}}*/
2025
2026
2027 /*{{{int my_mkdir(char *,Mode_t)*/
2028 int
2029 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2030 {
2031   STRLEN dirlen = strlen(dir);
2032
2033   /* zero length string sometimes gives ACCVIO */
2034   if (dirlen == 0) return -1;
2035
2036   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2037    * null file name/type.  However, it's commonplace under Unix,
2038    * so we'll allow it for a gain in portability.
2039    */
2040   if (dir[dirlen-1] == '/') {
2041     char *newdir = savepvn(dir,dirlen-1);
2042     int ret = mkdir(newdir,mode);
2043     Safefree(newdir);
2044     return ret;
2045   }
2046   else return mkdir(dir,mode);
2047 }  /* end of my_mkdir */
2048 /*}}}*/
2049
2050 /*{{{int my_chdir(char *)*/
2051 int
2052 Perl_my_chdir(pTHX_ const char *dir)
2053 {
2054   STRLEN dirlen = strlen(dir);
2055
2056   /* zero length string sometimes gives ACCVIO */
2057   if (dirlen == 0) return -1;
2058   const char *dir1;
2059
2060   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2061    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2062    * so that existing scripts do not need to be changed.
2063    */
2064   dir1 = dir;
2065   while ((dirlen > 0) && (*dir1 == ' ')) {
2066     dir1++;
2067     dirlen--;
2068   }
2069
2070   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2071    * that implies
2072    * null file name/type.  However, it's commonplace under Unix,
2073    * so we'll allow it for a gain in portability.
2074    *
2075    * - Preview- '/' will be valid soon on VMS
2076    */
2077   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2078     char *newdir = savepvn(dir1,dirlen-1);
2079     int ret = chdir(newdir);
2080     Safefree(newdir);
2081     return ret;
2082   }
2083   else return chdir(dir1);
2084 }  /* end of my_chdir */
2085 /*}}}*/
2086
2087
2088 /*{{{int my_chmod(char *, mode_t)*/
2089 int
2090 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2091 {
2092   STRLEN speclen = strlen(file_spec);
2093
2094   /* zero length string sometimes gives ACCVIO */
2095   if (speclen == 0) return -1;
2096
2097   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2098    * that implies null file name/type.  However, it's commonplace under Unix,
2099    * so we'll allow it for a gain in portability.
2100    *
2101    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2102    * in VMS file.dir notation.
2103    */
2104   if ((speclen > 1) && (file_spec[speclen-1] == '/')) {
2105     char *vms_src, *vms_dir, *rslt;
2106     int ret = -1;
2107     errno = EIO;
2108
2109     /* First convert this to a VMS format specification */
2110     vms_src = PerlMem_malloc(VMS_MAXRSS);
2111     if (vms_src == NULL)
2112         _ckvmssts(SS$_INSFMEM);
2113
2114     rslt = do_tovmsspec(file_spec, vms_src, 0, NULL);
2115     if (rslt == NULL) {
2116         /* If we fail, then not a file specification */
2117         PerlMem_free(vms_src);
2118         errno = EIO;
2119         return -1;
2120     }
2121
2122     /* Now make it a directory spec so chmod is happy */
2123     vms_dir = PerlMem_malloc(VMS_MAXRSS + 1);
2124     if (vms_dir == NULL)
2125         _ckvmssts(SS$_INSFMEM);
2126     rslt = do_fileify_dirspec(vms_src, vms_dir, 0, NULL);
2127     PerlMem_free(vms_src);
2128
2129     /* Now do it */
2130     if (rslt != NULL) {
2131         ret = chmod(vms_dir, mode);
2132     } else {
2133         errno = EIO;
2134     }
2135     PerlMem_free(vms_dir);
2136     return ret;
2137   }
2138   else return chmod(file_spec, mode);
2139 }  /* end of my_chmod */
2140 /*}}}*/
2141
2142
2143 /*{{{FILE *my_tmpfile()*/
2144 FILE *
2145 my_tmpfile(void)
2146 {
2147   FILE *fp;
2148   char *cp;
2149
2150   if ((fp = tmpfile())) return fp;
2151
2152   cp = PerlMem_malloc(L_tmpnam+24);
2153   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2154
2155   if (decc_filename_unix_only == 0)
2156     strcpy(cp,"Sys$Scratch:");
2157   else
2158     strcpy(cp,"/tmp/");
2159   tmpnam(cp+strlen(cp));
2160   strcat(cp,".Perltmp");
2161   fp = fopen(cp,"w+","fop=dlt");
2162   PerlMem_free(cp);
2163   return fp;
2164 }
2165 /*}}}*/
2166
2167
2168 #ifndef HOMEGROWN_POSIX_SIGNALS
2169 /*
2170  * The C RTL's sigaction fails to check for invalid signal numbers so we
2171  * help it out a bit.  The docs are correct, but the actual routine doesn't
2172  * do what the docs say it will.
2173  */
2174 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2175 int
2176 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2177                    struct sigaction* oact)
2178 {
2179   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2180         SETERRNO(EINVAL, SS$_INVARG);
2181         return -1;
2182   }
2183   return sigaction(sig, act, oact);
2184 }
2185 /*}}}*/
2186 #endif
2187
2188 #ifdef KILL_BY_SIGPRC
2189 #include <errnodef.h>
2190
2191 /* We implement our own kill() using the undocumented system service
2192    sys$sigprc for one of two reasons:
2193
2194    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2195    target process to do a sys$exit, which usually can't be handled
2196    gracefully...certainly not by Perl and the %SIG{} mechanism.
2197
2198    2.) If the kill() in the CRTL can't be called from a signal
2199    handler without disappearing into the ether, i.e., the signal
2200    it purportedly sends is never trapped. Still true as of VMS 7.3.
2201
2202    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2203    in the target process rather than calling sys$exit.
2204
2205    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2206    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2207    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2208    with condition codes C$_SIG0+nsig*8, catching the exception on the
2209    target process and resignaling with appropriate arguments.
2210
2211    But we don't have that VMS 7.0+ exception handler, so if you
2212    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2213
2214    Also note that SIGTERM is listed in the docs as being "unimplemented",
2215    yet always seems to be signaled with a VMS condition code of 4 (and
2216    correctly handled for that code).  So we hardwire it in.
2217
2218    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2219    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2220    than signalling with an unrecognized (and unhandled by CRTL) code.
2221 */
2222
2223 #define _MY_SIG_MAX 28
2224
2225 static unsigned int
2226 Perl_sig_to_vmscondition_int(int sig)
2227 {
2228     static unsigned int sig_code[_MY_SIG_MAX+1] =
2229     {
2230         0,                  /*  0 ZERO     */
2231         SS$_HANGUP,         /*  1 SIGHUP   */
2232         SS$_CONTROLC,       /*  2 SIGINT   */
2233         SS$_CONTROLY,       /*  3 SIGQUIT  */
2234         SS$_RADRMOD,        /*  4 SIGILL   */
2235         SS$_BREAK,          /*  5 SIGTRAP  */
2236         SS$_OPCCUS,         /*  6 SIGABRT  */
2237         SS$_COMPAT,         /*  7 SIGEMT   */
2238 #ifdef __VAX
2239         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2240 #else
2241         SS$_HPARITH,        /*  8 SIGFPE AXP */
2242 #endif
2243         SS$_ABORT,          /*  9 SIGKILL  */
2244         SS$_ACCVIO,         /* 10 SIGBUS   */
2245         SS$_ACCVIO,         /* 11 SIGSEGV  */
2246         SS$_BADPARAM,       /* 12 SIGSYS   */
2247         SS$_NOMBX,          /* 13 SIGPIPE  */
2248         SS$_ASTFLT,         /* 14 SIGALRM  */
2249         4,                  /* 15 SIGTERM  */
2250         0,                  /* 16 SIGUSR1  */
2251         0,                  /* 17 SIGUSR2  */
2252         0,                  /* 18 */
2253         0,                  /* 19 */
2254         0,                  /* 20 SIGCHLD  */
2255         0,                  /* 21 SIGCONT  */
2256         0,                  /* 22 SIGSTOP  */
2257         0,                  /* 23 SIGTSTP  */
2258         0,                  /* 24 SIGTTIN  */
2259         0,                  /* 25 SIGTTOU  */
2260         0,                  /* 26 */
2261         0,                  /* 27 */
2262         0                   /* 28 SIGWINCH  */
2263     };
2264
2265 #if __VMS_VER >= 60200000
2266     static int initted = 0;
2267     if (!initted) {
2268         initted = 1;
2269         sig_code[16] = C$_SIGUSR1;
2270         sig_code[17] = C$_SIGUSR2;
2271 #if __CRTL_VER >= 70000000
2272         sig_code[20] = C$_SIGCHLD;
2273 #endif
2274 #if __CRTL_VER >= 70300000
2275         sig_code[28] = C$_SIGWINCH;
2276 #endif
2277     }
2278 #endif
2279
2280     if (sig < _SIG_MIN) return 0;
2281     if (sig > _MY_SIG_MAX) return 0;
2282     return sig_code[sig];
2283 }
2284
2285 unsigned int
2286 Perl_sig_to_vmscondition(int sig)
2287 {
2288 #ifdef SS$_DEBUG
2289     if (vms_debug_on_exception != 0)
2290         lib$signal(SS$_DEBUG);
2291 #endif
2292     return Perl_sig_to_vmscondition_int(sig);
2293 }
2294
2295
2296 int
2297 Perl_my_kill(int pid, int sig)
2298 {
2299     dTHX;
2300     int iss;
2301     unsigned int code;
2302     int sys$sigprc(unsigned int *pidadr,
2303                      struct dsc$descriptor_s *prcname,
2304                      unsigned int code);
2305
2306      /* sig 0 means validate the PID */
2307     /*------------------------------*/
2308     if (sig == 0) {
2309         const unsigned long int jpicode = JPI$_PID;
2310         pid_t ret_pid;
2311         int status;
2312         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2313         if ($VMS_STATUS_SUCCESS(status))
2314            return 0;
2315         switch (status) {
2316         case SS$_NOSUCHNODE:
2317         case SS$_UNREACHABLE:
2318         case SS$_NONEXPR:
2319            errno = ESRCH;
2320            break;
2321         case SS$_NOPRIV:
2322            errno = EPERM;
2323            break;
2324         default:
2325            errno = EVMSERR;
2326         }
2327         vaxc$errno=status;
2328         return -1;
2329     }
2330
2331     code = Perl_sig_to_vmscondition_int(sig);
2332
2333     if (!code) {
2334         SETERRNO(EINVAL, SS$_BADPARAM);
2335         return -1;
2336     }
2337
2338     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2339      * signals are to be sent to multiple processes.
2340      *  pid = 0 - all processes in group except ones that the system exempts
2341      *  pid = -1 - all processes except ones that the system exempts
2342      *  pid = -n - all processes in group (abs(n)) except ...
2343      * For now, just report as not supported.
2344      */
2345
2346     if (pid <= 0) {
2347         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2348         return -1;
2349     }
2350
2351     iss = sys$sigprc((unsigned int *)&pid,0,code);
2352     if (iss&1) return 0;
2353
2354     switch (iss) {
2355       case SS$_NOPRIV:
2356         set_errno(EPERM);  break;
2357       case SS$_NONEXPR:
2358       case SS$_NOSUCHNODE:
2359       case SS$_UNREACHABLE:
2360         set_errno(ESRCH);  break;
2361       case SS$_INSFMEM:
2362         set_errno(ENOMEM); break;
2363       default:
2364         _ckvmssts(iss);
2365         set_errno(EVMSERR);
2366     }
2367     set_vaxc_errno(iss);
2368
2369     return -1;
2370 }
2371 #endif
2372
2373 /* Routine to convert a VMS status code to a UNIX status code.
2374 ** More tricky than it appears because of conflicting conventions with
2375 ** existing code.
2376 **
2377 ** VMS status codes are a bit mask, with the least significant bit set for
2378 ** success.
2379 **
2380 ** Special UNIX status of EVMSERR indicates that no translation is currently
2381 ** available, and programs should check the VMS status code.
2382 **
2383 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2384 ** decoding.
2385 */
2386
2387 #ifndef C_FACILITY_NO
2388 #define C_FACILITY_NO 0x350000
2389 #endif
2390 #ifndef DCL_IVVERB
2391 #define DCL_IVVERB 0x38090
2392 #endif
2393
2394 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2395 {
2396 int facility;
2397 int fac_sp;
2398 int msg_no;
2399 int msg_status;
2400 int unix_status;
2401
2402   /* Assume the best or the worst */
2403   if (vms_status & STS$M_SUCCESS)
2404     unix_status = 0;
2405   else
2406     unix_status = EVMSERR;
2407
2408   msg_status = vms_status & ~STS$M_CONTROL;
2409
2410   facility = vms_status & STS$M_FAC_NO;
2411   fac_sp = vms_status & STS$M_FAC_SP;
2412   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2413
2414   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2415     switch(msg_no) {
2416     case SS$_NORMAL:
2417         unix_status = 0;
2418         break;
2419     case SS$_ACCVIO:
2420         unix_status = EFAULT;
2421         break;
2422     case SS$_DEVOFFLINE:
2423         unix_status = EBUSY;
2424         break;
2425     case SS$_CLEARED:
2426         unix_status = ENOTCONN;
2427         break;
2428     case SS$_IVCHAN:
2429     case SS$_IVLOGNAM:
2430     case SS$_BADPARAM:
2431     case SS$_IVLOGTAB:
2432     case SS$_NOLOGNAM:
2433     case SS$_NOLOGTAB:
2434     case SS$_INVFILFOROP:
2435     case SS$_INVARG:
2436     case SS$_NOSUCHID:
2437     case SS$_IVIDENT:
2438         unix_status = EINVAL;
2439         break;
2440     case SS$_UNSUPPORTED:
2441         unix_status = ENOTSUP;
2442         break;
2443     case SS$_FILACCERR:
2444     case SS$_NOGRPPRV:
2445     case SS$_NOSYSPRV:
2446         unix_status = EACCES;
2447         break;
2448     case SS$_DEVICEFULL:
2449         unix_status = ENOSPC;
2450         break;
2451     case SS$_NOSUCHDEV:
2452         unix_status = ENODEV;
2453         break;
2454     case SS$_NOSUCHFILE:
2455     case SS$_NOSUCHOBJECT:
2456         unix_status = ENOENT;
2457         break;
2458     case SS$_ABORT:                                 /* Fatal case */
2459     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2460     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2461         unix_status = EINTR;
2462         break;
2463     case SS$_BUFFEROVF:
2464         unix_status = E2BIG;
2465         break;
2466     case SS$_INSFMEM:
2467         unix_status = ENOMEM;
2468         break;
2469     case SS$_NOPRIV:
2470         unix_status = EPERM;
2471         break;
2472     case SS$_NOSUCHNODE:
2473     case SS$_UNREACHABLE:
2474         unix_status = ESRCH;
2475         break;
2476     case SS$_NONEXPR:
2477         unix_status = ECHILD;
2478         break;
2479     default:
2480         if ((facility == 0) && (msg_no < 8)) {
2481           /* These are not real VMS status codes so assume that they are
2482           ** already UNIX status codes
2483           */
2484           unix_status = msg_no;
2485           break;
2486         }
2487     }
2488   }
2489   else {
2490     /* Translate a POSIX exit code to a UNIX exit code */
2491     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2492         unix_status = (msg_no & 0x07F8) >> 3;
2493     }
2494     else {
2495
2496          /* Documented traditional behavior for handling VMS child exits */
2497         /*--------------------------------------------------------------*/
2498         if (child_flag != 0) {
2499
2500              /* Success / Informational return 0 */
2501             /*----------------------------------*/
2502             if (msg_no & STS$K_SUCCESS)
2503                 return 0;
2504
2505              /* Warning returns 1 */
2506             /*-------------------*/
2507             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2508                 return 1;
2509
2510              /* Everything else pass through the severity bits */
2511             /*------------------------------------------------*/
2512             return (msg_no & STS$M_SEVERITY);
2513         }
2514
2515          /* Normal VMS status to ERRNO mapping attempt */
2516         /*--------------------------------------------*/
2517         switch(msg_status) {
2518         /* case RMS$_EOF: */ /* End of File */
2519         case RMS$_FNF:  /* File Not Found */
2520         case RMS$_DNF:  /* Dir Not Found */
2521                 unix_status = ENOENT;
2522                 break;
2523         case RMS$_RNF:  /* Record Not Found */
2524                 unix_status = ESRCH;
2525                 break;
2526         case RMS$_DIR:
2527                 unix_status = ENOTDIR;
2528                 break;
2529         case RMS$_DEV:
2530                 unix_status = ENODEV;
2531                 break;
2532         case RMS$_IFI:
2533         case RMS$_FAC:
2534         case RMS$_ISI:
2535                 unix_status = EBADF;
2536                 break;
2537         case RMS$_FEX:
2538                 unix_status = EEXIST;
2539                 break;
2540         case RMS$_SYN:
2541         case RMS$_FNM:
2542         case LIB$_INVSTRDES:
2543         case LIB$_INVARG:
2544         case LIB$_NOSUCHSYM:
2545         case LIB$_INVSYMNAM:
2546         case DCL_IVVERB:
2547                 unix_status = EINVAL;
2548                 break;
2549         case CLI$_BUFOVF:
2550         case RMS$_RTB:
2551         case CLI$_TKNOVF:
2552         case CLI$_RSLOVF:
2553                 unix_status = E2BIG;
2554                 break;
2555         case RMS$_PRV:  /* No privilege */
2556         case RMS$_ACC:  /* ACP file access failed */
2557         case RMS$_WLK:  /* Device write locked */
2558                 unix_status = EACCES;
2559                 break;
2560         /* case RMS$_NMF: */  /* No more files */
2561         }
2562     }
2563   }
2564
2565   return unix_status;
2566 }
2567
2568 /* Try to guess at what VMS error status should go with a UNIX errno
2569  * value.  This is hard to do as there could be many possible VMS
2570  * error statuses that caused the errno value to be set.
2571  */
2572
2573 int Perl_unix_status_to_vms(int unix_status)
2574 {
2575 int test_unix_status;
2576
2577      /* Trivial cases first */
2578     /*---------------------*/
2579     if (unix_status == EVMSERR)
2580         return vaxc$errno;
2581
2582      /* Is vaxc$errno sane? */
2583     /*---------------------*/
2584     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2585     if (test_unix_status == unix_status)
2586         return vaxc$errno;
2587
2588      /* If way out of range, must be VMS code already */
2589     /*-----------------------------------------------*/
2590     if (unix_status > EVMSERR)
2591         return unix_status;
2592
2593      /* If out of range, punt */
2594     /*-----------------------*/
2595     if (unix_status > __ERRNO_MAX)
2596         return SS$_ABORT;
2597
2598
2599      /* Ok, now we have to do it the hard way. */
2600     /*----------------------------------------*/
2601     switch(unix_status) {
2602     case 0:     return SS$_NORMAL;
2603     case EPERM: return SS$_NOPRIV;
2604     case ENOENT: return SS$_NOSUCHOBJECT;
2605     case ESRCH: return SS$_UNREACHABLE;
2606     case EINTR: return SS$_ABORT;
2607     /* case EIO: */
2608     /* case ENXIO:  */
2609     case E2BIG: return SS$_BUFFEROVF;
2610     /* case ENOEXEC */
2611     case EBADF: return RMS$_IFI;
2612     case ECHILD: return SS$_NONEXPR;
2613     /* case EAGAIN */
2614     case ENOMEM: return SS$_INSFMEM;
2615     case EACCES: return SS$_FILACCERR;
2616     case EFAULT: return SS$_ACCVIO;
2617     /* case ENOTBLK */
2618     case EBUSY: return SS$_DEVOFFLINE;
2619     case EEXIST: return RMS$_FEX;
2620     /* case EXDEV */
2621     case ENODEV: return SS$_NOSUCHDEV;
2622     case ENOTDIR: return RMS$_DIR;
2623     /* case EISDIR */
2624     case EINVAL: return SS$_INVARG;
2625     /* case ENFILE */
2626     /* case EMFILE */
2627     /* case ENOTTY */
2628     /* case ETXTBSY */
2629     /* case EFBIG */
2630     case ENOSPC: return SS$_DEVICEFULL;
2631     case ESPIPE: return LIB$_INVARG;
2632     /* case EROFS: */
2633     /* case EMLINK: */
2634     /* case EPIPE: */
2635     /* case EDOM */
2636     case ERANGE: return LIB$_INVARG;
2637     /* case EWOULDBLOCK */
2638     /* case EINPROGRESS */
2639     /* case EALREADY */
2640     /* case ENOTSOCK */
2641     /* case EDESTADDRREQ */
2642     /* case EMSGSIZE */
2643     /* case EPROTOTYPE */
2644     /* case ENOPROTOOPT */
2645     /* case EPROTONOSUPPORT */
2646     /* case ESOCKTNOSUPPORT */
2647     /* case EOPNOTSUPP */
2648     /* case EPFNOSUPPORT */
2649     /* case EAFNOSUPPORT */
2650     /* case EADDRINUSE */
2651     /* case EADDRNOTAVAIL */
2652     /* case ENETDOWN */
2653     /* case ENETUNREACH */
2654     /* case ENETRESET */
2655     /* case ECONNABORTED */
2656     /* case ECONNRESET */
2657     /* case ENOBUFS */
2658     /* case EISCONN */
2659     case ENOTCONN: return SS$_CLEARED;
2660     /* case ESHUTDOWN */
2661     /* case ETOOMANYREFS */
2662     /* case ETIMEDOUT */
2663     /* case ECONNREFUSED */
2664     /* case ELOOP */
2665     /* case ENAMETOOLONG */
2666     /* case EHOSTDOWN */
2667     /* case EHOSTUNREACH */
2668     /* case ENOTEMPTY */
2669     /* case EPROCLIM */
2670     /* case EUSERS  */
2671     /* case EDQUOT  */
2672     /* case ENOMSG  */
2673     /* case EIDRM */
2674     /* case EALIGN */
2675     /* case ESTALE */
2676     /* case EREMOTE */
2677     /* case ENOLCK */
2678     /* case ENOSYS */
2679     /* case EFTYPE */
2680     /* case ECANCELED */
2681     /* case EFAIL */
2682     /* case EINPROG */
2683     case ENOTSUP:
2684         return SS$_UNSUPPORTED;
2685     /* case EDEADLK */
2686     /* case ENWAIT */
2687     /* case EILSEQ */
2688     /* case EBADCAT */
2689     /* case EBADMSG */
2690     /* case EABANDONED */
2691     default:
2692         return SS$_ABORT; /* punt */
2693     }
2694
2695   return SS$_ABORT; /* Should not get here */
2696 }
2697
2698
2699 /* default piping mailbox size */
2700 #define PERL_BUFSIZ        512
2701
2702
2703 static void
2704 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2705 {
2706   unsigned long int mbxbufsiz;
2707   static unsigned long int syssize = 0;
2708   unsigned long int dviitm = DVI$_DEVNAM;
2709   char csize[LNM$C_NAMLENGTH+1];
2710   int sts;
2711
2712   if (!syssize) {
2713     unsigned long syiitm = SYI$_MAXBUF;
2714     /*
2715      * Get the SYSGEN parameter MAXBUF
2716      *
2717      * If the logical 'PERL_MBX_SIZE' is defined
2718      * use the value of the logical instead of PERL_BUFSIZ, but
2719      * keep the size between 128 and MAXBUF.
2720      *
2721      */
2722     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2723   }
2724
2725   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2726       mbxbufsiz = atoi(csize);
2727   } else {
2728       mbxbufsiz = PERL_BUFSIZ;
2729   }
2730   if (mbxbufsiz < 128) mbxbufsiz = 128;
2731   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2732
2733   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2734
2735   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2736   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2737
2738 }  /* end of create_mbx() */
2739
2740
2741 /*{{{  my_popen and my_pclose*/
2742
2743 typedef struct _iosb           IOSB;
2744 typedef struct _iosb*         pIOSB;
2745 typedef struct _pipe           Pipe;
2746 typedef struct _pipe*         pPipe;
2747 typedef struct pipe_details    Info;
2748 typedef struct pipe_details*  pInfo;
2749 typedef struct _srqp            RQE;
2750 typedef struct _srqp*          pRQE;
2751 typedef struct _tochildbuf      CBuf;
2752 typedef struct _tochildbuf*    pCBuf;
2753
2754 struct _iosb {
2755     unsigned short status;
2756     unsigned short count;
2757     unsigned long  dvispec;
2758 };
2759
2760 #pragma member_alignment save
2761 #pragma nomember_alignment quadword
2762 struct _srqp {          /* VMS self-relative queue entry */
2763     unsigned long qptr[2];
2764 };
2765 #pragma member_alignment restore
2766 static RQE  RQE_ZERO = {0,0};
2767
2768 struct _tochildbuf {
2769     RQE             q;
2770     int             eof;
2771     unsigned short  size;
2772     char            *buf;
2773 };
2774
2775 struct _pipe {
2776     RQE            free;
2777     RQE            wait;
2778     int            fd_out;
2779     unsigned short chan_in;
2780     unsigned short chan_out;
2781     char          *buf;
2782     unsigned int   bufsize;
2783     IOSB           iosb;
2784     IOSB           iosb2;
2785     int           *pipe_done;
2786     int            retry;
2787     int            type;
2788     int            shut_on_empty;
2789     int            need_wake;
2790     pPipe         *home;
2791     pInfo          info;
2792     pCBuf          curr;
2793     pCBuf          curr2;
2794 #if defined(PERL_IMPLICIT_CONTEXT)
2795     void            *thx;           /* Either a thread or an interpreter */
2796                                     /* pointer, depending on how we're built */
2797 #endif
2798 };
2799
2800
2801 struct pipe_details
2802 {
2803     pInfo           next;
2804     PerlIO *fp;  /* file pointer to pipe mailbox */
2805     int useFILE; /* using stdio, not perlio */
2806     int pid;   /* PID of subprocess */
2807     int mode;  /* == 'r' if pipe open for reading */
2808     int done;  /* subprocess has completed */
2809     int waiting; /* waiting for completion/closure */
2810     int             closing;        /* my_pclose is closing this pipe */
2811     unsigned long   completion;     /* termination status of subprocess */
2812     pPipe           in;             /* pipe in to sub */
2813     pPipe           out;            /* pipe out of sub */
2814     pPipe           err;            /* pipe of sub's sys$error */
2815     int             in_done;        /* true when in pipe finished */
2816     int             out_done;
2817     int             err_done;
2818     unsigned short  xchan;          /* channel to debug xterm */
2819     unsigned short  xchan_valid;    /* channel is assigned */
2820 };
2821
2822 struct exit_control_block
2823 {
2824     struct exit_control_block *flink;
2825     unsigned long int   (*exit_routine)();
2826     unsigned long int arg_count;
2827     unsigned long int *status_address;
2828     unsigned long int exit_status;
2829 };
2830
2831 typedef struct _closed_pipes    Xpipe;
2832 typedef struct _closed_pipes*  pXpipe;
2833
2834 struct _closed_pipes {
2835     int             pid;            /* PID of subprocess */
2836     unsigned long   completion;     /* termination status of subprocess */
2837 };
2838 #define NKEEPCLOSED 50
2839 static Xpipe closed_list[NKEEPCLOSED];
2840 static int   closed_index = 0;
2841 static int   closed_num = 0;
2842
2843 #define RETRY_DELAY     "0 ::0.20"
2844 #define MAX_RETRY              50
2845
2846 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2847 static unsigned long mypid;
2848 static unsigned long delaytime[2];
2849
2850 static pInfo open_pipes = NULL;
2851 static $DESCRIPTOR(nl_desc, "NL:");
2852
2853 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2854
2855
2856
2857 static unsigned long int
2858 pipe_exit_routine(pTHX)
2859 {
2860     pInfo info;
2861     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2862     int sts, did_stuff, need_eof, j;
2863
2864    /*
2865     * Flush any pending i/o, but since we are in process run-down, be
2866     * careful about referencing PerlIO structures that may already have
2867     * been deallocated.  We may not even have an interpreter anymore.
2868     */
2869     info = open_pipes;
2870     while (info) {
2871         if (info->fp) {
2872            if (!info->useFILE
2873 #if defined(USE_ITHREADS)
2874              && my_perl
2875 #endif
2876              && PL_perlio_fd_refcnt)
2877                PerlIO_flush(info->fp);
2878            else
2879                fflush((FILE *)info->fp);
2880         }
2881         info = info->next;
2882     }
2883
2884     /*
2885      next we try sending an EOF...ignore if doesn't work, make sure we
2886      don't hang
2887     */
2888     did_stuff = 0;
2889     info = open_pipes;
2890
2891     while (info) {
2892       int need_eof;
2893       _ckvmssts_noperl(sys$setast(0));
2894       if (info->in && !info->in->shut_on_empty) {
2895         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2896                           0, 0, 0, 0, 0, 0));
2897         info->waiting = 1;
2898         did_stuff = 1;
2899       }
2900       _ckvmssts_noperl(sys$setast(1));
2901       info = info->next;
2902     }
2903
2904     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2905
2906     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2907         int nwait = 0;
2908
2909         info = open_pipes;
2910         while (info) {
2911           _ckvmssts_noperl(sys$setast(0));
2912           if (info->waiting && info->done)
2913                 info->waiting = 0;
2914           nwait += info->waiting;
2915           _ckvmssts_noperl(sys$setast(1));
2916           info = info->next;
2917         }
2918         if (!nwait) break;
2919         sleep(1);
2920     }
2921
2922     did_stuff = 0;
2923     info = open_pipes;
2924     while (info) {
2925       _ckvmssts_noperl(sys$setast(0));
2926       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2927         sts = sys$forcex(&info->pid,0,&abort);
2928         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2929         did_stuff = 1;
2930       }
2931       _ckvmssts_noperl(sys$setast(1));
2932       info = info->next;
2933     }
2934
2935     /* again, wait for effect */
2936
2937     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2938         int nwait = 0;
2939
2940         info = open_pipes;
2941         while (info) {
2942           _ckvmssts_noperl(sys$setast(0));
2943           if (info->waiting && info->done)
2944                 info->waiting = 0;
2945           nwait += info->waiting;
2946           _ckvmssts_noperl(sys$setast(1));
2947           info = info->next;
2948         }
2949         if (!nwait) break;
2950         sleep(1);
2951     }
2952
2953     info = open_pipes;
2954     while (info) {
2955       _ckvmssts_noperl(sys$setast(0));
2956       if (!info->done) {  /* We tried to be nice . . . */
2957         sts = sys$delprc(&info->pid,0);
2958         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2959         info->done = 1;  /* sys$delprc is as done as we're going to get. */
2960       }
2961       _ckvmssts_noperl(sys$setast(1));
2962       info = info->next;
2963     }
2964
2965     while(open_pipes) {
2966       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2967       else if (!(sts & 1)) retsts = sts;
2968     }
2969     return retsts;
2970 }
2971
2972 static struct exit_control_block pipe_exitblock =
2973        {(struct exit_control_block *) 0,
2974         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2975
2976 static void pipe_mbxtofd_ast(pPipe p);
2977 static void pipe_tochild1_ast(pPipe p);
2978 static void pipe_tochild2_ast(pPipe p);
2979
2980 static void
2981 popen_completion_ast(pInfo info)
2982 {
2983   pInfo i = open_pipes;
2984   int iss;
2985   int sts;
2986   pXpipe x;
2987
2988   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2989   closed_list[closed_index].pid = info->pid;
2990   closed_list[closed_index].completion = info->completion;
2991   closed_index++;
2992   if (closed_index == NKEEPCLOSED)
2993     closed_index = 0;
2994   closed_num++;
2995
2996   while (i) {
2997     if (i == info) break;
2998     i = i->next;
2999   }
3000   if (!i) return;       /* unlinked, probably freed too */
3001
3002   info->done = TRUE;
3003
3004 /*
3005     Writing to subprocess ...
3006             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3007
3008             chan_out may be waiting for "done" flag, or hung waiting
3009             for i/o completion to child...cancel the i/o.  This will
3010             put it into "snarf mode" (done but no EOF yet) that discards
3011             input.
3012
3013     Output from subprocess (stdout, stderr) needs to be flushed and
3014     shut down.   We try sending an EOF, but if the mbx is full the pipe
3015     routine should still catch the "shut_on_empty" flag, telling it to
3016     use immediate-style reads so that "mbx empty" -> EOF.
3017
3018
3019 */
3020   if (info->in && !info->in_done) {               /* only for mode=w */
3021         if (info->in->shut_on_empty && info->in->need_wake) {
3022             info->in->need_wake = FALSE;
3023             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3024         } else {
3025             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3026         }
3027   }
3028
3029   if (info->out && !info->out_done) {             /* were we also piping output? */
3030       info->out->shut_on_empty = TRUE;
3031       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3032       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3033       _ckvmssts_noperl(iss);
3034   }
3035
3036   if (info->err && !info->err_done) {        /* we were piping stderr */
3037         info->err->shut_on_empty = TRUE;
3038         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3039         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3040         _ckvmssts_noperl(iss);
3041   }
3042   _ckvmssts_noperl(sys$setef(pipe_ef));
3043
3044 }
3045
3046 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3047 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3048
3049 /*
3050     we actually differ from vmstrnenv since we use this to
3051     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3052     are pointing to the same thing
3053 */
3054
3055 static unsigned short
3056 popen_translate(pTHX_ char *logical, char *result)
3057 {
3058     int iss;
3059     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3060     $DESCRIPTOR(d_log,"");
3061     struct _il3 {
3062         unsigned short length;
3063         unsigned short code;
3064         char *         buffer_addr;
3065         unsigned short *retlenaddr;
3066     } itmlst[2];
3067     unsigned short l, ifi;
3068
3069     d_log.dsc$a_pointer = logical;
3070     d_log.dsc$w_length  = strlen(logical);
3071
3072     itmlst[0].code = LNM$_STRING;
3073     itmlst[0].length = 255;
3074     itmlst[0].buffer_addr = result;
3075     itmlst[0].retlenaddr = &l;
3076
3077     itmlst[1].code = 0;
3078     itmlst[1].length = 0;
3079     itmlst[1].buffer_addr = 0;
3080     itmlst[1].retlenaddr = 0;
3081
3082     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3083     if (iss == SS$_NOLOGNAM) {
3084         iss = SS$_NORMAL;
3085         l = 0;
3086     }
3087     if (!(iss&1)) lib$signal(iss);
3088     result[l] = '\0';
3089 /*
3090     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
3091     strip it off and return the ifi, if any
3092 */
3093     ifi  = 0;
3094     if (result[0] == 0x1b && result[1] == 0x00) {
3095         memmove(&ifi,result+2,2);
3096         strcpy(result,result+4);
3097     }
3098     return ifi;     /* this is the RMS internal file id */
3099 }
3100
3101 static void pipe_infromchild_ast(pPipe p);
3102
3103 /*
3104     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3105     inside an AST routine without worrying about reentrancy and which Perl
3106     memory allocator is being used.
3107
3108     We read data and queue up the buffers, then spit them out one at a
3109     time to the output mailbox when the output mailbox is ready for one.
3110
3111 */
3112 #define INITIAL_TOCHILDQUEUE  2
3113
3114 static pPipe
3115 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3116 {
3117     pPipe p;
3118     pCBuf b;
3119     char mbx1[64], mbx2[64];
3120     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3121                                       DSC$K_CLASS_S, mbx1},
3122                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3123                                       DSC$K_CLASS_S, mbx2};
3124     unsigned int dviitm = DVI$_DEVBUFSIZ;
3125     int j, n;
3126
3127     n = sizeof(Pipe);
3128     _ckvmssts(lib$get_vm(&n, &p));
3129
3130     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3131     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3132     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3133
3134     p->buf           = 0;
3135     p->shut_on_empty = FALSE;
3136     p->need_wake     = FALSE;
3137     p->type          = 0;
3138     p->retry         = 0;
3139     p->iosb.status   = SS$_NORMAL;
3140     p->iosb2.status  = SS$_NORMAL;
3141     p->free          = RQE_ZERO;
3142     p->wait          = RQE_ZERO;
3143     p->curr          = 0;
3144     p->curr2         = 0;
3145     p->info          = 0;
3146 #ifdef PERL_IMPLICIT_CONTEXT
3147     p->thx           = aTHX;
3148 #endif
3149
3150     n = sizeof(CBuf) + p->bufsize;
3151
3152     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3153         _ckvmssts(lib$get_vm(&n, &b));
3154         b->buf = (char *) b + sizeof(CBuf);
3155         _ckvmssts(lib$insqhi(b, &p->free));
3156     }
3157
3158     pipe_tochild2_ast(p);
3159     pipe_tochild1_ast(p);
3160     strcpy(wmbx, mbx1);
3161     strcpy(rmbx, mbx2);
3162     return p;
3163 }
3164
3165 /*  reads the MBX Perl is writing, and queues */
3166
3167 static void
3168 pipe_tochild1_ast(pPipe p)
3169 {
3170     pCBuf b = p->curr;
3171     int iss = p->iosb.status;
3172     int eof = (iss == SS$_ENDOFFILE);
3173     int sts;
3174 #ifdef PERL_IMPLICIT_CONTEXT
3175     pTHX = p->thx;
3176 #endif
3177
3178     if (p->retry) {
3179         if (eof) {
3180             p->shut_on_empty = TRUE;
3181             b->eof     = TRUE;
3182             _ckvmssts(sys$dassgn(p->chan_in));
3183         } else  {
3184             _ckvmssts(iss);
3185         }
3186
3187         b->eof  = eof;
3188         b->size = p->iosb.count;
3189         _ckvmssts(sts = lib$insqhi(b, &p->wait));
3190         if (p->need_wake) {
3191             p->need_wake = FALSE;
3192             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3193         }
3194     } else {
3195         p->retry = 1;   /* initial call */
3196     }
3197
3198     if (eof) {                  /* flush the free queue, return when done */
3199         int n = sizeof(CBuf) + p->bufsize;
3200         while (1) {
3201             iss = lib$remqti(&p->free, &b);
3202             if (iss == LIB$_QUEWASEMP) return;
3203             _ckvmssts(iss);
3204             _ckvmssts(lib$free_vm(&n, &b));
3205         }
3206     }
3207
3208     iss = lib$remqti(&p->free, &b);
3209     if (iss == LIB$_QUEWASEMP) {
3210         int n = sizeof(CBuf) + p->bufsize;
3211         _ckvmssts(lib$get_vm(&n, &b));
3212         b->buf = (char *) b + sizeof(CBuf);
3213     } else {
3214        _ckvmssts(iss);
3215     }
3216
3217     p->curr = b;
3218     iss = sys$qio(0,p->chan_in,
3219              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3220              &p->iosb,
3221              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3222     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3223     _ckvmssts(iss);
3224 }
3225
3226
3227 /* writes queued buffers to output, waits for each to complete before
3228    doing the next */
3229
3230 static void
3231 pipe_tochild2_ast(pPipe p)
3232 {
3233     pCBuf b = p->curr2;
3234     int iss = p->iosb2.status;
3235     int n = sizeof(CBuf) + p->bufsize;
3236     int done = (p->info && p->info->done) ||
3237               iss == SS$_CANCEL || iss == SS$_ABORT;
3238 #if defined(PERL_IMPLICIT_CONTEXT)
3239     pTHX = p->thx;
3240 #endif
3241
3242     do {
3243         if (p->type) {         /* type=1 has old buffer, dispose */
3244             if (p->shut_on_empty) {
3245                 _ckvmssts(lib$free_vm(&n, &b));
3246             } else {
3247                 _ckvmssts(lib$insqhi(b, &p->free));
3248             }
3249             p->type = 0;
3250         }
3251
3252         iss = lib$remqti(&p->wait, &b);
3253         if (iss == LIB$_QUEWASEMP) {
3254             if (p->shut_on_empty) {
3255                 if (done) {
3256                     _ckvmssts(sys$dassgn(p->chan_out));
3257                     *p->pipe_done = TRUE;
3258                     _ckvmssts(sys$setef(pipe_ef));
3259                 } else {
3260                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3261                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3262                 }
3263                 return;
3264             }
3265             p->need_wake = TRUE;
3266             return;
3267         }
3268         _ckvmssts(iss);
3269         p->type = 1;
3270     } while (done);
3271
3272
3273     p->curr2 = b;
3274     if (b->eof) {
3275         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3276             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3277     } else {
3278         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3279             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3280     }
3281
3282     return;
3283
3284 }
3285
3286
3287 static pPipe
3288 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3289 {
3290     pPipe p;
3291     char mbx1[64], mbx2[64];
3292     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3293                                       DSC$K_CLASS_S, mbx1},
3294                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3295                                       DSC$K_CLASS_S, mbx2};
3296     unsigned int dviitm = DVI$_DEVBUFSIZ;
3297
3298     int n = sizeof(Pipe);
3299     _ckvmssts(lib$get_vm(&n, &p));
3300     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3301     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3302
3303     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3304     n = p->bufsize * sizeof(char);
3305     _ckvmssts(lib$get_vm(&n, &p->buf));
3306     p->shut_on_empty = FALSE;
3307     p->info   = 0;
3308     p->type   = 0;
3309     p->iosb.status = SS$_NORMAL;
3310 #if defined(PERL_IMPLICIT_CONTEXT)
3311     p->thx = aTHX;
3312 #endif
3313     pipe_infromchild_ast(p);
3314
3315     strcpy(wmbx, mbx1);
3316     strcpy(rmbx, mbx2);
3317     return p;
3318 }
3319
3320 static void
3321 pipe_infromchild_ast(pPipe p)
3322 {
3323     int iss = p->iosb.status;
3324     int eof = (iss == SS$_ENDOFFILE);
3325     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3326     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3327 #if defined(PERL_IMPLICIT_CONTEXT)
3328     pTHX = p->thx;
3329 #endif
3330
3331     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3332         _ckvmssts(sys$dassgn(p->chan_out));
3333         p->chan_out = 0;
3334     }
3335
3336     /* read completed:
3337             input shutdown if EOF from self (done or shut_on_empty)
3338             output shutdown if closing flag set (my_pclose)
3339             send data/eof from child or eof from self
3340             otherwise, re-read (snarf of data from child)
3341     */
3342
3343     if (p->type == 1) {
3344         p->type = 0;
3345         if (myeof && p->chan_in) {                  /* input shutdown */
3346             _ckvmssts(sys$dassgn(p->chan_in));
3347             p->chan_in = 0;
3348         }
3349
3350         if (p->chan_out) {
3351             if (myeof || kideof) {      /* pass EOF to parent */
3352                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3353                               pipe_infromchild_ast, p,
3354                               0, 0, 0, 0, 0, 0));
3355                 return;
3356             } else if (eof) {       /* eat EOF --- fall through to read*/
3357
3358             } else {                /* transmit data */
3359                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3360                               pipe_infromchild_ast,p,
3361                               p->buf, p->iosb.count, 0, 0, 0, 0));
3362                 return;
3363             }
3364         }
3365     }
3366
3367     /*  everything shut? flag as done */
3368
3369     if (!p->chan_in && !p->chan_out) {
3370         *p->pipe_done = TRUE;
3371         _ckvmssts(sys$setef(pipe_ef));
3372         return;
3373     }
3374
3375     /* write completed (or read, if snarfing from child)
3376             if still have input active,
3377                queue read...immediate mode if shut_on_empty so we get EOF if empty
3378             otherwise,
3379                check if Perl reading, generate EOFs as needed
3380     */
3381
3382     if (p->type == 0) {
3383         p->type = 1;
3384         if (p->chan_in) {
3385             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3386                           pipe_infromchild_ast,p,
3387                           p->buf, p->bufsize, 0, 0, 0, 0);
3388             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3389             _ckvmssts(iss);
3390         } else {           /* send EOFs for extra reads */
3391             p->iosb.status = SS$_ENDOFFILE;
3392             p->iosb.dvispec = 0;
3393             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3394                       0, 0, 0,
3395                       pipe_infromchild_ast, p, 0, 0, 0, 0));
3396         }
3397     }
3398 }
3399
3400 static pPipe
3401 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3402 {
3403     pPipe p;
3404     char mbx[64];
3405     unsigned long dviitm = DVI$_DEVBUFSIZ;
3406     struct stat s;
3407     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3408                                       DSC$K_CLASS_S, mbx};
3409     int n = sizeof(Pipe);
3410
3411     /* things like terminals and mbx's don't need this filter */
3412     if (fd && fstat(fd,&s) == 0) {
3413         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3414         char device[65];
3415         unsigned short dev_len;
3416         struct dsc$descriptor_s d_dev;
3417         char * cptr;
3418         struct item_list_3 items[3];
3419         int status;
3420         unsigned short dvi_iosb[4];
3421
3422         cptr = getname(fd, out, 1);
3423         if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3424         d_dev.dsc$a_pointer = out;
3425         d_dev.dsc$w_length = strlen(out);
3426         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3427         d_dev.dsc$b_class = DSC$K_CLASS_S;
3428
3429         items[0].len = 4;
3430         items[0].code = DVI$_DEVCHAR;
3431         items[0].bufadr = &devchar;
3432         items[0].retadr = NULL;
3433         items[1].len = 64;
3434         items[1].code = DVI$_FULLDEVNAM;
3435         items[1].bufadr = device;
3436         items[1].retadr = &dev_len;
3437         items[2].len = 0;
3438         items[2].code = 0;
3439
3440         status = sys$getdviw
3441                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3442         _ckvmssts(status);
3443         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3444             device[dev_len] = 0;
3445
3446             if (!(devchar & DEV$M_DIR)) {
3447                 strcpy(out, device);
3448                 return 0;
3449             }
3450         }
3451     }
3452
3453     _ckvmssts(lib$get_vm(&n, &p));
3454     p->fd_out = dup(fd);
3455     create_mbx(aTHX_ &p->chan_in, &d_mbx);
3456     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3457     n = (p->bufsize+1) * sizeof(char);
3458     _ckvmssts(lib$get_vm(&n, &p->buf));
3459     p->shut_on_empty = FALSE;
3460     p->retry = 0;
3461     p->info  = 0;
3462     strcpy(out, mbx);
3463
3464     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3465                   pipe_mbxtofd_ast, p,
3466                   p->buf, p->bufsize, 0, 0, 0, 0));
3467
3468     return p;
3469 }
3470
3471 static void
3472 pipe_mbxtofd_ast(pPipe p)
3473 {
3474     int iss = p->iosb.status;
3475     int done = p->info->done;
3476     int iss2;
3477     int eof = (iss == SS$_ENDOFFILE);
3478     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3479     int err = !(iss&1) && !eof;
3480 #if defined(PERL_IMPLICIT_CONTEXT)
3481     pTHX = p->thx;
3482 #endif
3483
3484     if (done && myeof) {               /* end piping */
3485         close(p->fd_out);
3486         sys$dassgn(p->chan_in);
3487         *p->pipe_done = TRUE;
3488         _ckvmssts(sys$setef(pipe_ef));
3489         return;
3490     }
3491
3492     if (!err && !eof) {             /* good data to send to file */
3493         p->buf[p->iosb.count] = '\n';
3494         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3495         if (iss2 < 0) {
3496             p->retry++;
3497             if (p->retry < MAX_RETRY) {
3498                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3499                 return;
3500             }
3501         }
3502         p->retry = 0;
3503     } else if (err) {
3504         _ckvmssts(iss);
3505     }
3506
3507
3508     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3509           pipe_mbxtofd_ast, p,
3510           p->buf, p->bufsize, 0, 0, 0, 0);
3511     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3512     _ckvmssts(iss);
3513 }
3514
3515
3516 typedef struct _pipeloc     PLOC;
3517 typedef struct _pipeloc*   pPLOC;
3518
3519 struct _pipeloc {
3520     pPLOC   next;
3521     char    dir[NAM$C_MAXRSS+1];
3522 };
3523 static pPLOC  head_PLOC = 0;
3524
3525 void
3526 free_pipelocs(pTHX_ void *head)
3527 {
3528     pPLOC p, pnext;
3529     pPLOC *pHead = (pPLOC *)head;
3530
3531     p = *pHead;
3532     while (p) {
3533         pnext = p->next;
3534         PerlMem_free(p);
3535         p = pnext;
3536     }
3537     *pHead = 0;
3538 }
3539
3540 static void
3541 store_pipelocs(pTHX)
3542 {
3543     int    i;
3544     pPLOC  p;
3545     AV    *av = 0;
3546     SV    *dirsv;
3547     GV    *gv;
3548     char  *dir, *x;
3549     char  *unixdir;
3550     char  temp[NAM$C_MAXRSS+1];
3551     STRLEN n_a;
3552
3553     if (head_PLOC)
3554         free_pipelocs(aTHX_ &head_PLOC);
3555
3556 /*  the . directory from @INC comes last */
3557
3558     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3559     if (p == NULL) _ckvmssts(SS$_INSFMEM);
3560     p->next = head_PLOC;
3561     head_PLOC = p;
3562     strcpy(p->dir,"./");
3563
3564 /*  get the directory from $^X */
3565
3566     unixdir = PerlMem_malloc(VMS_MAXRSS);
3567     if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3568
3569 #ifdef PERL_IMPLICIT_CONTEXT
3570     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3571 #else
3572     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3573 #endif
3574         strcpy(temp, PL_origargv[0]);
3575         x = strrchr(temp,']');
3576         if (x == NULL) {
3577         x = strrchr(temp,'>');
3578           if (x == NULL) {
3579             /* It could be a UNIX path */
3580             x = strrchr(temp,'/');
3581           }
3582         }
3583         if (x)
3584           x[1] = '\0';
3585         else {
3586           /* Got a bare name, so use default directory */
3587           temp[0] = '.';
3588           temp[1] = '\0';
3589         }
3590
3591         if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
3592             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3593             if (p == NULL) _ckvmssts(SS$_INSFMEM);
3594             p->next = head_PLOC;
3595             head_PLOC = p;
3596             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3597             p->dir[NAM$C_MAXRSS] = '\0';
3598         }
3599     }
3600
3601 /*  reverse order of @INC entries, skip "." since entered above */
3602
3603 #ifdef PERL_IMPLICIT_CONTEXT
3604     if (aTHX)
3605 #endif
3606     if (PL_incgv) av = GvAVn(PL_incgv);
3607
3608     for (i = 0; av && i <= AvFILL(av); i++) {
3609         dirsv = *av_fetch(av,i,TRUE);
3610
3611         if (SvROK(dirsv)) continue;
3612         dir = SvPVx(dirsv,n_a);
3613         if (strcmp(dir,".") == 0) continue;
3614         if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
3615             continue;
3616
3617         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3618         p->next = head_PLOC;
3619         head_PLOC = p;
3620         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3621         p->dir[NAM$C_MAXRSS] = '\0';
3622     }
3623
3624 /* most likely spot (ARCHLIB) put first in the list */
3625
3626 #ifdef ARCHLIB_EXP
3627     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
3628         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3629         if (p == NULL) _ckvmssts(SS$_INSFMEM);
3630         p->next = head_PLOC;
3631         head_PLOC = p;
3632         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3633         p->dir[NAM$C_MAXRSS] = '\0';
3634     }
3635 #endif
3636     PerlMem_free(unixdir);
3637 }
3638
3639 static I32
3640 Perl_cando_by_name_int
3641    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3642 #if !defined(PERL_IMPLICIT_CONTEXT)
3643 #define cando_by_name_int               Perl_cando_by_name_int
3644 #else
3645 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3646 #endif
3647
3648 static char *
3649 find_vmspipe(pTHX)
3650 {
3651     static int   vmspipe_file_status = 0;
3652     static char  vmspipe_file[NAM$C_MAXRSS+1];
3653
3654     /* already found? Check and use ... need read+execute permission */
3655
3656     if (vmspipe_file_status == 1) {
3657         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3658          && cando_by_name_int
3659            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3660             return vmspipe_file;
3661         }
3662         vmspipe_file_status = 0;
3663     }
3664
3665     /* scan through stored @INC, $^X */
3666
3667     if (vmspipe_file_status == 0) {
3668         char file[NAM$C_MAXRSS+1];
3669         pPLOC  p = head_PLOC;
3670
3671         while (p) {
3672             char * exp_res;
3673             int dirlen;
3674             strcpy(file, p->dir);
3675             dirlen = strlen(file);
3676             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3677             file[NAM$C_MAXRSS] = '\0';
3678             p = p->next;
3679
3680             exp_res = do_rmsexpand
3681                 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3682             if (!exp_res) continue;
3683
3684             if (cando_by_name_int
3685                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3686              && cando_by_name_int
3687                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3688                 vmspipe_file_status = 1;
3689                 return vmspipe_file;
3690             }
3691         }
3692         vmspipe_file_status = -1;   /* failed, use tempfiles */
3693     }
3694
3695     return 0;
3696 }
3697
3698 static FILE *
3699 vmspipe_tempfile(pTHX)
3700 {
3701     char file[NAM$C_MAXRSS+1];
3702     FILE *fp;
3703     static int index = 0;
3704     Stat_t s0, s1;
3705     int cmp_result;
3706
3707     /* create a tempfile */
3708
3709     /* we can't go from   W, shr=get to  R, shr=get without
3710        an intermediate vulnerable state, so don't bother trying...
3711
3712        and lib$spawn doesn't shr=put, so have to close the write
3713
3714        So... match up the creation date/time and the FID to
3715        make sure we're dealing with the same file
3716
3717     */
3718
3719     index++;
3720     if (!decc_filename_unix_only) {
3721       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3722       fp = fopen(file,"w");
3723       if (!fp) {
3724         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3725         fp = fopen(file,"w");
3726         if (!fp) {
3727             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3728             fp = fopen(file,"w");
3729         }
3730       }
3731      }
3732      else {
3733       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3734       fp = fopen(file,"w");
3735       if (!fp) {
3736         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3737         fp = fopen(file,"w");
3738         if (!fp) {
3739           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3740           fp = fopen(file,"w");
3741         }
3742       }
3743     }
3744     if (!fp) return 0;  /* we're hosed */
3745
3746     fprintf(fp,"$! 'f$verify(0)'\n");
3747     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3748     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3749     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3750     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3751     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3752     fprintf(fp,"$ perl_del    = \"delete\"\n");
3753     fprintf(fp,"$ pif         = \"if\"\n");
3754     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3755     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3756     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3757     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3758     fprintf(fp,"$!  --- build command line to get max possible length\n");
3759     fprintf(fp,"$c=perl_popen_cmd0\n");
3760     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3761     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3762     fprintf(fp,"$x=perl_popen_cmd3\n");
3763     fprintf(fp,"$c=c+x\n");
3764     fprintf(fp,"$ perl_on\n");
3765     fprintf(fp,"$ 'c'\n");
3766     fprintf(fp,"$ perl_status = $STATUS\n");
3767     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3768     fprintf(fp,"$ perl_exit 'perl_status'\n");
3769     fsync(fileno(fp));
3770
3771     fgetname(fp, file, 1);
3772     fstat(fileno(fp), (struct stat *)&s0);
3773     fclose(fp);
3774
3775     if (decc_filename_unix_only)
3776         do_tounixspec(file, file, 0, NULL);
3777     fp = fopen(file,"r","shr=get");
3778     if (!fp) return 0;
3779     fstat(fileno(fp), (struct stat *)&s1);
3780
3781     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3782     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3783         fclose(fp);
3784         return 0;
3785     }
3786
3787     return fp;
3788 }
3789
3790
3791 static int vms_is_syscommand_xterm(void)
3792 {
3793     const static struct dsc$descriptor_s syscommand_dsc =
3794       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3795
3796     const static struct dsc$descriptor_s decwdisplay_dsc =
3797       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3798
3799     struct item_list_3 items[2];
3800     unsigned short dvi_iosb[4];
3801     unsigned long devchar;
3802     unsigned long devclass;
3803     int status;
3804
3805     /* Very simple check to guess if sys$command is a decterm? */
3806     /* First see if the DECW$DISPLAY: device exists */
3807     items[0].len = 4;
3808     items[0].code = DVI$_DEVCHAR;
3809     items[0].bufadr = &devchar;
3810     items[0].retadr = NULL;
3811     items[1].len = 0;
3812     items[1].code = 0;
3813
3814     status = sys$getdviw
3815         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3816
3817     if ($VMS_STATUS_SUCCESS(status)) {
3818         status = dvi_iosb[0];
3819     }
3820
3821     if (!$VMS_STATUS_SUCCESS(status)) {
3822         SETERRNO(EVMSERR, status);
3823         return -1;
3824     }
3825
3826     /* If it does, then for now assume that we are on a workstation */
3827     /* Now verify that SYS$COMMAND is a terminal */
3828     /* for creating the debugger DECTerm */
3829
3830     items[0].len = 4;
3831     items[0].code = DVI$_DEVCLASS;
3832     items[0].bufadr = &devclass;
3833     items[0].retadr = NULL;
3834     items[1].len = 0;
3835     items[1].code = 0;
3836
3837     status = sys$getdviw
3838         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3839
3840     if ($VMS_STATUS_SUCCESS(status)) {
3841         status = dvi_iosb[0];
3842     }
3843
3844     if (!$VMS_STATUS_SUCCESS(status)) {
3845         SETERRNO(EVMSERR, status);
3846         return -1;
3847     }
3848     else {
3849         if (devclass == DC$_TERM) {
3850             return 0;
3851         }
3852     }
3853     return -1;
3854 }
3855
3856 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3857 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3858 {
3859     int status;
3860     int ret_stat;
3861     char * ret_char;
3862     char device_name[65];
3863     unsigned short device_name_len;
3864     struct dsc$descriptor_s customization_dsc;
3865     struct dsc$descriptor_s device_name_dsc;
3866     const char * cptr;
3867     char * tptr;
3868     char customization[200];
3869     char title[40];
3870     pInfo info = NULL;
3871     char mbx1[64];
3872     unsigned short p_chan;
3873     int n;
3874     unsigned short iosb[4];
3875     struct item_list_3 items[2];
3876     const char * cust_str =
3877         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3878     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3879                                           DSC$K_CLASS_S, mbx1};
3880
3881      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3882     /*---------------------------------------*/
3883     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
3884
3885
3886     /* Make sure that this is from the Perl debugger */
3887     ret_char = strstr(cmd," xterm ");
3888     if (ret_char == NULL)
3889         return NULL;
3890     cptr = ret_char + 7;
3891     ret_char = strstr(cmd,"tty");
3892     if (ret_char == NULL)
3893         return NULL;
3894     ret_char = strstr(cmd,"sleep");
3895     if (ret_char == NULL)
3896         return NULL;
3897
3898     if (decw_term_port == 0) {
3899         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3900         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3901         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3902
3903        status = lib$find_image_symbol
3904                                (&filename1_dsc,
3905                                 &decw_term_port_dsc,
3906                                 (void *)&decw_term_port,
3907                                 NULL,
3908                                 0);
3909
3910         /* Try again with the other image name */
3911         if (!$VMS_STATUS_SUCCESS(status)) {
3912
3913            status = lib$find_image_symbol
3914                                (&filename2_dsc,
3915                                 &decw_term_port_dsc,
3916                                 (void *)&decw_term_port,
3917                                 NULL,
3918                                 0);
3919
3920         }
3921
3922     }
3923
3924
3925     /* No decw$term_port, give it up */
3926     if (!$VMS_STATUS_SUCCESS(status))
3927         return NULL;
3928
3929     /* Are we on a workstation? */
3930     /* to do: capture the rows / columns and pass their properties */
3931     ret_stat = vms_is_syscommand_xterm();
3932     if (ret_stat < 0)
3933         return NULL;
3934
3935     /* Make the title: */
3936     ret_char = strstr(cptr,"-title");
3937     if (ret_char != NULL) {
3938         while ((*cptr != 0) && (*cptr != '\"')) {
3939             cptr++;
3940         }
3941         if (*cptr == '\"')
3942             cptr++;
3943         n = 0;
3944         while ((*cptr != 0) && (*cptr != '\"')) {
3945             title[n] = *cptr;
3946             n++;
3947             if (n == 39) {
3948                 title[39] == 0;
3949                 break;
3950             }
3951             cptr++;
3952         }
3953         title[n] = 0;
3954     }
3955     else {
3956             /* Default title */
3957             strcpy(title,"Perl Debug DECTerm");
3958     }
3959     sprintf(customization, cust_str, title);
3960
3961     customization_dsc.dsc$a_pointer = customization;
3962     customization_dsc.dsc$w_length = strlen(customization);
3963     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3964     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3965
3966     device_name_dsc.dsc$a_pointer = device_name;
3967     device_name_dsc.dsc$w_length = sizeof device_name -1;
3968     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3969     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3970
3971     device_name_len = 0;
3972
3973     /* Try to create the window */
3974      status = (*decw_term_port)
3975        (NULL,
3976         NULL,
3977         &customization_dsc,
3978         &device_name_dsc,
3979         &device_name_len,
3980         NULL,
3981         NULL,
3982         NULL);
3983     if (!$VMS_STATUS_SUCCESS(status)) {
3984         SETERRNO(EVMSERR, status);
3985         return NULL;
3986     }
3987
3988     device_name[device_name_len] = '\0';
3989
3990     /* Need to set this up to look like a pipe for cleanup */
3991     n = sizeof(Info);
3992     status = lib$get_vm(&n, &info);
3993     if (!$VMS_STATUS_SUCCESS(status)) {
3994         SETERRNO(ENOMEM, status);
3995         return NULL;
3996     }
3997
3998     info->mode = *mode;
3999     info->done = FALSE;
4000     info->completion = 0;
4001     info->closing    = FALSE;
4002     info->in         = 0;
4003     info->out        = 0;
4004     info->err        = 0;
4005     info->fp         = Nullfp;
4006     info->useFILE    = 0;
4007     info->waiting    = 0;
4008     info->in_done    = TRUE;
4009     info->out_done   = TRUE;
4010     info->err_done   = TRUE;
4011
4012     /* Assign a channel on this so that it will persist, and not login */
4013     /* We stash this channel in the info structure for reference. */
4014     /* The created xterm self destructs when the last channel is removed */
4015     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4016     /* So leave this assigned. */
4017     device_name_dsc.dsc$w_length = device_name_len;
4018     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4019     if (!$VMS_STATUS_SUCCESS(status)) {
4020         SETERRNO(EVMSERR, status);
4021         return NULL;
4022     }
4023     info->xchan_valid = 1;
4024
4025     /* Now create a mailbox to be read by the application */
4026
4027     create_mbx(aTHX_ &p_chan, &d_mbx1);
4028
4029     /* write the name of the created terminal to the mailbox */
4030     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4031             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4032
4033     if (!$VMS_STATUS_SUCCESS(status)) {
4034         SETERRNO(EVMSERR, status);
4035         return NULL;
4036     }
4037
4038     info->fp  = PerlIO_open(mbx1, mode);
4039
4040     /* Done with this channel */
4041     sys$dassgn(p_chan);
4042
4043     /* If any errors, then clean up */
4044     if (!info->fp) {
4045         n = sizeof(Info);
4046         _ckvmssts(lib$free_vm(&n, &info));
4047         return NULL;
4048         }
4049
4050     /* All done */
4051     return info->fp;
4052 }
4053
4054 static PerlIO *
4055 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4056 {
4057     static int handler_set_up = FALSE;
4058     unsigned long int sts, flags = CLI$M_NOWAIT;
4059     /* The use of a GLOBAL table (as was done previously) rendered
4060      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4061      * environment.  Hence we've switched to LOCAL symbol table.
4062      */
4063     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4064     int j, wait = 0, n;
4065     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4066     char *in, *out, *err, mbx[512];
4067     FILE *tpipe = 0;
4068     char tfilebuf[NAM$C_MAXRSS+1];
4069     pInfo info = NULL;
4070     char cmd_sym_name[20];
4071     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4072                                       DSC$K_CLASS_S, symbol};
4073     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4074                                       DSC$K_CLASS_S, 0};
4075     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4076                                       DSC$K_CLASS_S, cmd_sym_name};
4077     struct dsc$descriptor_s *vmscmd;
4078     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4079     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4080     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4081
4082     /* Check here for Xterm create request.  This means looking for
4083      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4084      *  is possible to create an xterm.
4085      */
4086     if (*in_mode == 'r') {
4087         PerlIO * xterm_fd;
4088
4089         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4090         if (xterm_fd != Nullfp)
4091             return xterm_fd;
4092     }
4093
4094     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4095
4096     /* once-per-program initialization...
4097        note that the SETAST calls and the dual test of pipe_ef
4098        makes sure that only the FIRST thread through here does
4099        the initialization...all other threads wait until it's
4100        done.
4101
4102        Yeah, uglier than a pthread call, it's got all the stuff inline
4103        rather than in a separate routine.
4104     */
4105
4106     if (!pipe_ef) {
4107         _ckvmssts(sys$setast(0));
4108         if (!pipe_ef) {
4109             unsigned long int pidcode = JPI$_PID;
4110             $DESCRIPTOR(d_delay, RETRY_DELAY);
4111             _ckvmssts(lib$get_ef(&pipe_ef));
4112             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4113             _ckvmssts(sys$bintim(&d_delay, delaytime));
4114         }
4115         if (!handler_set_up) {
4116           _ckvmssts(sys$dclexh(&pipe_exitblock));
4117           handler_set_up = TRUE;
4118         }
4119         _ckvmssts(sys$setast(1));
4120     }
4121
4122     /* see if we can find a VMSPIPE.COM */
4123
4124     tfilebuf[0] = '@';
4125     vmspipe = find_vmspipe(aTHX);
4126     if (vmspipe) {
4127         strcpy(tfilebuf+1,vmspipe);
4128     } else {        /* uh, oh...we're in tempfile hell */
4129         tpipe = vmspipe_tempfile(aTHX);
4130         if (!tpipe) {       /* a fish popular in Boston */
4131             if (ckWARN(WARN_PIPE)) {
4132                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4133             }
4134         return Nullfp;
4135         }
4136         fgetname(tpipe,tfilebuf+1,1);
4137     }
4138     vmspipedsc.dsc$a_pointer = tfilebuf;
4139     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4140
4141     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4142     if (!(sts & 1)) {
4143       switch (sts) {
4144         case RMS$_FNF:  case RMS$_DNF:
4145           set_errno(ENOENT); break;
4146         case RMS$_DIR:
4147           set_errno(ENOTDIR); break;
4148         case RMS$_DEV:
4149           set_errno(ENODEV); break;
4150         case RMS$_PRV:
4151           set_errno(EACCES); break;
4152         case RMS$_SYN:
4153           set_errno(EINVAL); break;
4154         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4155           set_errno(E2BIG); break;
4156         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4157           _ckvmssts(sts); /* fall through */
4158         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4159           set_errno(EVMSERR);
4160       }
4161       set_vaxc_errno(sts);
4162       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4163         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4164       }
4165       *psts = sts;
4166       return Nullfp;
4167     }
4168     n = sizeof(Info);
4169     _ckvmssts(lib$get_vm(&n, &info));
4170
4171     strcpy(mode,in_mode);
4172     info->mode = *mode;
4173     info->done = FALSE;
4174     info->completion = 0;
4175     info->closing    = FALSE;
4176     info->in         = 0;
4177     info->out        = 0;
4178     info->err        = 0;
4179     info->fp         = Nullfp;
4180     info->useFILE    = 0;
4181     info->waiting    = 0;
4182     info->in_done    = TRUE;
4183     info->out_done   = TRUE;
4184     info->err_done   = TRUE;
4185     info->xchan      = 0;
4186     info->xchan_valid = 0;
4187
4188     in = PerlMem_malloc(VMS_MAXRSS);
4189     if (in == NULL) _ckvmssts(SS$_INSFMEM);
4190     out = PerlMem_malloc(VMS_MAXRSS);
4191     if (out == NULL) _ckvmssts(SS$_INSFMEM);
4192     err = PerlMem_malloc(VMS_MAXRSS);
4193     if (err == NULL) _ckvmssts(SS$_INSFMEM);
4194
4195     in[0] = out[0] = err[0] = '\0';
4196
4197     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4198         info->useFILE = 1;
4199         strcpy(p,p+1);
4200     }
4201     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4202         wait = 1;
4203         strcpy(p,p+1);
4204     }
4205
4206     if (*mode == 'r') {             /* piping from subroutine */
4207
4208         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4209         if (info->out) {
4210             info->out->pipe_done = &info->out_done;
4211             info->out_done = FALSE;
4212             info->out->info = info;
4213         }
4214         if (!info->useFILE) {
4215             info->fp  = PerlIO_open(mbx, mode);
4216         } else {
4217             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4218             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4219         }
4220
4221         if (!info->fp && info->out) {
4222             sys$cancel(info->out->chan_out);
4223
4224             while (!info->out_done) {
4225                 int done;
4226                 _ckvmssts(sys$setast(0));
4227                 done = info->out_done;
4228                 if (!done) _ckvmssts(sys$clref(pipe_ef));
4229                 _ckvmssts(sys$setast(1));
4230                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4231             }
4232
4233             if (info->out->buf) {
4234                 n = info->out->bufsize * sizeof(char);
4235                 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4236             }
4237             n = sizeof(Pipe);
4238             _ckvmssts(lib$free_vm(&n, &info->out));
4239             n = sizeof(Info);
4240             _ckvmssts(lib$free_vm(&n, &info));
4241             *psts = RMS$_FNF;
4242             return Nullfp;
4243         }
4244
4245         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4246         if (info->err) {
4247             info->err->pipe_done = &info->err_done;
4248             info->err_done = FALSE;
4249             info->err->info = info;
4250         }
4251
4252     } else if (*mode == 'w') {      /* piping to subroutine */
4253
4254         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4255         if (info->out) {
4256             info->out->pipe_done = &info->out_done;
4257             info->out_done = FALSE;
4258             info->out->info = info;
4259         }
4260
4261         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4262         if (info->err) {
4263             info->err->pipe_done = &info->err_done;
4264             info->err_done = FALSE;
4265             info->err->info = info;
4266         }
4267
4268         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4269         if (!info->useFILE) {
4270             info->fp  = PerlIO_open(mbx, mode);
4271         } else {
4272             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4273             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4274         }
4275
4276         if (info->in) {
4277             info->in->pipe_done = &info->in_done;
4278             info->in_done = FALSE;
4279             info->in->info = info;
4280         }
4281
4282         /* error cleanup */
4283         if (!info->fp && info->in) {
4284             info->done = TRUE;
4285             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4286                               0, 0, 0, 0, 0, 0, 0, 0));
4287
4288             while (!info->in_done) {
4289                 int done;
4290                 _ckvmssts(sys$setast(0));
4291                 done = info->in_done;
4292                 if (!done) _ckvmssts(sys$clref(pipe_ef));
4293                 _ckvmssts(sys$setast(1));
4294                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4295             }
4296
4297             if (info->in->buf) {
4298                 n = info->in->bufsize * sizeof(char);
4299                 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4300             }
4301             n = sizeof(Pipe);
4302             _ckvmssts(lib$free_vm(&n, &info->in));
4303             n = sizeof(Info);
4304             _ckvmssts(lib$free_vm(&n, &info));
4305             *psts = RMS$_FNF;
4306             return Nullfp;
4307         }
4308
4309
4310     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4311         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4312         if (info->out) {
4313             info->out->pipe_done = &info->out_done;
4314             info->out_done = FALSE;
4315             info->out->info = info;
4316         }
4317
4318         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4319         if (info->err) {
4320             info->err->pipe_done = &info->err_done;
4321             info->err_done = FALSE;
4322             info->err->info = info;
4323         }
4324     }
4325
4326     symbol[MAX_DCL_SYMBOL] = '\0';
4327
4328     strncpy(symbol, in, MAX_DCL_SYMBOL);
4329     d_symbol.dsc$w_length = strlen(symbol);
4330     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4331
4332     strncpy(symbol, err, MAX_DCL_SYMBOL);
4333     d_symbol.dsc$w_length = strlen(symbol);
4334     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4335
4336     strncpy(symbol, out, MAX_DCL_SYMBOL);
4337     d_symbol.dsc$w_length = strlen(symbol);
4338     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4339
4340     /* Done with the names for the pipes */
4341     PerlMem_free(err);
4342     PerlMem_free(out);
4343     PerlMem_free(in);
4344
4345     p = vmscmd->dsc$a_pointer;
4346     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4347     if (*p == '$') p++;                         /* remove leading $ */
4348     while (*p == ' ' || *p == '\t') p++;
4349
4350     for (j = 0; j < 4; j++) {
4351         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4352         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4353
4354     strncpy(symbol, p, MAX_DCL_SYMBOL);
4355     d_symbol.dsc$w_length = strlen(symbol);
4356     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4357
4358         if (strlen(p) > MAX_DCL_SYMBOL) {
4359             p += MAX_DCL_SYMBOL;
4360         } else {
4361             p += strlen(p);
4362         }
4363     }
4364     _ckvmssts(sys$setast(0));
4365     info->next=open_pipes;  /* prepend to list */
4366     open_pipes=info;
4367     _ckvmssts(sys$setast(1));
4368     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4369      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4370      * have SYS$COMMAND if we need it.
4371      */
4372     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4373                       0, &info->pid, &info->completion,
4374                       0, popen_completion_ast,info,0,0,0));
4375
4376     /* if we were using a tempfile, close it now */
4377
4378     if (tpipe) fclose(tpipe);
4379
4380     /* once the subprocess is spawned, it has copied the symbols and
4381        we can get rid of ours */
4382
4383     for (j = 0; j < 4; j++) {
4384         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4385         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4386     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4387     }
4388     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
4389     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4390     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4391     vms_execfree(vmscmd);
4392
4393 #ifdef PERL_IMPLICIT_CONTEXT
4394     if (aTHX)
4395 #endif
4396     PL_forkprocess = info->pid;
4397
4398     if (wait) {
4399          int done = 0;
4400          while (!done) {
4401              _ckvmssts(sys$setast(0));
4402              done = info->done;
4403              if (!done) _ckvmssts(sys$clref(pipe_ef));
4404              _ckvmssts(sys$setast(1));
4405              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4406          }
4407         *psts = info->completion;
4408 /* Caller thinks it is open and tries to close it. */
4409 /* This causes some problems, as it changes the error status */
4410 /*        my_pclose(info->fp); */
4411     } else {
4412         *psts = info->pid;
4413     }
4414     return info->fp;
4415 }  /* end of safe_popen */
4416
4417
4418 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4419 PerlIO *
4420 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4421 {
4422     int sts;
4423     TAINT_ENV();
4424     TAINT_PROPER("popen");
4425     PERL_FLUSHALL_FOR_CHILD;
4426     return safe_popen(aTHX_ cmd,mode,&sts);
4427 }
4428
4429 /*}}}*/
4430
4431 /*{{{  I32 my_pclose(PerlIO *fp)*/
4432 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4433 {
4434     pInfo info, last = NULL;
4435     unsigned long int retsts;
4436     int done, iss, n;
4437     int status;
4438
4439     for (info = open_pipes; info != NULL; last = info, info = info->next)
4440         if (info->fp == fp) break;
4441
4442     if (info == NULL) {  /* no such pipe open */
4443       set_errno(ECHILD); /* quoth POSIX */
4444       set_vaxc_errno(SS$_NONEXPR);
4445       return -1;
4446     }
4447
4448     /* If we were writing to a subprocess, insure that someone reading from
4449      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4450      * produce an EOF record in the mailbox.
4451      *
4452      *  well, at least sometimes it *does*, so we have to watch out for
4453      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4454      */
4455      if (info->fp) {
4456         if (!info->useFILE
4457 #if defined(USE_ITHREADS)
4458           && my_perl
4459 #endif
4460           && PL_perlio_fd_refcnt)
4461             PerlIO_flush(info->fp);
4462         else
4463             fflush((FILE *)info->fp);
4464     }
4465
4466     _ckvmssts(sys$setast(0));
4467      info->closing = TRUE;
4468      done = info->done && info->in_done && info->out_done && info->err_done;
4469      /* hanging on write to Perl's input? cancel it */
4470      if (info->mode == 'r' && info->out && !info->out_done) {
4471         if (info->out->chan_out) {
4472             _ckvmssts(sys$cancel(info->out->chan_out));
4473             if (!info->out->chan_in) {   /* EOF generation, need AST */
4474                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4475             }
4476         }
4477      }
4478      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4479          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4480                            0, 0, 0, 0, 0, 0));
4481     _ckvmssts(sys$setast(1));
4482     if (info->fp) {
4483      if (!info->useFILE
4484 #if defined(USE_ITHREADS)
4485          && my_perl
4486 #endif
4487          && PL_perlio_fd_refcnt)
4488         PerlIO_close(info->fp);
4489      else
4490         fclose((FILE *)info->fp);
4491     }
4492      /*
4493         we have to wait until subprocess completes, but ALSO wait until all
4494         the i/o completes...otherwise we'll be freeing the "info" structure
4495         that the i/o ASTs could still be using...
4496      */
4497
4498      while (!done) {
4499          _ckvmssts(sys$setast(0));
4500          done = info->done && info->in_done && info->out_done && info->err_done;
4501          if (!done) _ckvmssts(sys$clref(pipe_ef));
4502          _ckvmssts(sys$setast(1));
4503          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4504      }
4505      retsts = info->completion;
4506
4507     /* remove from list of open pipes */
4508     _ckvmssts(sys$setast(0));
4509     if (last) last->next = info->next;
4510     else open_pipes = info->next;
4511     _ckvmssts(sys$setast(1));
4512
4513     /* free buffers and structures */
4514
4515     if (info->in) {
4516         if (info->in->buf) {
4517             n = info->in->bufsize * sizeof(char);
4518             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4519         }
4520         n = sizeof(Pipe);
4521         _ckvmssts(lib$free_vm(&n, &info->in));
4522     }
4523     if (info->out) {
4524         if (info->out->buf) {
4525             n = info->out->bufsize * sizeof(char);
4526             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4527         }
4528         n = sizeof(Pipe);
4529         _ckvmssts(lib$free_vm(&n, &info->out));
4530     }
4531     if (info->err) {
4532         if (info->err->buf) {
4533             n = info->err->bufsize * sizeof(char);
4534             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4535         }
4536         n = sizeof(Pipe);
4537         _ckvmssts(lib$free_vm(&n, &info->err));
4538     }
4539     n = sizeof(Info);
4540     _ckvmssts(lib$free_vm(&n, &info));
4541
4542     return retsts;
4543
4544 }  /* end of my_pclose() */
4545
4546 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4547   /* Roll our own prototype because we want this regardless of whether
4548    * _VMS_WAIT is defined.
4549    */
4550   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4551 #endif
4552 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4553    created with popen(); otherwise partially emulate waitpid() unless
4554    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4555    Also check processes not considered by the CRTL waitpid().
4556  */
4557 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4558 Pid_t
4559 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4560 {
4561     pInfo info;
4562     int done;
4563     int sts;
4564     int j;
4565
4566     if (statusp) *statusp = 0;
4567
4568     for (info = open_pipes; info != NULL; info = info->next)
4569         if (info->pid == pid) break;
4570
4571     if (info != NULL) {  /* we know about this child */
4572       while (!info->done) {
4573           _ckvmssts(sys$setast(0));
4574           done = info->done;
4575           if (!done) _ckvmssts(sys$clref(pipe_ef));
4576           _ckvmssts(sys$setast(1));
4577           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4578       }
4579
4580       if (statusp) *statusp = info->completion;
4581       return pid;
4582     }
4583
4584     /* child that already terminated? */
4585
4586     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4587         if (closed_list[j].pid == pid) {
4588             if (statusp) *statusp = closed_list[j].completion;
4589             return pid;
4590         }
4591     }
4592
4593     /* fall through if this child is not one of our own pipe children */
4594
4595 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4596
4597       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4598        * in 7.2 did we get a version that fills in the VMS completion
4599        * status as Perl has always tried to do.
4600        */
4601
4602       sts = __vms_waitpid( pid, statusp, flags );
4603
4604       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4605          return sts;
4606
4607       /* If the real waitpid tells us the child does not exist, we
4608        * fall through here to implement waiting for a child that
4609        * was created by some means other than exec() (say, spawned
4610        * from DCL) or to wait for a process that is not a subprocess
4611        * of the current process.
4612        */
4613
4614 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4615
4616     {
4617       $DESCRIPTOR(intdsc,"0 00:00:01");
4618       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4619       unsigned long int pidcode = JPI$_PID, mypid;
4620       unsigned long int interval[2];
4621       unsigned int jpi_iosb[2];
4622       struct itmlst_3 jpilist[2] = {
4623           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4624           {                      0,         0,                 0, 0}
4625       };
4626
4627       if (pid <= 0) {
4628         /* Sorry folks, we don't presently implement rooting around for
4629            the first child we can find, and we definitely don't want to
4630            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4631          */
4632         set_errno(ENOTSUP);
4633         return -1;
4634       }
4635
4636       /* Get the owner of the child so I can warn if it's not mine. If the
4637        * process doesn't exist or I don't have the privs to look at it,
4638        * I can go home early.
4639        */
4640       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4641       if (sts & 1) sts = jpi_iosb[0];
4642       if (!(sts & 1)) {
4643         switch (sts) {
4644             case SS$_NONEXPR:
4645                 set_errno(ECHILD);
4646                 break;
4647             case SS$_NOPRIV:
4648                 set_errno(EACCES);
4649                 break;
4650             default:
4651                 _ckvmssts(sts);
4652         }
4653         set_vaxc_errno(sts);
4654         return -1;
4655       }
4656
4657       if (ckWARN(WARN_EXEC)) {
4658         /* remind folks they are asking for non-standard waitpid behavior */
4659         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4660         if (ownerpid != mypid)
4661           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4662                       "waitpid: process %x is not a child of process %x",
4663                       pid,mypid);
4664       }
4665
4666       /* simply check on it once a second until it's not there anymore. */
4667
4668       _ckvmssts(sys$bintim(&intdsc,interval));
4669       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4670             _ckvmssts(sys$schdwk(0,0,interval,0));
4671             _ckvmssts(sys$hiber());
4672       }
4673       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4674
4675       _ckvmssts(sts);
4676       return pid;
4677     }
4678 }  /* end of waitpid() */
4679 /*}}}*/
4680 /*}}}*/
4681 /*}}}*/
4682
4683 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4684 char *
4685 my_gconvert(double val, int ndig, int trail, char *buf)
4686 {
4687   static char __gcvtbuf[DBL_DIG+1];
4688   char *loc;
4689
4690   loc = buf ? buf : __gcvtbuf;
4691
4692 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4693   if (val < 1) {
4694     sprintf(loc,"%.*g",ndig,val);
4695     return loc;
4696   }
4697 #endif
4698
4699   if (val) {
4700     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4701     return gcvt(val,ndig,loc);
4702   }
4703   else {
4704     loc[0] = '0'; loc[1] = '\0';
4705     return loc;
4706   }
4707
4708 }
4709 /*}}}*/
4710
4711 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4712 static int rms_free_search_context(struct FAB * fab)
4713 {
4714 struct NAM * nam;
4715
4716     nam = fab->fab$l_nam;
4717     nam->nam$b_nop |= NAM$M_SYNCHK;
4718     nam->nam$l_rlf = NULL;
4719     fab->fab$b_dns = 0;
4720     return sys$parse(fab, NULL, NULL);
4721 }
4722
4723 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4724 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4725 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4726 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4727 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4728 #define rms_nam_esll(nam) nam.nam$b_esl
4729 #define rms_nam_esl(nam) nam.nam$b_esl
4730 #define rms_nam_name(nam) nam.nam$l_name
4731 #define rms_nam_namel(nam) nam.nam$l_name
4732 #define rms_nam_type(nam) nam.nam$l_type
4733 #define rms_nam_typel(nam) nam.nam$l_type
4734 #define rms_nam_ver(nam) nam.nam$l_ver
4735 #define rms_nam_verl(nam) nam.nam$l_ver
4736 #define rms_nam_rsll(nam) nam.nam$b_rsl
4737 #define rms_nam_rsl(nam) nam.nam$b_rsl
4738 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4739 #define rms_set_fna(fab, nam, name, size) \
4740         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4741 #define rms_get_fna(fab, nam) fab.fab$l_fna
4742 #define rms_set_dna(fab, nam, name, size) \
4743         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4744 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4745 #define rms_set_esa(nam, name, size) \
4746         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4747 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4748         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4749 #define rms_set_rsa(nam, name, size) \
4750         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4751 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4752         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4753 #define rms_nam_name_type_l_size(nam) \
4754         (nam.nam$b_name + nam.nam$b_type)
4755 #else
4756 static int rms_free_search_context(struct FAB * fab)
4757 {
4758 struct NAML * nam;
4759
4760     nam = fab->fab$l_naml;
4761     nam->naml$b_nop |= NAM$M_SYNCHK;
4762     nam->naml$l_rlf = NULL;
4763     nam->naml$l_long_defname_size = 0;
4764
4765     fab->fab$b_dns = 0;
4766     return sys$parse(fab, NULL, NULL);
4767 }
4768
4769 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4770 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4771 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4772 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4773 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4774 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4775 #define rms_nam_esl(nam) nam.naml$b_esl
4776 #define rms_nam_name(nam) nam.naml$l_name
4777 #define rms_nam_namel(nam) nam.naml$l_long_name
4778 #define rms_nam_type(nam) nam.naml$l_type
4779 #define rms_nam_typel(nam) nam.naml$l_long_type
4780 #define rms_nam_ver(nam) nam.naml$l_ver
4781 #define rms_nam_verl(nam) nam.naml$l_long_ver
4782 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4783 #define rms_nam_rsl(nam) nam.naml$b_rsl
4784 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4785 #define rms_set_fna(fab, nam, name, size) \
4786         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4787         nam.naml$l_long_filename_size = size; \
4788         nam.naml$l_long_filename = name;}
4789 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4790 #define rms_set_dna(fab, nam, name, size) \
4791         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4792         nam.naml$l_long_defname_size = size; \
4793         nam.naml$l_long_defname = name; }
4794 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4795 #define rms_set_esa(nam, name, size) \
4796         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4797         nam.naml$l_long_expand_alloc = size; \
4798         nam.naml$l_long_expand = name; }
4799 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4800         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4801         nam.naml$l_long_expand = l_name; \
4802         nam.naml$l_long_expand_alloc = l_size; }
4803 #define rms_set_rsa(nam, name, size) \
4804         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4805         nam.naml$l_long_result = name; \
4806         nam.naml$l_long_result_alloc = size; }
4807 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4808         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4809         nam.naml$l_long_result = l_name; \
4810         nam.naml$l_long_result_alloc = l_size; }
4811 #define rms_nam_name_type_l_size(nam) \
4812         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4813 #endif
4814
4815
4816 /* rms_erase
4817  * The CRTL for 8.3 and later can create symbolic links in any mode,
4818  * however in 8.3 the unlink/remove/delete routines will only properly handle
4819  * them if one of the PCP modes is active.
4820  */
4821 static int rms_erase(const char * vmsname)
4822 {
4823   int status;
4824   struct FAB myfab = cc$rms_fab;
4825   rms_setup_nam(mynam);
4826
4827   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4828   rms_bind_fab_nam(myfab, mynam);
4829
4830   /* Are we removing all versions? */
4831   if (vms_unlink_all_versions == 1) {
4832     const char * defspec = ";*";
4833     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4834   }
4835
4836 #ifdef NAML$M_OPEN_SPECIAL
4837   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4838 #endif
4839
4840   status = sys$erase(&myfab, 0, 0);
4841
4842   return status;
4843 }
4844
4845
4846 static int
4847 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4848                     const struct dsc$descriptor_s * vms_dst_dsc,
4849                     unsigned long flags)
4850 {
4851     /*  VMS and UNIX handle file permissions differently and the
4852      * the same ACL trick may be needed for renaming files,
4853      * especially if they are directories.
4854      */
4855
4856    /* todo: get kill_file and rename to share common code */
4857    /* I can not find online documentation for $change_acl
4858     * it appears to be replaced by $set_security some time ago */
4859
4860 const unsigned int access_mode = 0;
4861 $DESCRIPTOR(obj_file_dsc,"FILE");
4862 char *vmsname;
4863 char *rslt;
4864 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
4865 int aclsts, fndsts, rnsts = -1;
4866 unsigned int ctx = 0;
4867 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4868 struct dsc$descriptor_s * clean_dsc;
4869
4870 struct myacedef {
4871     unsigned char myace$b_length;
4872     unsigned char myace$b_type;
4873     unsigned short int myace$w_flags;
4874     unsigned long int myace$l_access;
4875     unsigned long int myace$l_ident;
4876 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
4877              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
4878              0},
4879              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
4880
4881 struct item_list_3
4882         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
4883                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
4884                       {0,0,0,0}},
4885         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
4886         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
4887                      {0,0,0,0}};
4888
4889
4890     /* Expand the input spec using RMS, since we do not want to put
4891      * ACLs on the target of a symbolic link */
4892     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
4893     if (vmsname == NULL)
4894         return SS$_INSFMEM;
4895
4896     rslt = do_rmsexpand(vms_src_dsc->dsc$a_pointer,
4897                         vmsname,
4898                         0,
4899                         NULL,
4900                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
4901                         NULL,
4902                         NULL);
4903     if (rslt == NULL) {
4904         PerlMem_free(vmsname);
4905         return SS$_INSFMEM;
4906     }
4907
4908     /* So we get our own UIC to use as a rights identifier,
4909      * and the insert an ACE at the head of the ACL which allows us
4910      * to delete the file.
4911      */
4912     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
4913
4914     fildsc.dsc$w_length = strlen(vmsname);
4915     fildsc.dsc$a_pointer = vmsname;
4916     ctx = 0;
4917     newace.myace$l_ident = oldace.myace$l_ident;
4918     rnsts = SS$_ABORT;
4919
4920     /* Grab any existing ACEs with this identifier in case we fail */
4921     clean_dsc = &fildsc;
4922     aclsts = fndsts = sys$get_security(&obj_file_dsc,
4923                                &fildsc,
4924                                NULL,
4925                                OSS$M_WLOCK,
4926                                findlst,
4927                                &ctx,
4928                                &access_mode);
4929
4930     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
4931         /* Add the new ACE . . . */
4932
4933         /* if the sys$get_security succeeded, then ctx is valid, and the
4934          * object/file descriptors will be ignored.  But otherwise they
4935          * are needed
4936          */
4937         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
4938                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
4939         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4940             set_errno(EVMSERR);
4941             set_vaxc_errno(aclsts);
4942             PerlMem_free(vmsname);
4943             return aclsts;
4944         }
4945
4946         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
4947                                 NULL, NULL,
4948                                 &flags,
4949                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
4950
4951         if ($VMS_STATUS_SUCCESS(rnsts)) {
4952             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
4953         }
4954
4955         /* Put things back the way they were. */
4956         ctx = 0;
4957         aclsts = sys$get_security(&obj_file_dsc,
4958                                   clean_dsc,
4959                                   NULL,
4960                                   OSS$M_WLOCK,
4961                                   findlst,
4962                                   &ctx,
4963                                   &access_mode);
4964
4965         if ($VMS_STATUS_SUCCESS(aclsts)) {
4966         int sec_flags;
4967
4968             sec_flags = 0;
4969             if (!$VMS_STATUS_SUCCESS(fndsts))
4970                 sec_flags = OSS$M_RELCTX;
4971
4972             /* Get rid of the new ACE */
4973             aclsts = sys$set_security(NULL, NULL, NULL,
4974                                   sec_flags, dellst, &ctx, &access_mode);
4975
4976             /* If there was an old ACE, put it back */
4977             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
4978                 addlst[0].bufadr = &oldace;
4979                 aclsts = sys$set_security(NULL, NULL, NULL,
4980                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
4981                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4982                     set_errno(EVMSERR);
4983                     set_vaxc_errno(aclsts);
4984                     rnsts = aclsts;
4985                 }
4986             } else {
4987             int aclsts2;
4988
4989                 /* Try to clear the lock on the ACL list */
4990                 aclsts2 = sys$set_security(NULL, NULL, NULL,
4991                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
4992
4993                 /* Rename errors are most important */
4994                 if (!$VMS_STATUS_SUCCESS(rnsts))
4995                     aclsts = rnsts;
4996                 set_errno(EVMSERR);
4997                 set_vaxc_errno(aclsts);
4998                 rnsts = aclsts;
4999             }
5000         }
5001         else {
5002             if (aclsts != SS$_ACLEMPTY)
5003                 rnsts = aclsts;
5004         }
5005     }
5006     else
5007         rnsts = fndsts;
5008
5009     PerlMem_free(vmsname);
5010     return rnsts;
5011 }
5012
5013
5014 /*{{{int rename(const char *, const char * */
5015 /* Not exactly what X/Open says to do, but doing it absolutely right
5016  * and efficiently would require a lot more work.  This should be close
5017  * enough to pass all but the most strict X/Open compliance test.
5018  */
5019 int
5020 Perl_rename(pTHX_ const char *src, const char * dst)
5021 {
5022 int retval;
5023 int pre_delete = 0;
5024 int src_sts;
5025 int dst_sts;
5026 Stat_t src_st;
5027 Stat_t dst_st;
5028
5029     /* Validate the source file */
5030     src_sts = flex_lstat(src, &src_st);
5031     if (src_sts != 0) {
5032
5033         /* No source file or other problem */
5034         return src_sts;
5035     }
5036
5037     dst_sts = flex_lstat(dst, &dst_st);
5038     if (dst_sts == 0) {
5039
5040         if (dst_st.st_dev != src_st.st_dev) {
5041             /* Must be on the same device */
5042             errno = EXDEV;
5043             return -1;
5044         }
5045
5046         /* VMS_INO_T_COMPARE is true if the inodes are different
5047          * to match the output of memcmp
5048          */
5049
5050         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5051             /* That was easy, the files are the same! */
5052             return 0;
5053         }
5054
5055         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5056             /* If source is a directory, so must be dest */
5057                 errno = EISDIR;
5058                 return -1;
5059         }
5060
5061     }
5062
5063
5064     if ((dst_sts == 0) &&
5065         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5066
5067         /* We have issues here if vms_unlink_all_versions is set
5068          * If the destination exists, and is not a directory, then
5069          * we must delete in advance.
5070          *
5071          * If the src is a directory, then we must always pre-delete
5072          * the destination.
5073          *
5074          * If we successfully delete the dst in advance, and the rename fails
5075          * X/Open requires that errno be EIO.
5076          *
5077          */
5078
5079         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5080             int d_sts;
5081             d_sts = mp_do_kill_file(aTHX_ dst, S_ISDIR(dst_st.st_mode));
5082             if (d_sts != 0)
5083                 return d_sts;
5084
5085             /* We killed the destination, so only errno now is EIO */
5086             pre_delete = 1;
5087         }
5088     }
5089
5090     /* Originally the idea was to call the CRTL rename() and only
5091      * try the lib$rename_file if it failed.
5092      * It turns out that there are too many variants in what the
5093      * the CRTL rename might do, so only use lib$rename_file
5094      */
5095     retval = -1;
5096
5097     {
5098         /* Is the source and dest both in VMS format */
5099         /* if the source is a directory, then need to fileify */
5100         /*  and dest must be a directory or non-existant. */
5101
5102         char * vms_src;
5103         char * vms_dst;
5104         int sts;
5105         char * ret_str;
5106         unsigned long flags;
5107         struct dsc$descriptor_s old_file_dsc;
5108         struct dsc$descriptor_s new_file_dsc;
5109
5110         /* We need to modify the src and dst depending
5111          * on if one or more of them are directories.
5112          */
5113
5114         vms_src = PerlMem_malloc(VMS_MAXRSS);
5115         if (vms_src == NULL)
5116             _ckvmssts(SS$_INSFMEM);
5117
5118         /* Source is always a VMS format file */
5119         ret_str = do_tovmsspec(src, vms_src, 0, NULL);
5120         if (ret_str == NULL) {
5121             PerlMem_free(vms_src);
5122             errno = EIO;
5123             return -1;
5124         }
5125
5126         vms_dst = PerlMem_malloc(VMS_MAXRSS);
5127         if (vms_dst == NULL)
5128             _ckvmssts(SS$_INSFMEM);
5129
5130         if (S_ISDIR(src_st.st_mode)) {
5131         char * ret_str;
5132         char * vms_dir_file;
5133
5134             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5135             if (vms_dir_file == NULL)
5136                 _ckvmssts(SS$_INSFMEM);
5137
5138             /* The source must be a file specification */
5139             ret_str = do_fileify_dirspec(vms_src, vms_dir_file, 0, NULL);
5140             if (ret_str == NULL) {
5141                 PerlMem_free(vms_src);
5142                 PerlMem_free(vms_dst);
5143                 PerlMem_free(vms_dir_file);
5144                 errno = EIO;
5145                 return -1;
5146             }
5147             PerlMem_free(vms_src);
5148             vms_src = vms_dir_file;
5149
5150             /* If the dest is a directory, we must remove it
5151             if (dst_sts == 0) {
5152                 int d_sts;
5153                 d_sts = mp_do_kill_file(aTHX_ dst, 1);
5154                 if (d_sts != 0) {
5155                     PerlMem_free(vms_src);
5156                     PerlMem_free(vms_dst);
5157                     errno = EIO;
5158                     return sts;
5159                 }
5160
5161                 pre_delete = 1;
5162             }
5163
5164            /* The dest must be a VMS file specification */
5165            ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
5166            if (ret_str == NULL) {
5167                 PerlMem_free(vms_src);
5168                 PerlMem_free(vms_dst);
5169                 errno = EIO;
5170                 return -1;
5171            }
5172
5173             /* The source must be a file specification */
5174             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5175             if (vms_dir_file == NULL)
5176                 _ckvmssts(SS$_INSFMEM);
5177
5178             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5179             if (ret_str == NULL) {
5180                 PerlMem_free(vms_src);
5181                 PerlMem_free(vms_dst);
5182                 PerlMem_free(vms_dir_file);
5183                 errno = EIO;
5184                 return -1;
5185             }
5186             PerlMem_free(vms_dst);
5187             vms_dst = vms_dir_file;
5188
5189         } else {
5190             /* File to file or file to new dir */
5191
5192             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5193                 /* VMS pathify a dir target */
5194                 ret_str = do_tovmspath(dst, vms_dst, 0, NULL);
5195                 if (ret_str == NULL) {
5196                     PerlMem_free(vms_src);
5197                     PerlMem_free(vms_dst);
5198                     errno = EIO;
5199                     return -1;
5200                 }
5201             } else {
5202
5203                 /* fileify a target VMS file specification */
5204                 ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
5205                 if (ret_str == NULL) {
5206                     PerlMem_free(vms_src);
5207                     PerlMem_free(vms_dst);
5208                     errno = EIO;
5209                     return -1;
5210                 }
5211             }
5212         }
5213
5214         old_file_dsc.dsc$a_pointer = vms_src;
5215         old_file_dsc.dsc$w_length = strlen(vms_src);
5216         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5217         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5218
5219         new_file_dsc.dsc$a_pointer = vms_dst;
5220         new_file_dsc.dsc$w_length = strlen(vms_dst);
5221         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5222         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5223
5224         flags = 0;
5225 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5226         flags |= 2; /* LIB$M_FIL_LONG_NAMES */
5227 #endif
5228
5229         sts = lib$rename_file(&old_file_dsc,
5230                               &new_file_dsc,
5231                               NULL, NULL,
5232                               &flags,
5233                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5234         if (!$VMS_STATUS_SUCCESS(sts)) {
5235
5236            /* We could have failed because VMS style permissions do not
5237             * permit renames that UNIX will allow.  Just like the hack
5238             * in for kill_file.
5239             */
5240            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5241         }
5242
5243         PerlMem_free(vms_src);
5244         PerlMem_free(vms_dst);
5245         if (!$VMS_STATUS_SUCCESS(sts)) {
5246             errno = EIO;
5247             return -1;
5248         }
5249         retval = 0;
5250     }
5251
5252     if (vms_unlink_all_versions) {
5253         /* Now get rid of any previous versions of the source file that
5254          * might still exist
5255          */
5256         int save_errno;
5257         save_errno = errno;
5258         src_sts = mp_do_kill_file(aTHX_ src, S_ISDIR(src_st.st_mode));
5259         errno = save_errno;
5260     }
5261
5262     /* We deleted the destination, so must force the error to be EIO */
5263     if ((retval != 0) && (pre_delete != 0))
5264         errno = EIO;
5265
5266     return retval;
5267 }
5268 /*}}}*/
5269
5270
5271 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5272 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5273  * to expand file specification.  Allows for a single default file
5274  * specification and a simple mask of options.  If outbuf is non-NULL,
5275  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5276  * the resultant file specification is placed.  If outbuf is NULL, the
5277  * resultant file specification is placed into a static buffer.
5278  * The third argument, if non-NULL, is taken to be a default file
5279  * specification string.  The fourth argument is unused at present.
5280  * rmesexpand() returns the address of the resultant string if
5281  * successful, and NULL on error.
5282  *
5283  * New functionality for previously unused opts value:
5284  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5285  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5286  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5287  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5288  */
5289 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5290
5291 static char *
5292 mp_do_rmsexpand
5293    (pTHX_ const char *filespec,
5294     char *outbuf,
5295     int ts,
5296     const char *defspec,
5297     unsigned opts,
5298     int * fs_utf8,
5299     int * dfs_utf8)
5300 {
5301   static char __rmsexpand_retbuf[VMS_MAXRSS];
5302   char * vmsfspec, *tmpfspec;
5303   char * esa, *cp, *out = NULL;
5304   char * tbuf;
5305   char * esal = NULL;
5306   char * outbufl;
5307   struct FAB myfab = cc$rms_fab;
5308   rms_setup_nam(mynam);
5309   STRLEN speclen;
5310   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5311   int sts;
5312
5313   /* temp hack until UTF8 is actually implemented */
5314   if (fs_utf8 != NULL)
5315     *fs_utf8 = 0;
5316
5317   if (!filespec || !*filespec) {
5318     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5319     return NULL;
5320   }
5321   if (!outbuf) {
5322     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
5323     else    outbuf = __rmsexpand_retbuf;
5324   }
5325
5326   vmsfspec = NULL;
5327   tmpfspec = NULL;
5328   outbufl = NULL;
5329
5330   isunix = 0;
5331   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5332     isunix = is_unix_filespec(filespec);
5333     if (isunix) {
5334       vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5335       if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
5336       if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
5337         PerlMem_free(vmsfspec);
5338         if (out)
5339            Safefree(out);
5340         return NULL;
5341       }
5342       filespec = vmsfspec;
5343
5344       /* Unless we are forcing to VMS format, a UNIX input means
5345        * UNIX output, and that requires long names to be used
5346        */
5347 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5348       if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5349         opts |= PERL_RMSEXPAND_M_LONG;
5350       else
5351 #endif
5352         isunix = 0;
5353       }
5354     }
5355
5356   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
5357   rms_bind_fab_nam(myfab, mynam);
5358
5359   if (defspec && *defspec) {
5360     int t_isunix;
5361     t_isunix = is_unix_filespec(defspec);
5362     if (t_isunix) {
5363       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5364       if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5365       if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
5366         PerlMem_free(tmpfspec);
5367         if (vmsfspec != NULL)
5368             PerlMem_free(vmsfspec);
5369         if (out)
5370            Safefree(out);
5371         return NULL;
5372       }
5373       defspec = tmpfspec;
5374     }
5375     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
5376   }
5377
5378   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5379   if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5380 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5381   esal = PerlMem_malloc(VMS_MAXRSS);
5382   if (esal == NULL) _ckvmssts(SS$_INSFMEM);
5383 #endif
5384   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5385
5386   /* If a NAML block is used RMS always writes to the long and short
5387    * addresses unless you suppress the short name.
5388    */
5389 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5390   outbufl = PerlMem_malloc(VMS_MAXRSS);
5391   if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
5392 #endif
5393    rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5394
5395 #ifdef NAM$M_NO_SHORT_UPCASE
5396   if (decc_efs_case_preserve)
5397     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5398 #endif
5399
5400    /* We may not want to follow symbolic links */
5401 #ifdef NAML$M_OPEN_SPECIAL
5402   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5403     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5404 #endif
5405
5406   /* First attempt to parse as an existing file */
5407   retsts = sys$parse(&myfab,0,0);
5408   if (!(retsts & STS$K_SUCCESS)) {
5409
5410     /* Could not find the file, try as syntax only if error is not fatal */
5411     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5412     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
5413       retsts = sys$parse(&myfab,0,0);
5414       if (retsts & STS$K_SUCCESS) goto expanded;
5415     }
5416
5417      /* Still could not parse the file specification */
5418     /*----------------------------------------------*/
5419     sts = rms_free_search_context(&myfab); /* Free search context */
5420     if (out) Safefree(out);
5421     if (tmpfspec != NULL)
5422         PerlMem_free(tmpfspec);
5423     if (vmsfspec != NULL)
5424         PerlMem_free(vmsfspec);
5425     if (outbufl != NULL)
5426         PerlMem_free(outbufl);
5427     PerlMem_free(esa);
5428     if (esal != NULL)
5429         PerlMem_free(esal);
5430     set_vaxc_errno(retsts);
5431     if      (retsts == RMS$_PRV) set_errno(EACCES);
5432     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5433     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5434     else                         set_errno(EVMSERR);
5435     return NULL;
5436   }
5437   retsts = sys$search(&myfab,0,0);
5438   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5439     sts = rms_free_search_context(&myfab); /* Free search context */
5440     if (out) Safefree(out);
5441     if (tmpfspec != NULL)
5442         PerlMem_free(tmpfspec);
5443     if (vmsfspec != NULL)
5444         PerlMem_free(vmsfspec);
5445     if (outbufl != NULL)
5446         PerlMem_free(outbufl);
5447     PerlMem_free(esa);
5448     if (esal != NULL)
5449         PerlMem_free(esal);
5450     set_vaxc_errno(retsts);
5451     if      (retsts == RMS$_PRV) set_errno(EACCES);
5452     else                         set_errno(EVMSERR);
5453     return NULL;
5454   }
5455
5456   /* If the input filespec contained any lowercase characters,
5457    * downcase the result for compatibility with Unix-minded code. */
5458   expanded:
5459   if (!decc_efs_case_preserve) {
5460     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5461       if (islower(*tbuf)) { haslower = 1; break; }
5462   }
5463
5464    /* Is a long or a short name expected */
5465   /*------------------------------------*/
5466   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5467     if (rms_nam_rsll(mynam)) {
5468         tbuf = outbufl;
5469         speclen = rms_nam_rsll(mynam);
5470     }
5471     else {
5472         tbuf = esal; /* Not esa */
5473         speclen = rms_nam_esll(mynam);
5474     }
5475   }
5476   else {
5477     if (rms_nam_rsl(mynam)) {
5478         tbuf = outbuf;
5479         speclen = rms_nam_rsl(mynam);
5480     }
5481     else {
5482         tbuf = esa; /* Not esal */
5483         speclen = rms_nam_esl(mynam);
5484     }
5485   }
5486   tbuf[speclen] = '\0';
5487
5488   /* Trim off null fields added by $PARSE
5489    * If type > 1 char, must have been specified in original or default spec
5490    * (not true for version; $SEARCH may have added version of existing file).
5491    */
5492   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5493   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5494     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5495              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5496   }
5497   else {
5498     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5499              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5500   }
5501   if (trimver || trimtype) {
5502     if (defspec && *defspec) {
5503       char *defesal = NULL;
5504       char *defesa = NULL;
5505       defesa = PerlMem_malloc(VMS_MAXRSS + 1);
5506       if (defesa != NULL) {
5507 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5508         defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5509         if (defesal == NULL) _ckvmssts(SS$_INSFMEM);
5510 #endif
5511         struct FAB deffab = cc$rms_fab;
5512         rms_setup_nam(defnam);
5513
5514         rms_bind_fab_nam(deffab, defnam);
5515
5516         /* Cast ok */
5517         rms_set_fna
5518             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5519
5520         /* RMS needs the esa/esal as a work area if wildcards are involved */
5521         rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5522
5523         rms_clear_nam_nop(defnam);
5524         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5525 #ifdef NAM$M_NO_SHORT_UPCASE
5526         if (decc_efs_case_preserve)
5527           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5528 #endif
5529 #ifdef NAML$M_OPEN_SPECIAL
5530         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5531           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5532 #endif
5533         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5534           if (trimver) {
5535              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5536           }
5537           if (trimtype) {
5538             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5539           }
5540         }
5541         if (defesal != NULL)
5542             PerlMem_free(defesal);
5543         PerlMem_free(defesa);
5544       }
5545     }
5546     if (trimver) {
5547       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5548         if (*(rms_nam_verl(mynam)) != '\"')
5549           speclen = rms_nam_verl(mynam) - tbuf;
5550       }
5551       else {
5552         if (*(rms_nam_ver(mynam)) != '\"')
5553           speclen = rms_nam_ver(mynam) - tbuf;
5554       }
5555     }
5556     if (trimtype) {
5557       /* If we didn't already trim version, copy down */
5558       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5559         if (speclen > rms_nam_verl(mynam) - tbuf)
5560           memmove
5561            (rms_nam_typel(mynam),
5562             rms_nam_verl(mynam),
5563             speclen - (rms_nam_verl(mynam) - tbuf));
5564           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5565       }
5566       else {
5567         if (speclen > rms_nam_ver(mynam) - tbuf)
5568           memmove
5569            (rms_nam_type(mynam),
5570             rms_nam_ver(mynam),
5571             speclen - (rms_nam_ver(mynam) - tbuf));
5572           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5573       }
5574     }
5575   }
5576
5577    /* Done with these copies of the input files */
5578   /*-------------------------------------------*/
5579   if (vmsfspec != NULL)
5580         PerlMem_free(vmsfspec);
5581   if (tmpfspec != NULL)
5582         PerlMem_free(tmpfspec);
5583
5584   /* If we just had a directory spec on input, $PARSE "helpfully"
5585    * adds an empty name and type for us */
5586 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5587   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5588     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5589         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5590         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5591       speclen = rms_nam_namel(mynam) - tbuf;
5592   }
5593   else
5594 #endif
5595   {
5596     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5597         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5598         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5599       speclen = rms_nam_name(mynam) - tbuf;
5600   }
5601
5602   /* Posix format specifications must have matching quotes */
5603   if (speclen < (VMS_MAXRSS - 1)) {
5604     if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
5605       if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
5606         tbuf[speclen] = '\"';
5607         speclen++;
5608       }
5609     }
5610   }
5611   tbuf[speclen] = '\0';
5612   if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
5613
5614   /* Have we been working with an expanded, but not resultant, spec? */
5615   /* Also, convert back to Unix syntax if necessary. */
5616   {
5617   int rsl;
5618
5619 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5620     if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5621       rsl = rms_nam_rsll(mynam);
5622     } else
5623 #endif
5624     {
5625       rsl = rms_nam_rsl(mynam);
5626     }
5627     if (!rsl) {
5628       if (isunix) {
5629         if (do_tounixspec(tbuf, outbuf ,0 , fs_utf8) == NULL) {
5630           if (out) Safefree(out);
5631           if (esal != NULL)
5632             PerlMem_free(esal);
5633           PerlMem_free(esa);
5634           if (outbufl != NULL)
5635             PerlMem_free(outbufl);
5636           return NULL;
5637         }
5638       }
5639       else strcpy(outbuf, tbuf);
5640     }
5641     else if (isunix) {
5642       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5643       if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5644       if (do_tounixspec(tbuf,tmpfspec,0,fs_utf8) == NULL) {
5645         if (out) Safefree(out);
5646         PerlMem_free(esa);
5647         if (esal != NULL)
5648             PerlMem_free(esal);
5649         PerlMem_free(tmpfspec);
5650         if (outbufl != NULL)
5651             PerlMem_free(outbufl);
5652         return NULL;
5653       }
5654       strcpy(outbuf,tmpfspec);
5655       PerlMem_free(tmpfspec);
5656     }
5657   }
5658   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5659   sts = rms_free_search_context(&myfab); /* Free search context */
5660   PerlMem_free(esa);
5661   if (esal != NULL)
5662      PerlMem_free(esal);
5663   if (outbufl != NULL)
5664      PerlMem_free(outbufl);
5665   return outbuf;
5666 }
5667 /*}}}*/
5668 /* External entry points */
5669 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5670 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5671 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5672 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5673 char *Perl_rmsexpand_utf8
5674   (pTHX_ const char *spec, char *buf, const char *def,
5675    unsigned opt, int * fs_utf8, int * dfs_utf8)
5676 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5677 char *Perl_rmsexpand_utf8_ts
5678   (pTHX_ const char *spec, char *buf, const char *def,
5679    unsigned opt, int * fs_utf8, int * dfs_utf8)
5680 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5681
5682
5683 /*
5684 ** The following routines are provided to make life easier when
5685 ** converting among VMS-style and Unix-style directory specifications.
5686 ** All will take input specifications in either VMS or Unix syntax. On
5687 ** failure, all return NULL.  If successful, the routines listed below
5688 ** return a pointer to a buffer containing the appropriately
5689 ** reformatted spec (and, therefore, subsequent calls to that routine
5690 ** will clobber the result), while the routines of the same names with
5691 ** a _ts suffix appended will return a pointer to a mallocd string
5692 ** containing the appropriately reformatted spec.
5693 ** In all cases, only explicit syntax is altered; no check is made that
5694 ** the resulting string is valid or that the directory in question
5695 ** actually exists.
5696 **
5697 **   fileify_dirspec() - convert a directory spec into the name of the
5698 **     directory file (i.e. what you can stat() to see if it's a dir).
5699 **     The style (VMS or Unix) of the result is the same as the style
5700 **     of the parameter passed in.
5701 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5702 **     what you prepend to a filename to indicate what directory it's in).
5703 **     The style (VMS or Unix) of the result is the same as the style
5704 **     of the parameter passed in.
5705 **   tounixpath() - convert a directory spec into a Unix-style path.
5706 **   tovmspath() - convert a directory spec into a VMS-style path.
5707 **   tounixspec() - convert any file spec into a Unix-style file spec.
5708 **   tovmsspec() - convert any file spec into a VMS-style spec.
5709 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5710 **
5711 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5712 ** Permission is given to distribute this code as part of the Perl
5713 ** standard distribution under the terms of the GNU General Public
5714 ** License or the Perl Artistic License.  Copies of each may be
5715 ** found in the Perl standard distribution.
5716  */
5717
5718 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5719 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
5720 {
5721     static char __fileify_retbuf[VMS_MAXRSS];
5722     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5723     char *retspec, *cp1, *cp2, *lastdir;
5724     char *trndir, *vmsdir;
5725     unsigned short int trnlnm_iter_count;
5726     int sts;
5727     if (utf8_fl != NULL)
5728         *utf8_fl = 0;
5729
5730     if (!dir || !*dir) {
5731       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5732     }
5733     dirlen = strlen(dir);
5734     while (dirlen && dir[dirlen-1] == '/') --dirlen;
5735     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5736       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5737         dir = "/sys$disk";
5738         dirlen = 9;
5739       }
5740       else
5741         dirlen = 1;
5742     }
5743     if (dirlen > (VMS_MAXRSS - 1)) {
5744       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5745       return NULL;
5746     }
5747     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
5748     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5749     if (!strpbrk(dir+1,"/]>:")  &&
5750         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5751       strcpy(trndir,*dir == '/' ? dir + 1: dir);
5752       trnlnm_iter_count = 0;
5753       while (!strpbrk(trndir,"/]>:") && my_trnlnm(trndir,trndir,0)) {
5754         trnlnm_iter_count++;
5755         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5756       }
5757       dirlen = strlen(trndir);
5758     }
5759     else {
5760       strncpy(trndir,dir,dirlen);
5761       trndir[dirlen] = '\0';
5762     }
5763
5764     /* At this point we are done with *dir and use *trndir which is a
5765      * copy that can be modified.  *dir must not be modified.
5766      */
5767
5768     /* If we were handed a rooted logical name or spec, treat it like a
5769      * simple directory, so that
5770      *    $ Define myroot dev:[dir.]
5771      *    ... do_fileify_dirspec("myroot",buf,1) ...
5772      * does something useful.
5773      */
5774     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5775       trndir[--dirlen] = '\0';
5776       trndir[dirlen-1] = ']';
5777     }
5778     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5779       trndir[--dirlen] = '\0';
5780       trndir[dirlen-1] = '>';
5781     }
5782
5783     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5784       /* If we've got an explicit filename, we can just shuffle the string. */
5785       if (*(cp1+1)) hasfilename = 1;
5786       /* Similarly, we can just back up a level if we've got multiple levels
5787          of explicit directories in a VMS spec which ends with directories. */
5788       else {
5789         for (cp2 = cp1; cp2 > trndir; cp2--) {
5790           if (*cp2 == '.') {
5791             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5792 /* fix-me, can not scan EFS file specs backward like this */
5793               *cp2 = *cp1; *cp1 = '\0';
5794               hasfilename = 1;
5795               break;
5796             }
5797           }
5798           if (*cp2 == '[' || *cp2 == '<') break;
5799         }
5800       }
5801     }
5802
5803     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
5804     if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
5805     cp1 = strpbrk(trndir,"]:>");
5806     if (hasfilename || !cp1) { /* Unix-style path or filename */
5807       if (trndir[0] == '.') {
5808         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5809           PerlMem_free(trndir);
5810           PerlMem_free(vmsdir);
5811           return do_fileify_dirspec("[]",buf,ts,NULL);
5812         }
5813         else if (trndir[1] == '.' &&
5814                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5815           PerlMem_free(trndir);
5816           PerlMem_free(vmsdir);
5817           return do_fileify_dirspec("[-]",buf,ts,NULL);
5818         }
5819       }
5820       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
5821         dirlen -= 1;                 /* to last element */
5822         lastdir = strrchr(trndir,'/');
5823       }
5824       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
5825         /* If we have "/." or "/..", VMSify it and let the VMS code
5826          * below expand it, rather than repeating the code to handle
5827          * relative components of a filespec here */
5828         do {
5829           if (*(cp1+2) == '.') cp1++;
5830           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
5831             char * ret_chr;
5832             if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5833                 PerlMem_free(trndir);
5834                 PerlMem_free(vmsdir);
5835                 return NULL;
5836             }
5837             if (strchr(vmsdir,'/') != NULL) {
5838               /* If do_tovmsspec() returned it, it must have VMS syntax
5839                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
5840                * the time to check this here only so we avoid a recursion
5841                * loop; otherwise, gigo.
5842                */
5843               PerlMem_free(trndir);
5844               PerlMem_free(vmsdir);
5845               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
5846               return NULL;
5847             }
5848             if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5849                 PerlMem_free(trndir);
5850                 PerlMem_free(vmsdir);
5851                 return NULL;
5852             }
5853             ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5854             PerlMem_free(trndir);
5855             PerlMem_free(vmsdir);
5856             return ret_chr;
5857           }
5858           cp1++;
5859         } while ((cp1 = strstr(cp1,"/.")) != NULL);
5860         lastdir = strrchr(trndir,'/');
5861       }
5862       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5863         char * ret_chr;
5864         /* Ditto for specs that end in an MFD -- let the VMS code
5865          * figure out whether it's a real device or a rooted logical. */
5866
5867         /* This should not happen any more.  Allowing the fake /000000
5868          * in a UNIX pathname causes all sorts of problems when trying
5869          * to run in UNIX emulation.  So the VMS to UNIX conversions
5870          * now remove the fake /000000 directories.
5871          */
5872
5873         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5874         if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5875             PerlMem_free(trndir);
5876             PerlMem_free(vmsdir);
5877             return NULL;
5878         }
5879         if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5880             PerlMem_free(trndir);
5881             PerlMem_free(vmsdir);
5882             return NULL;
5883         }
5884         ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5885         PerlMem_free(trndir);
5886         PerlMem_free(vmsdir);
5887         return ret_chr;
5888       }
5889       else {
5890
5891         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5892              !(lastdir = cp1 = strrchr(trndir,']')) &&
5893              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5894         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
5895           int ver; char *cp3;
5896
5897           /* For EFS or ODS-5 look for the last dot */
5898           if (decc_efs_charset) {
5899               cp2 = strrchr(cp1,'.');
5900           }
5901           if (vms_process_case_tolerant) {
5902               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5903                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5904                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5905                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5906                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5907                             (ver || *cp3)))))) {
5908                   PerlMem_free(trndir);
5909                   PerlMem_free(vmsdir);
5910                   set_errno(ENOTDIR);
5911                   set_vaxc_errno(RMS$_DIR);
5912                   return NULL;
5913               }
5914           }
5915           else {
5916               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5917                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5918                   !*(cp2+3) || *(cp2+3) != 'R' ||
5919                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5920                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5921                             (ver || *cp3)))))) {
5922                  PerlMem_free(trndir);
5923                  PerlMem_free(vmsdir);
5924                  set_errno(ENOTDIR);
5925                  set_vaxc_errno(RMS$_DIR);
5926                  return NULL;
5927               }
5928           }
5929           dirlen = cp2 - trndir;
5930         }
5931       }
5932
5933       retlen = dirlen + 6;
5934       if (buf) retspec = buf;
5935       else if (ts) Newx(retspec,retlen+1,char);
5936       else retspec = __fileify_retbuf;
5937       memcpy(retspec,trndir,dirlen);
5938       retspec[dirlen] = '\0';
5939
5940       /* We've picked up everything up to the directory file name.
5941          Now just add the type and version, and we're set. */
5942       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5943         strcat(retspec,".dir;1");
5944       else
5945         strcat(retspec,".DIR;1");
5946       PerlMem_free(trndir);
5947       PerlMem_free(vmsdir);
5948       return retspec;
5949     }
5950     else {  /* VMS-style directory spec */
5951
5952       char *esa, *esal, term, *cp;
5953       char *my_esa;
5954       int my_esa_len;
5955       unsigned long int sts, cmplen, haslower = 0;
5956       unsigned int nam_fnb;
5957       char * nam_type;
5958       struct FAB dirfab = cc$rms_fab;
5959       rms_setup_nam(savnam);
5960       rms_setup_nam(dirnam);
5961
5962       esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5963       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5964       esal = NULL;
5965 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5966       esal = PerlMem_malloc(VMS_MAXRSS);
5967       if (esal == NULL) _ckvmssts(SS$_INSFMEM);
5968 #endif
5969       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5970       rms_bind_fab_nam(dirfab, dirnam);
5971       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5972       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
5973 #ifdef NAM$M_NO_SHORT_UPCASE
5974       if (decc_efs_case_preserve)
5975         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5976 #endif
5977
5978       for (cp = trndir; *cp; cp++)
5979         if (islower(*cp)) { haslower = 1; break; }
5980       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5981         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5982           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5983           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5984         }
5985         if (!sts) {
5986           PerlMem_free(esa);
5987           if (esal != NULL)
5988               PerlMem_free(esal);
5989           PerlMem_free(trndir);
5990           PerlMem_free(vmsdir);
5991           set_errno(EVMSERR);
5992           set_vaxc_errno(dirfab.fab$l_sts);
5993           return NULL;
5994         }
5995       }
5996       else {
5997         savnam = dirnam;
5998         /* Does the file really exist? */
5999         if (sys$search(&dirfab)& STS$K_SUCCESS) {
6000           /* Yes; fake the fnb bits so we'll check type below */
6001         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6002         }
6003         else { /* No; just work with potential name */
6004           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6005           else {
6006             int fab_sts;
6007             fab_sts = dirfab.fab$l_sts;
6008             sts = rms_free_search_context(&dirfab);
6009             PerlMem_free(esa);
6010             if (esal != NULL)
6011                 PerlMem_free(esal);
6012             PerlMem_free(trndir);
6013             PerlMem_free(vmsdir);
6014             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
6015             return NULL;
6016           }
6017         }
6018       }
6019
6020       /* Make sure we are using the right buffer */
6021       if (esal != NULL) {
6022         my_esa = esal;
6023         my_esa_len = rms_nam_esll(dirnam);
6024       } else {
6025         my_esa = esa;
6026         my_esa_len = rms_nam_esl(dirnam);
6027       }
6028       my_esa[my_esa_len] = '\0';
6029       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6030         cp1 = strchr(my_esa,']');
6031         if (!cp1) cp1 = strchr(my_esa,'>');
6032         if (cp1) {  /* Should always be true */
6033           my_esa_len -= cp1 - my_esa - 1;
6034           memmove(my_esa, cp1 + 1, my_esa_len);
6035         }
6036       }
6037       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6038         /* Yep; check version while we're at it, if it's there. */
6039         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6040         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6041           /* Something other than .DIR[;1].  Bzzt. */
6042           sts = rms_free_search_context(&dirfab);
6043           PerlMem_free(esa);
6044           if (esal != NULL)
6045              PerlMem_free(esal);
6046           PerlMem_free(trndir);
6047           PerlMem_free(vmsdir);
6048           set_errno(ENOTDIR);
6049           set_vaxc_errno(RMS$_DIR);
6050           return NULL;
6051         }
6052       }
6053
6054       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6055         /* They provided at least the name; we added the type, if necessary, */
6056         if (buf) retspec = buf;                            /* in sys$parse() */
6057         else if (ts) Newx(retspec, my_esa_len + 1, char);
6058         else retspec = __fileify_retbuf;
6059         strcpy(retspec,my_esa);
6060         sts = rms_free_search_context(&dirfab);
6061         PerlMem_free(trndir);
6062         PerlMem_free(esa);
6063         if (esal != NULL)
6064             PerlMem_free(esal);
6065         PerlMem_free(vmsdir);
6066         return retspec;
6067       }
6068       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6069         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6070         *cp1 = '\0';
6071         my_esa_len -= 9;
6072       }
6073       if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6074       if (cp1 == NULL) { /* should never happen */
6075         sts = rms_free_search_context(&dirfab);
6076         PerlMem_free(trndir);
6077         PerlMem_free(esa);
6078         if (esal != NULL)
6079             PerlMem_free(esal);
6080         PerlMem_free(vmsdir);
6081         return NULL;
6082       }
6083       term = *cp1;
6084       *cp1 = '\0';
6085       retlen = strlen(my_esa);
6086       cp1 = strrchr(my_esa,'.');
6087       /* ODS-5 directory specifications can have extra "." in them. */
6088       /* Fix-me, can not scan EFS file specifications backwards */
6089       while (cp1 != NULL) {
6090         if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6091           break;
6092         else {
6093            cp1--;
6094            while ((cp1 > my_esa) && (*cp1 != '.'))
6095              cp1--;
6096         }
6097         if (cp1 == my_esa)
6098           cp1 = NULL;
6099       }
6100
6101       if ((cp1) != NULL) {
6102         /* There's more than one directory in the path.  Just roll back. */
6103         *cp1 = term;
6104         if (buf) retspec = buf;
6105         else if (ts) Newx(retspec,retlen+7,char);
6106         else retspec = __fileify_retbuf;
6107         strcpy(retspec,my_esa);
6108       }
6109       else {
6110         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6111           /* Go back and expand rooted logical name */
6112           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6113 #ifdef NAM$M_NO_SHORT_UPCASE
6114           if (decc_efs_case_preserve)
6115             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6116 #endif
6117           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6118             sts = rms_free_search_context(&dirfab);
6119             PerlMem_free(esa);
6120             if (esal != NULL)
6121                 PerlMem_free(esal);
6122             PerlMem_free(trndir);
6123             PerlMem_free(vmsdir);
6124             set_errno(EVMSERR);
6125             set_vaxc_errno(dirfab.fab$l_sts);
6126             return NULL;
6127           }
6128
6129           /* This changes the length of the string of course */
6130           if (esal != NULL) {
6131               my_esa_len = rms_nam_esll(dirnam);
6132           } else {
6133               my_esa_len = rms_nam_esl(dirnam);
6134           }
6135
6136           retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6137           if (buf) retspec = buf;
6138           else if (ts) Newx(retspec,retlen+16,char);
6139           else retspec = __fileify_retbuf;
6140           cp1 = strstr(my_esa,"][");
6141           if (!cp1) cp1 = strstr(my_esa,"]<");
6142           dirlen = cp1 - my_esa;
6143           memcpy(retspec,my_esa,dirlen);
6144           if (!strncmp(cp1+2,"000000]",7)) {
6145             retspec[dirlen-1] = '\0';
6146             /* fix-me Not full ODS-5, just extra dots in directories for now */
6147             cp1 = retspec + dirlen - 1;
6148             while (cp1 > retspec)
6149             {
6150               if (*cp1 == '[')
6151                 break;
6152               if (*cp1 == '.') {
6153                 if (*(cp1-1) != '^')
6154                   break;
6155               }
6156               cp1--;
6157             }
6158             if (*cp1 == '.') *cp1 = ']';
6159             else {
6160               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6161               memmove(cp1+1,"000000]",7);
6162             }
6163           }
6164           else {
6165             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
6166             retspec[retlen] = '\0';
6167             /* Convert last '.' to ']' */
6168             cp1 = retspec+retlen-1;
6169             while (*cp != '[') {
6170               cp1--;
6171               if (*cp1 == '.') {
6172                 /* Do not trip on extra dots in ODS-5 directories */
6173                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
6174                 break;
6175               }
6176             }
6177             if (*cp1 == '.') *cp1 = ']';
6178             else {
6179               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6180               memmove(cp1+1,"000000]",7);
6181             }
6182           }
6183         }
6184         else {  /* This is a top-level dir.  Add the MFD to the path. */
6185           if (buf) retspec = buf;
6186           else if (ts) Newx(retspec,retlen+16,char);
6187           else retspec = __fileify_retbuf;
6188           cp1 = my_esa;
6189           cp2 = retspec;
6190           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6191           strcpy(cp2,":[000000]");
6192           cp1 += 2;
6193           strcpy(cp2+9,cp1);
6194         }
6195       }
6196       sts = rms_free_search_context(&dirfab);
6197       /* We've set up the string up through the filename.  Add the
6198          type and version, and we're done. */
6199       strcat(retspec,".DIR;1");
6200
6201       /* $PARSE may have upcased filespec, so convert output to lower
6202        * case if input contained any lowercase characters. */
6203       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
6204       PerlMem_free(trndir);
6205       PerlMem_free(esa);
6206       if (esal != NULL)
6207         PerlMem_free(esal);
6208       PerlMem_free(vmsdir);
6209       return retspec;
6210     }
6211 }  /* end of do_fileify_dirspec() */
6212 /*}}}*/
6213 /* External entry points */
6214 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6215 { return do_fileify_dirspec(dir,buf,0,NULL); }
6216 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6217 { return do_fileify_dirspec(dir,buf,1,NULL); }
6218 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6219 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6220 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6221 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6222
6223 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6224 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6225 {
6226     static char __pathify_retbuf[VMS_MAXRSS];
6227     unsigned long int retlen;
6228     char *retpath, *cp1, *cp2, *trndir;
6229     unsigned short int trnlnm_iter_count;
6230     STRLEN trnlen;
6231     int sts;
6232     if (utf8_fl != NULL)
6233         *utf8_fl = 0;
6234
6235     if (!dir || !*dir) {
6236       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6237     }
6238
6239     trndir = PerlMem_malloc(VMS_MAXRSS);
6240     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
6241     if (*dir) strcpy(trndir,dir);
6242     else getcwd(trndir,VMS_MAXRSS - 1);
6243
6244     trnlnm_iter_count = 0;
6245     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6246            && my_trnlnm(trndir,trndir,0)) {
6247       trnlnm_iter_count++;
6248       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6249       trnlen = strlen(trndir);
6250
6251       /* Trap simple rooted lnms, and return lnm:[000000] */
6252       if (!strcmp(trndir+trnlen-2,".]")) {
6253         if (buf) retpath = buf;
6254         else if (ts) Newx(retpath,strlen(dir)+10,char);
6255         else retpath = __pathify_retbuf;
6256         strcpy(retpath,dir);
6257         strcat(retpath,":[000000]");
6258         PerlMem_free(trndir);
6259         return retpath;
6260       }
6261     }
6262
6263     /* At this point we do not work with *dir, but the copy in
6264      * *trndir that is modifiable.
6265      */
6266
6267     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
6268       if (*trndir == '.' && (*(trndir+1) == '\0' ||
6269                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
6270         retlen = 2 + (*(trndir+1) != '\0');
6271       else {
6272         if ( !(cp1 = strrchr(trndir,'/')) &&
6273              !(cp1 = strrchr(trndir,']')) &&
6274              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
6275         if ((cp2 = strchr(cp1,'.')) != NULL &&
6276             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
6277              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
6278               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
6279               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
6280           int ver; char *cp3;
6281
6282           /* For EFS or ODS-5 look for the last dot */
6283           if (decc_efs_charset) {
6284             cp2 = strrchr(cp1,'.');
6285           }
6286           if (vms_process_case_tolerant) {
6287               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
6288                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
6289                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6290                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6291                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6292                             (ver || *cp3)))))) {
6293                 PerlMem_free(trndir);
6294                 set_errno(ENOTDIR);
6295                 set_vaxc_errno(RMS$_DIR);
6296                 return NULL;
6297               }
6298           }
6299           else {
6300               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
6301                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
6302                   !*(cp2+3) || *(cp2+3) != 'R' ||
6303                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6304                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6305                             (ver || *cp3)))))) {
6306                 PerlMem_free(trndir);
6307                 set_errno(ENOTDIR);
6308                 set_vaxc_errno(RMS$_DIR);
6309                 return NULL;
6310               }
6311           }
6312           retlen = cp2 - trndir + 1;
6313         }
6314         else {  /* No file type present.  Treat the filename as a directory. */
6315           retlen = strlen(trndir) + 1;
6316         }
6317       }
6318       if (buf) retpath = buf;
6319       else if (ts) Newx(retpath,retlen+1,char);
6320       else retpath = __pathify_retbuf;
6321       strncpy(retpath, trndir, retlen-1);
6322       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
6323         retpath[retlen-1] = '/';      /* with '/', add it. */
6324         retpath[retlen] = '\0';
6325       }
6326       else retpath[retlen-1] = '\0';
6327     }
6328     else {  /* VMS-style directory spec */
6329       char *esa, *esal, *cp;
6330       char *my_esa;
6331       int my_esa_len;
6332       unsigned long int sts, cmplen, haslower;
6333       struct FAB dirfab = cc$rms_fab;
6334       int dirlen;
6335       rms_setup_nam(savnam);
6336       rms_setup_nam(dirnam);
6337
6338       /* If we've got an explicit filename, we can just shuffle the string. */
6339       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
6340              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
6341         if ((cp2 = strchr(cp1,'.')) != NULL) {
6342           int ver; char *cp3;
6343           if (vms_process_case_tolerant) {
6344               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
6345                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
6346                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6347                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6348                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6349                             (ver || *cp3)))))) {
6350                PerlMem_free(trndir);
6351                set_errno(ENOTDIR);
6352                set_vaxc_errno(RMS$_DIR);
6353                return NULL;
6354              }
6355           }
6356           else {
6357               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
6358                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
6359                   !*(cp2+3) || *(cp2+3) != 'R' ||
6360                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6361                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6362                             (ver || *cp3)))))) {
6363                PerlMem_free(trndir);
6364                set_errno(ENOTDIR);
6365                set_vaxc_errno(RMS$_DIR);
6366                return NULL;
6367              }
6368           }
6369         }
6370         else {  /* No file type, so just draw name into directory part */
6371           for (cp2 = cp1; *cp2; cp2++) ;
6372         }
6373         *cp2 = *cp1;
6374         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
6375         *cp1 = '.';
6376         /* We've now got a VMS 'path'; fall through */
6377       }
6378
6379       dirlen = strlen(trndir);
6380       if (trndir[dirlen-1] == ']' ||
6381           trndir[dirlen-1] == '>' ||
6382           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
6383         if (buf) retpath = buf;
6384         else if (ts) Newx(retpath,strlen(trndir)+1,char);
6385         else retpath = __pathify_retbuf;
6386         strcpy(retpath,trndir);
6387         PerlMem_free(trndir);
6388         return retpath;
6389       }
6390       rms_set_fna(dirfab, dirnam, trndir, dirlen);
6391       esa = PerlMem_malloc(VMS_MAXRSS);
6392       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
6393       esal = NULL;
6394 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6395       esal = PerlMem_malloc(VMS_MAXRSS);
6396       if (esal == NULL) _ckvmssts(SS$_INSFMEM);
6397 #endif
6398       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6399       rms_bind_fab_nam(dirfab, dirnam);
6400       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
6401 #ifdef NAM$M_NO_SHORT_UPCASE
6402       if (decc_efs_case_preserve)
6403           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6404 #endif
6405
6406       for (cp = trndir; *cp; cp++)
6407         if (islower(*cp)) { haslower = 1; break; }
6408
6409       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
6410         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
6411           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6412           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
6413         }
6414         if (!sts) {
6415           PerlMem_free(trndir);
6416           PerlMem_free(esa);
6417           if (esal != NULL)
6418             PerlMem_free(esal);
6419           set_errno(EVMSERR);
6420           set_vaxc_errno(dirfab.fab$l_sts);
6421           return NULL;
6422         }
6423       }
6424       else {
6425         savnam = dirnam;
6426         /* Does the file really exist? */
6427         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
6428           if (dirfab.fab$l_sts != RMS$_FNF) {
6429             int sts1;
6430             sts1 = rms_free_search_context(&dirfab);
6431             PerlMem_free(trndir);
6432             PerlMem_free(esa);
6433             if (esal != NULL)
6434                 PerlMem_free(esal);
6435             set_errno(EVMSERR);
6436             set_vaxc_errno(dirfab.fab$l_sts);
6437             return NULL;
6438           }
6439           dirnam = savnam; /* No; just work with potential name */
6440         }
6441       }
6442       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6443         /* Yep; check version while we're at it, if it's there. */
6444         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6445         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
6446           int sts2;
6447           /* Something other than .DIR[;1].  Bzzt. */
6448           sts2 = rms_free_search_context(&dirfab);
6449           PerlMem_free(trndir);
6450           PerlMem_free(esa);
6451           if (esal != NULL)
6452              PerlMem_free(esal);
6453           set_errno(ENOTDIR);
6454           set_vaxc_errno(RMS$_DIR);
6455           return NULL;
6456         }
6457       }
6458       /* Make sure we are using the right buffer */
6459       if (esal != NULL) {
6460         /* We only need one, clean up the other */
6461         my_esa = esal;
6462         my_esa_len = rms_nam_esll(dirnam);
6463       } else {
6464         my_esa = esa;
6465         my_esa_len = rms_nam_esl(dirnam);
6466       }
6467
6468       /* Null terminate the buffer */
6469       my_esa[my_esa_len] = '\0';
6470
6471       /* OK, the type was fine.  Now pull any file name into the
6472          directory path. */
6473       if ((cp1 = strrchr(my_esa,']'))) *(rms_nam_typel(dirnam)) = ']';
6474       else {
6475         cp1 = strrchr(my_esa,'>');
6476         *(rms_nam_typel(dirnam)) = '>';
6477       }
6478       *cp1 = '.';
6479       *(rms_nam_typel(dirnam) + 1) = '\0';
6480       retlen = (rms_nam_typel(dirnam)) - my_esa + 2;
6481       if (buf) retpath = buf;
6482       else if (ts) Newx(retpath,retlen,char);
6483       else retpath = __pathify_retbuf;
6484       strcpy(retpath,my_esa);
6485       PerlMem_free(esa);
6486       if (esal != NULL)
6487           PerlMem_free(esal);
6488       sts = rms_free_search_context(&dirfab);
6489       /* $PARSE may have upcased filespec, so convert output to lower
6490        * case if input contained any lowercase characters. */
6491       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
6492     }
6493
6494     PerlMem_free(trndir);
6495     return retpath;
6496 }  /* end of do_pathify_dirspec() */
6497 /*}}}*/
6498 /* External entry points */
6499 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6500 { return do_pathify_dirspec(dir,buf,0,NULL); }
6501 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6502 { return do_pathify_dirspec(dir,buf,1,NULL); }
6503 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6504 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6505 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6506 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
6507
6508 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
6509 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
6510 {
6511   static char __tounixspec_retbuf[VMS_MAXRSS];
6512   char *dirend, *rslt, *cp1, *cp3, *tmp;
6513   const char *cp2;
6514   int devlen, dirlen, retlen = VMS_MAXRSS;
6515   int expand = 1; /* guarantee room for leading and trailing slashes */
6516   unsigned short int trnlnm_iter_count;
6517   int cmp_rslt;
6518   if (utf8_fl != NULL)
6519     *utf8_fl = 0;
6520
6521   if (spec == NULL) return NULL;
6522   if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
6523   if (buf) rslt = buf;
6524   else if (ts) {
6525     Newx(rslt, VMS_MAXRSS, char);
6526   }
6527   else rslt = __tounixspec_retbuf;
6528
6529   /* New VMS specific format needs translation
6530    * glob passes filenames with trailing '\n' and expects this preserved.
6531    */
6532   if (decc_posix_compliant_pathnames) {
6533     if (strncmp(spec, "\"^UP^", 5) == 0) {
6534       char * uspec;
6535       char *tunix;
6536       int tunix_len;
6537       int nl_flag;
6538
6539       tunix = PerlMem_malloc(VMS_MAXRSS);
6540       if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
6541       strcpy(tunix, spec);
6542       tunix_len = strlen(tunix);
6543       nl_flag = 0;
6544       if (tunix[tunix_len - 1] == '\n') {
6545         tunix[tunix_len - 1] = '\"';
6546         tunix[tunix_len] = '\0';
6547         tunix_len--;
6548         nl_flag = 1;
6549       }
6550       uspec = decc$translate_vms(tunix);
6551       PerlMem_free(tunix);
6552       if ((int)uspec > 0) {
6553         strcpy(rslt,uspec);
6554         if (nl_flag) {
6555           strcat(rslt,"\n");
6556         }
6557         else {
6558           /* If we can not translate it, makemaker wants as-is */
6559           strcpy(rslt, spec);
6560         }
6561         return rslt;
6562       }
6563     }
6564   }
6565
6566   cmp_rslt = 0; /* Presume VMS */
6567   cp1 = strchr(spec, '/');
6568   if (cp1 == NULL)
6569     cmp_rslt = 0;
6570
6571     /* Look for EFS ^/ */
6572     if (decc_efs_charset) {
6573       while (cp1 != NULL) {
6574         cp2 = cp1 - 1;
6575         if (*cp2 != '^') {
6576           /* Found illegal VMS, assume UNIX */
6577           cmp_rslt = 1;
6578           break;
6579         }
6580       cp1++;
6581       cp1 = strchr(cp1, '/');
6582     }
6583   }
6584
6585   /* Look for "." and ".." */
6586   if (decc_filename_unix_report) {
6587     if (spec[0] == '.') {
6588       if ((spec[1] == '\0') || (spec[1] == '\n')) {
6589         cmp_rslt = 1;
6590       }
6591       else {
6592         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
6593           cmp_rslt = 1;
6594         }
6595       }
6596     }
6597   }
6598   /* This is already UNIX or at least nothing VMS understands */
6599   if (cmp_rslt) {
6600     strcpy(rslt,spec);
6601     return rslt;
6602   }
6603
6604   cp1 = rslt;
6605   cp2 = spec;
6606   dirend = strrchr(spec,']');
6607   if (dirend == NULL) dirend = strrchr(spec,'>');
6608   if (dirend == NULL) dirend = strchr(spec,':');
6609   if (dirend == NULL) {
6610     strcpy(rslt,spec);
6611     return rslt;
6612   }
6613
6614   /* Special case 1 - sys$posix_root = / */
6615 #if __CRTL_VER >= 70000000
6616   if (!decc_disable_posix_root) {
6617     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6618       *cp1 = '/';
6619       cp1++;
6620       cp2 = cp2 + 15;
6621       }
6622   }
6623 #endif
6624
6625   /* Special case 2 - Convert NLA0: to /dev/null */
6626 #if __CRTL_VER < 70000000
6627   cmp_rslt = strncmp(spec,"NLA0:", 5);
6628   if (cmp_rslt != 0)
6629      cmp_rslt = strncmp(spec,"nla0:", 5);
6630 #else
6631   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6632 #endif
6633   if (cmp_rslt == 0) {
6634     strcpy(rslt, "/dev/null");
6635     cp1 = cp1 + 9;
6636     cp2 = cp2 + 5;
6637     if (spec[6] != '\0') {
6638       cp1[9] == '/';
6639       cp1++;
6640       cp2++;
6641     }
6642   }
6643
6644    /* Also handle special case "SYS$SCRATCH:" */
6645 #if __CRTL_VER < 70000000
6646   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
6647   if (cmp_rslt != 0)
6648      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
6649 #else
6650   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6651 #endif
6652   tmp = PerlMem_malloc(VMS_MAXRSS);
6653   if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
6654   if (cmp_rslt == 0) {
6655   int islnm;
6656
6657     islnm = my_trnlnm(tmp, "TMP", 0);
6658     if (!islnm) {
6659       strcpy(rslt, "/tmp");
6660       cp1 = cp1 + 4;
6661       cp2 = cp2 + 12;
6662       if (spec[12] != '\0') {
6663         cp1[4] == '/';
6664         cp1++;
6665         cp2++;
6666       }
6667     }
6668   }
6669
6670   if (*cp2 != '[' && *cp2 != '<') {
6671     *(cp1++) = '/';
6672   }
6673   else {  /* the VMS spec begins with directories */
6674     cp2++;
6675     if (*cp2 == ']' || *cp2 == '>') {
6676       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
6677       PerlMem_free(tmp);
6678       return rslt;
6679     }
6680     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
6681       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
6682         if (ts) Safefree(rslt);
6683         PerlMem_free(tmp);
6684         return NULL;
6685       }
6686       trnlnm_iter_count = 0;
6687       do {
6688         cp3 = tmp;
6689         while (*cp3 != ':' && *cp3) cp3++;
6690         *(cp3++) = '\0';
6691         if (strchr(cp3,']') != NULL) break;
6692         trnlnm_iter_count++;
6693         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
6694       } while (vmstrnenv(tmp,tmp,0,fildev,0));
6695       if (ts && !buf &&
6696           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
6697         retlen = devlen + dirlen;
6698         Renew(rslt,retlen+1+2*expand,char);
6699         cp1 = rslt;
6700       }
6701       cp3 = tmp;
6702       *(cp1++) = '/';
6703       while (*cp3) {
6704         *(cp1++) = *(cp3++);
6705         if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
6706             PerlMem_free(tmp);
6707             return NULL; /* No room */
6708         }
6709       }
6710       *(cp1++) = '/';
6711     }
6712     if ((*cp2 == '^')) {
6713         /* EFS file escape, pass the next character as is */
6714         /* Fix me: HEX encoding for Unicode not implemented */
6715         cp2++;
6716     }
6717     else if ( *cp2 == '.') {
6718       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
6719         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6720         cp2 += 3;
6721       }
6722       else cp2++;
6723     }
6724   }
6725   PerlMem_free(tmp);
6726   for (; cp2 <= dirend; cp2++) {
6727     if ((*cp2 == '^')) {
6728         /* EFS file escape, pass the next character as is */
6729         /* Fix me: HEX encoding for Unicode not implemented */
6730         *(cp1++) = *(++cp2);
6731         /* An escaped dot stays as is -- don't convert to slash */
6732         if (*cp2 == '.') cp2++;
6733     }
6734     if (*cp2 == ':') {
6735       *(cp1++) = '/';
6736       if (*(cp2+1) == '[') cp2++;
6737     }
6738     else if (*cp2 == ']' || *cp2 == '>') {
6739       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6740     }
6741     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
6742       *(cp1++) = '/';
6743       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6744         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6745                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6746         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6747             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6748       }
6749       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6750         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6751         cp2 += 2;
6752       }
6753     }
6754     else if (*cp2 == '-') {
6755       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6756         while (*cp2 == '-') {
6757           cp2++;
6758           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6759         }
6760         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
6761           if (ts) Safefree(rslt);                        /* filespecs like */
6762           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
6763           return NULL;
6764         }
6765       }
6766       else *(cp1++) = *cp2;
6767     }
6768     else *(cp1++) = *cp2;
6769   }
6770   while (*cp2) {
6771     if ((*cp2 == '^') && (*(cp2+1) == '.')) cp2++;  /* '^.' --> '.' */
6772     *(cp1++) = *(cp2++);
6773   }
6774   *cp1 = '\0';
6775
6776   /* This still leaves /000000/ when working with a
6777    * VMS device root or concealed root.
6778    */
6779   {
6780   int ulen;
6781   char * zeros;
6782
6783       ulen = strlen(rslt);
6784
6785       /* Get rid of "000000/ in rooted filespecs */
6786       if (ulen > 7) {
6787         zeros = strstr(rslt, "/000000/");
6788         if (zeros != NULL) {
6789           int mlen;
6790           mlen = ulen - (zeros - rslt) - 7;
6791           memmove(zeros, &zeros[7], mlen);
6792           ulen = ulen - 7;
6793           rslt[ulen] = '\0';
6794         }
6795       }
6796   }
6797
6798   return rslt;
6799
6800 }  /* end of do_tounixspec() */
6801 /*}}}*/
6802 /* External entry points */
6803 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
6804   { return do_tounixspec(spec,buf,0, NULL); }
6805 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
6806   { return do_tounixspec(spec,buf,1, NULL); }
6807 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
6808   { return do_tounixspec(spec,buf,0, utf8_fl); }
6809 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
6810   { return do_tounixspec(spec,buf,1, utf8_fl); }
6811
6812 #if __CRTL_VER >= 70200000 && !defined(__VAX)
6813
6814 /*
6815  This procedure is used to identify if a path is based in either
6816  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
6817  it returns the OpenVMS format directory for it.
6818
6819  It is expecting specifications of only '/' or '/xxxx/'
6820
6821  If a posix root does not exist, or 'xxxx' is not a directory
6822  in the posix root, it returns a failure.
6823
6824  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
6825
6826  It is used only internally by posix_to_vmsspec_hardway().
6827  */
6828
6829 static int posix_root_to_vms
6830   (char *vmspath, int vmspath_len,
6831    const char *unixpath,
6832    const int * utf8_fl)
6833 {
6834 int sts;
6835 struct FAB myfab = cc$rms_fab;
6836 rms_setup_nam(mynam);
6837 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6838 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6839 char * esa, * esal, * rsa, * rsal;
6840 char *vms_delim;
6841 int dir_flag;
6842 int unixlen;
6843
6844     dir_flag = 0;
6845     vmspath[0] = '\0';
6846     unixlen = strlen(unixpath);
6847     if (unixlen == 0) {
6848       return RMS$_FNF;
6849     }
6850
6851 #if __CRTL_VER >= 80200000
6852   /* If not a posix spec already, convert it */
6853   if (decc_posix_compliant_pathnames) {
6854     if (strncmp(unixpath,"\"^UP^",5) != 0) {
6855       sprintf(vmspath,"\"^UP^%s\"",unixpath);
6856     }
6857     else {
6858       /* This is already a VMS specification, no conversion */
6859       unixlen--;
6860       strncpy(vmspath,unixpath, vmspath_len);
6861     }
6862   }
6863   else
6864 #endif
6865   {
6866   int path_len;
6867   int i,j;
6868
6869      /* Check to see if this is under the POSIX root */
6870      if (decc_disable_posix_root) {
6871         return RMS$_FNF;
6872      }
6873
6874      /* Skip leading / */
6875      if (unixpath[0] == '/') {
6876         unixpath++;
6877         unixlen--;
6878      }
6879
6880
6881      strcpy(vmspath,"SYS$POSIX_ROOT:");
6882
6883      /* If this is only the / , or blank, then... */
6884      if (unixpath[0] == '\0') {
6885         /* by definition, this is the answer */
6886         return SS$_NORMAL;
6887      }
6888
6889      /* Need to look up a directory */
6890      vmspath[15] = '[';
6891      vmspath[16] = '\0';
6892
6893      /* Copy and add '^' escape characters as needed */
6894      j = 16;
6895      i = 0;
6896      while (unixpath[i] != 0) {
6897      int k;
6898
6899         j += copy_expand_unix_filename_escape
6900             (&vmspath[j], &unixpath[i], &k, utf8_fl);
6901         i += k;
6902      }
6903
6904      path_len = strlen(vmspath);
6905      if (vmspath[path_len - 1] == '/')
6906         path_len--;
6907      vmspath[path_len] = ']';
6908      path_len++;
6909      vmspath[path_len] = '\0';
6910
6911   }
6912   vmspath[vmspath_len] = 0;
6913   if (unixpath[unixlen - 1] == '/')
6914   dir_flag = 1;
6915   esal = PerlMem_malloc(VMS_MAXRSS);
6916   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6917   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6918   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6919   rsal = PerlMem_malloc(VMS_MAXRSS);
6920   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6921   rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6922   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6923   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
6924   rms_bind_fab_nam(myfab, mynam);
6925   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
6926   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
6927   if (decc_efs_case_preserve)
6928     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6929 #ifdef NAML$M_OPEN_SPECIAL
6930   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6931 #endif
6932
6933   /* Set up the remaining naml fields */
6934   sts = sys$parse(&myfab);
6935
6936   /* It failed! Try again as a UNIX filespec */
6937   if (!(sts & 1)) {
6938     PerlMem_free(esal);
6939     PerlMem_free(esa);
6940     PerlMem_free(rsal);
6941     PerlMem_free(rsa);
6942     return sts;
6943   }
6944
6945    /* get the Device ID and the FID */
6946    sts = sys$search(&myfab);
6947
6948    /* These are no longer needed */
6949    PerlMem_free(esa);
6950    PerlMem_free(rsal);
6951    PerlMem_free(rsa);
6952
6953    /* on any failure, returned the POSIX ^UP^ filespec */
6954    if (!(sts & 1)) {
6955       PerlMem_free(esal);
6956       return sts;
6957    }
6958    specdsc.dsc$a_pointer = vmspath;
6959    specdsc.dsc$w_length = vmspath_len;
6960
6961    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6962    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6963    sts = lib$fid_to_name
6964       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6965
6966   /* on any failure, returned the POSIX ^UP^ filespec */
6967   if (!(sts & 1)) {
6968      /* This can happen if user does not have permission to read directories */
6969      if (strncmp(unixpath,"\"^UP^",5) != 0)
6970        sprintf(vmspath,"\"^UP^%s\"",unixpath);
6971      else
6972        strcpy(vmspath, unixpath);
6973   }
6974   else {
6975     vmspath[specdsc.dsc$w_length] = 0;
6976
6977     /* Are we expecting a directory? */
6978     if (dir_flag != 0) {
6979     int i;
6980     char *eptr;
6981
6982       eptr = NULL;
6983
6984       i = specdsc.dsc$w_length - 1;
6985       while (i > 0) {
6986       int zercnt;
6987         zercnt = 0;
6988         /* Version must be '1' */
6989         if (vmspath[i--] != '1')
6990           break;
6991         /* Version delimiter is one of ".;" */
6992         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6993           break;
6994         i--;
6995         if (vmspath[i--] != 'R')
6996           break;
6997         if (vmspath[i--] != 'I')
6998           break;
6999         if (vmspath[i--] != 'D')
7000           break;
7001         if (vmspath[i--] != '.')
7002           break;
7003         eptr = &vmspath[i+1];
7004         while (i > 0) {
7005           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7006             if (vmspath[i-1] != '^') {
7007               if (zercnt != 6) {
7008                 *eptr = vmspath[i];
7009                 eptr[1] = '\0';
7010                 vmspath[i] = '.';
7011                 break;
7012               }
7013               else {
7014                 /* Get rid of 6 imaginary zero directory filename */
7015                 vmspath[i+1] = '\0';
7016               }
7017             }
7018           }
7019           if (vmspath[i] == '0')
7020             zercnt++;
7021           else
7022             zercnt = 10;
7023           i--;
7024         }
7025         break;
7026       }
7027     }
7028   }
7029   PerlMem_free(esal);
7030   return sts;
7031 }
7032
7033 /* /dev/mumble needs to be handled special.
7034    /dev/null becomes NLA0:, And there is the potential for other stuff
7035    like /dev/tty which may need to be mapped to something.
7036 */
7037
7038 static int
7039 slash_dev_special_to_vms
7040    (const char * unixptr,
7041     char * vmspath,
7042     int vmspath_len)
7043 {
7044 char * nextslash;
7045 int len;
7046 int cmp;
7047 int islnm;
7048
7049     unixptr += 4;
7050     nextslash = strchr(unixptr, '/');
7051     len = strlen(unixptr);
7052     if (nextslash != NULL)
7053         len = nextslash - unixptr;
7054     cmp = strncmp("null", unixptr, 5);
7055     if (cmp == 0) {
7056         if (vmspath_len >= 6) {
7057             strcpy(vmspath, "_NLA0:");
7058             return SS$_NORMAL;
7059         }
7060     }
7061 }
7062
7063
7064 /* The built in routines do not understand perl's special needs, so
7065     doing a manual conversion from UNIX to VMS
7066
7067     If the utf8_fl is not null and points to a non-zero value, then
7068     treat 8 bit characters as UTF-8.
7069
7070     The sequence starting with '$(' and ending with ')' will be passed
7071     through with out interpretation instead of being escaped.
7072
7073   */
7074 static int posix_to_vmsspec_hardway
7075   (char *vmspath, int vmspath_len,
7076    const char *unixpath,
7077    int dir_flag,
7078    int * utf8_fl) {
7079
7080 char *esa;
7081 const char *unixptr;
7082 const char *unixend;
7083 char *vmsptr;
7084 const char *lastslash;
7085 const char *lastdot;
7086 int unixlen;
7087 int vmslen;
7088 int dir_start;
7089 int dir_dot;
7090 int quoted;
7091 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7092 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7093
7094   if (utf8_fl != NULL)
7095     *utf8_fl = 0;
7096
7097   unixptr = unixpath;
7098   dir_dot = 0;
7099
7100   /* Ignore leading "/" characters */
7101   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7102     unixptr++;
7103   }
7104   unixlen = strlen(unixptr);
7105
7106   /* Do nothing with blank paths */
7107   if (unixlen == 0) {
7108     vmspath[0] = '\0';
7109     return SS$_NORMAL;
7110   }
7111
7112   quoted = 0;
7113   /* This could have a "^UP^ on the front */
7114   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7115     quoted = 1;
7116     unixptr+= 5;
7117     unixlen-= 5;
7118   }
7119
7120   lastslash = strrchr(unixptr,'/');
7121   lastdot = strrchr(unixptr,'.');
7122   unixend = strrchr(unixptr,'\"');
7123   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7124     unixend = unixptr + unixlen;
7125   }
7126
7127   /* last dot is last dot or past end of string */
7128   if (lastdot == NULL)
7129     lastdot = unixptr + unixlen;
7130
7131   /* if no directories, set last slash to beginning of string */
7132   if (lastslash == NULL) {
7133     lastslash = unixptr;
7134   }
7135   else {
7136     /* Watch out for trailing "." after last slash, still a directory */
7137     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7138       lastslash = unixptr + unixlen;
7139     }
7140
7141     /* Watch out for traiing ".." after last slash, still a directory */
7142     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7143       lastslash = unixptr + unixlen;
7144     }
7145
7146     /* dots in directories are aways escaped */
7147     if (lastdot < lastslash)
7148       lastdot = unixptr + unixlen;
7149   }
7150
7151   /* if (unixptr < lastslash) then we are in a directory */
7152
7153   dir_start = 0;
7154
7155   vmsptr = vmspath;
7156   vmslen = 0;
7157
7158   /* Start with the UNIX path */
7159   if (*unixptr != '/') {
7160     /* relative paths */
7161
7162     /* If allowing logical names on relative pathnames, then handle here */
7163     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7164         !decc_posix_compliant_pathnames) {
7165     char * nextslash;
7166     int seg_len;
7167     char * trn;
7168     int islnm;
7169
7170         /* Find the next slash */
7171         nextslash = strchr(unixptr,'/');
7172
7173         esa = PerlMem_malloc(vmspath_len);
7174         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7175
7176         trn = PerlMem_malloc(VMS_MAXRSS);
7177         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7178
7179         if (nextslash != NULL) {
7180
7181             seg_len = nextslash - unixptr;
7182             strncpy(esa, unixptr, seg_len);
7183             esa[seg_len] = 0;
7184         }
7185         else {
7186             strcpy(esa, unixptr);
7187             seg_len = strlen(unixptr);
7188         }
7189         /* trnlnm(section) */
7190         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7191
7192         if (islnm) {
7193             /* Now fix up the directory */
7194
7195             /* Split up the path to find the components */
7196             sts = vms_split_path
7197                   (trn,
7198                    &v_spec,
7199                    &v_len,
7200                    &r_spec,
7201                    &r_len,
7202                    &d_spec,
7203                    &d_len,
7204                    &n_spec,
7205                    &n_len,
7206                    &e_spec,
7207                    &e_len,
7208                    &vs_spec,
7209                    &vs_len);
7210
7211             while (sts == 0) {
7212             char * strt;
7213             int cmp;
7214
7215                 /* A logical name must be a directory  or the full
7216                    specification.  It is only a full specification if
7217                    it is the only component */
7218                 if ((unixptr[seg_len] == '\0') ||
7219                     (unixptr[seg_len+1] == '\0')) {
7220
7221                     /* Is a directory being required? */
7222                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7223                         /* Not a logical name */
7224                         break;
7225                     }
7226
7227
7228                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7229                         /* This must be a directory */
7230                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7231                             strcpy(vmsptr, esa);
7232                             vmslen=strlen(vmsptr);
7233                             vmsptr[vmslen] = ':';
7234                             vmslen++;
7235                             vmsptr[vmslen] = '\0';
7236                             return SS$_NORMAL;
7237                         }
7238                     }
7239
7240                 }
7241
7242
7243                 /* must be dev/directory - ignore version */
7244                 if ((n_len + e_len) != 0)
7245                     break;
7246
7247                 /* transfer the volume */
7248                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7249                     strncpy(vmsptr, v_spec, v_len);
7250                     vmsptr += v_len;
7251                     vmsptr[0] = '\0';
7252                     vmslen += v_len;
7253                 }
7254
7255                 /* unroot the rooted directory */
7256                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7257                     r_spec[0] = '[';
7258                     r_spec[r_len - 1] = ']';
7259
7260                     /* This should not be there, but nothing is perfect */
7261                     if (r_len > 9) {
7262                         cmp = strcmp(&r_spec[1], "000000.");
7263                         if (cmp == 0) {
7264                             r_spec += 7;
7265                             r_spec[7] = '[';
7266                             r_len -= 7;
7267                             if (r_len == 2)
7268                                 r_len = 0;
7269                         }
7270                     }
7271                     if (r_len > 0) {
7272                         strncpy(vmsptr, r_spec, r_len);
7273                         vmsptr += r_len;
7274                         vmslen += r_len;
7275                         vmsptr[0] = '\0';
7276                     }
7277                 }
7278                 /* Bring over the directory. */
7279                 if ((d_len > 0) &&
7280                     ((d_len + vmslen) < vmspath_len)) {
7281                     d_spec[0] = '[';
7282                     d_spec[d_len - 1] = ']';
7283                     if (d_len > 9) {
7284                         cmp = strcmp(&d_spec[1], "000000.");
7285                         if (cmp == 0) {
7286                             d_spec += 7;
7287                             d_spec[7] = '[';
7288                             d_len -= 7;
7289                             if (d_len == 2)
7290                                 d_len = 0;
7291                         }
7292                     }
7293
7294                     if (r_len > 0) {
7295                         /* Remove the redundant root */
7296                         if (r_len > 0) {
7297                             /* remove the ][ */
7298                             vmsptr--;
7299                             vmslen--;
7300                             d_spec++;
7301                             d_len--;
7302                         }
7303                         strncpy(vmsptr, d_spec, d_len);
7304                             vmsptr += d_len;
7305                             vmslen += d_len;
7306                             vmsptr[0] = '\0';
7307                     }
7308                 }
7309                 break;
7310             }
7311         }
7312
7313         PerlMem_free(esa);
7314         PerlMem_free(trn);
7315     }
7316
7317     if (lastslash > unixptr) {
7318     int dotdir_seen;
7319
7320       /* skip leading ./ */
7321       dotdir_seen = 0;
7322       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7323         dotdir_seen = 1;
7324         unixptr++;
7325         unixptr++;
7326       }
7327
7328       /* Are we still in a directory? */
7329       if (unixptr <= lastslash) {
7330         *vmsptr++ = '[';
7331         vmslen = 1;
7332         dir_start = 1;
7333
7334         /* if not backing up, then it is relative forward. */
7335         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7336               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7337           *vmsptr++ = '.';
7338           vmslen++;
7339           dir_dot = 1;
7340           }
7341        }
7342        else {
7343          if (dotdir_seen) {
7344            /* Perl wants an empty directory here to tell the difference
7345             * between a DCL commmand and a filename
7346             */
7347           *vmsptr++ = '[';
7348           *vmsptr++ = ']';
7349           vmslen = 2;
7350         }
7351       }
7352     }
7353     else {
7354       /* Handle two special files . and .. */
7355       if (unixptr[0] == '.') {
7356         if (&unixptr[1] == unixend) {
7357           *vmsptr++ = '[';
7358           *vmsptr++ = ']';
7359           vmslen += 2;
7360           *vmsptr++ = '\0';
7361           return SS$_NORMAL;
7362         }
7363         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7364           *vmsptr++ = '[';
7365           *vmsptr++ = '-';
7366           *vmsptr++ = ']';
7367           vmslen += 3;
7368           *vmsptr++ = '\0';
7369           return SS$_NORMAL;
7370         }
7371       }
7372     }
7373   }
7374   else {        /* Absolute PATH handling */
7375   int sts;
7376   char * nextslash;
7377   int seg_len;
7378     /* Need to find out where root is */
7379
7380     /* In theory, this procedure should never get an absolute POSIX pathname
7381      * that can not be found on the POSIX root.
7382      * In practice, that can not be relied on, and things will show up
7383      * here that are a VMS device name or concealed logical name instead.
7384      * So to make things work, this procedure must be tolerant.
7385      */
7386     esa = PerlMem_malloc(vmspath_len);
7387     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7388
7389     sts = SS$_NORMAL;
7390     nextslash = strchr(&unixptr[1],'/');
7391     seg_len = 0;
7392     if (nextslash != NULL) {
7393     int cmp;
7394       seg_len = nextslash - &unixptr[1];
7395       strncpy(vmspath, unixptr, seg_len + 1);
7396       vmspath[seg_len+1] = 0;
7397       cmp = 1;
7398       if (seg_len == 3) {
7399         cmp = strncmp(vmspath, "dev", 4);
7400         if (cmp == 0) {
7401             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7402             if (sts = SS$_NORMAL)
7403                 return SS$_NORMAL;
7404         }
7405       }
7406       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
7407     }
7408
7409     if ($VMS_STATUS_SUCCESS(sts)) {
7410       /* This is verified to be a real path */
7411
7412       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7413       if ($VMS_STATUS_SUCCESS(sts)) {
7414         strcpy(vmspath, esa);
7415         vmslen = strlen(vmspath);
7416         vmsptr = vmspath + vmslen;
7417         unixptr++;
7418         if (unixptr < lastslash) {
7419         char * rptr;
7420           vmsptr--;
7421           *vmsptr++ = '.';
7422           dir_start = 1;
7423           dir_dot = 1;
7424           if (vmslen > 7) {
7425           int cmp;
7426             rptr = vmsptr - 7;
7427             cmp = strcmp(rptr,"000000.");
7428             if (cmp == 0) {
7429               vmslen -= 7;
7430               vmsptr -= 7;
7431               vmsptr[1] = '\0';
7432             } /* removing 6 zeros */
7433           } /* vmslen < 7, no 6 zeros possible */
7434         } /* Not in a directory */
7435       } /* Posix root found */
7436       else {
7437         /* No posix root, fall back to default directory */
7438         strcpy(vmspath, "SYS$DISK:[");
7439         vmsptr = &vmspath[10];
7440         vmslen = 10;
7441         if (unixptr > lastslash) {
7442            *vmsptr = ']';
7443            vmsptr++;
7444            vmslen++;
7445         }
7446         else {
7447            dir_start = 1;
7448         }
7449       }
7450     } /* end of verified real path handling */
7451     else {
7452     int add_6zero;
7453     int islnm;
7454
7455       /* Ok, we have a device or a concealed root that is not in POSIX
7456        * or we have garbage.  Make the best of it.
7457        */
7458
7459       /* Posix to VMS destroyed this, so copy it again */
7460       strncpy(vmspath, &unixptr[1], seg_len);
7461       vmspath[seg_len] = 0;
7462       vmslen = seg_len;
7463       vmsptr = &vmsptr[vmslen];
7464       islnm = 0;
7465
7466       /* Now do we need to add the fake 6 zero directory to it? */
7467       add_6zero = 1;
7468       if ((*lastslash == '/') && (nextslash < lastslash)) {
7469         /* No there is another directory */
7470         add_6zero = 0;
7471       }
7472       else {
7473       int trnend;
7474       int cmp;
7475
7476         /* now we have foo:bar or foo:[000000]bar to decide from */
7477         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
7478
7479         if (!islnm && !decc_posix_compliant_pathnames) {
7480
7481             cmp = strncmp("bin", vmspath, 4);
7482             if (cmp == 0) {
7483                 /* bin => SYS$SYSTEM: */
7484                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7485             }
7486             else {
7487                 /* tmp => SYS$SCRATCH: */
7488                 cmp = strncmp("tmp", vmspath, 4);
7489                 if (cmp == 0) {
7490                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
7491                 }
7492             }
7493         }
7494
7495         trnend = islnm ? islnm - 1 : 0;
7496
7497         /* if this was a logical name, ']' or '>' must be present */
7498         /* if not a logical name, then assume a device and hope. */
7499         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
7500
7501         /* if log name and trailing '.' then rooted - treat as device */
7502         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
7503
7504         /* Fix me, if not a logical name, a device lookup should be
7505          * done to see if the device is file structured.  If the device
7506          * is not file structured, the 6 zeros should not be put on.
7507          *
7508          * As it is, perl is occasionally looking for dev:[000000]tty.
7509          * which looks a little strange.
7510          *
7511          * Not that easy to detect as "/dev" may be file structured with
7512          * special device files.
7513          */
7514
7515         if ((add_6zero == 0) && (*nextslash == '/') &&
7516             (&nextslash[1] == unixend)) {
7517           /* No real directory present */
7518           add_6zero = 1;
7519         }
7520       }
7521
7522       /* Put the device delimiter on */
7523       *vmsptr++ = ':';
7524       vmslen++;
7525       unixptr = nextslash;
7526       unixptr++;
7527
7528       /* Start directory if needed */
7529       if (!islnm || add_6zero) {
7530         *vmsptr++ = '[';
7531         vmslen++;
7532         dir_start = 1;
7533       }
7534
7535       /* add fake 000000] if needed */
7536       if (add_6zero) {
7537         *vmsptr++ = '0';
7538         *vmsptr++ = '0';
7539         *vmsptr++ = '0';
7540         *vmsptr++ = '0';
7541         *vmsptr++ = '0';
7542         *vmsptr++ = '0';
7543         *vmsptr++ = ']';
7544         vmslen += 7;
7545         dir_start = 0;
7546       }
7547
7548     } /* non-POSIX translation */
7549     PerlMem_free(esa);
7550   } /* End of relative/absolute path handling */
7551
7552   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
7553   int dash_flag;
7554   int in_cnt;
7555   int out_cnt;
7556
7557     dash_flag = 0;
7558
7559     if (dir_start != 0) {
7560
7561       /* First characters in a directory are handled special */
7562       while ((*unixptr == '/') ||
7563              ((*unixptr == '.') &&
7564               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
7565                 (&unixptr[1]==unixend)))) {
7566       int loop_flag;
7567
7568         loop_flag = 0;
7569
7570         /* Skip redundant / in specification */
7571         while ((*unixptr == '/') && (dir_start != 0)) {
7572           loop_flag = 1;
7573           unixptr++;
7574           if (unixptr == lastslash)
7575             break;
7576         }
7577         if (unixptr == lastslash)
7578           break;
7579
7580         /* Skip redundant ./ characters */
7581         while ((*unixptr == '.') &&
7582                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
7583           loop_flag = 1;
7584           unixptr++;
7585           if (unixptr == lastslash)
7586             break;
7587           if (*unixptr == '/')
7588             unixptr++;
7589         }
7590         if (unixptr == lastslash)
7591           break;
7592
7593         /* Skip redundant ../ characters */
7594         while ((*unixptr == '.') && (unixptr[1] == '.') &&
7595              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
7596           /* Set the backing up flag */
7597           loop_flag = 1;
7598           dir_dot = 0;
7599           dash_flag = 1;
7600           *vmsptr++ = '-';
7601           vmslen++;
7602           unixptr++; /* first . */
7603           unixptr++; /* second . */
7604           if (unixptr == lastslash)
7605             break;
7606           if (*unixptr == '/') /* The slash */
7607             unixptr++;
7608         }
7609         if (unixptr == lastslash)
7610           break;
7611
7612         /* To do: Perl expects /.../ to be translated to [...] on VMS */
7613         /* Not needed when VMS is pretending to be UNIX. */
7614
7615         /* Is this loop stuck because of too many dots? */
7616         if (loop_flag == 0) {
7617           /* Exit the loop and pass the rest through */
7618           break;
7619         }
7620       }
7621
7622       /* Are we done with directories yet? */
7623       if (unixptr >= lastslash) {
7624
7625         /* Watch out for trailing dots */
7626         if (dir_dot != 0) {
7627             vmslen --;
7628             vmsptr--;
7629         }
7630         *vmsptr++ = ']';
7631         vmslen++;
7632         dash_flag = 0;
7633         dir_start = 0;
7634         if (*unixptr == '/')
7635           unixptr++;
7636       }
7637       else {
7638         /* Have we stopped backing up? */
7639         if (dash_flag) {
7640           *vmsptr++ = '.';
7641           vmslen++;
7642           dash_flag = 0;
7643           /* dir_start continues to be = 1 */
7644         }
7645         if (*unixptr == '-') {
7646           *vmsptr++ = '^';
7647           *vmsptr++ = *unixptr++;
7648           vmslen += 2;
7649           dir_start = 0;
7650
7651           /* Now are we done with directories yet? */
7652           if (unixptr >= lastslash) {
7653
7654             /* Watch out for trailing dots */
7655             if (dir_dot != 0) {
7656               vmslen --;
7657               vmsptr--;
7658             }
7659
7660             *vmsptr++ = ']';
7661             vmslen++;
7662             dash_flag = 0;
7663             dir_start = 0;
7664           }
7665         }
7666       }
7667     }
7668
7669     /* All done? */
7670     if (unixptr >= unixend)
7671       break;
7672
7673     /* Normal characters - More EFS work probably needed */
7674     dir_start = 0;
7675     dir_dot = 0;
7676
7677     switch(*unixptr) {
7678     case '/':
7679         /* remove multiple / */
7680         while (unixptr[1] == '/') {
7681            unixptr++;
7682         }
7683         if (unixptr == lastslash) {
7684           /* Watch out for trailing dots */
7685           if (dir_dot != 0) {
7686             vmslen --;
7687             vmsptr--;
7688           }
7689           *vmsptr++ = ']';
7690         }
7691         else {
7692           dir_start = 1;
7693           *vmsptr++ = '.';
7694           dir_dot = 1;
7695
7696           /* To do: Perl expects /.../ to be translated to [...] on VMS */
7697           /* Not needed when VMS is pretending to be UNIX. */
7698
7699         }
7700         dash_flag = 0;
7701         if (unixptr != unixend)
7702           unixptr++;
7703         vmslen++;
7704         break;
7705     case '.':
7706         if ((unixptr < lastdot) || (unixptr < lastslash) ||
7707             (&unixptr[1] == unixend)) {
7708           *vmsptr++ = '^';
7709           *vmsptr++ = '.';
7710           vmslen += 2;
7711           unixptr++;
7712
7713           /* trailing dot ==> '^..' on VMS */
7714           if (unixptr == unixend) {
7715             *vmsptr++ = '.';
7716             vmslen++;
7717             unixptr++;
7718           }
7719           break;
7720         }
7721
7722         *vmsptr++ = *unixptr++;
7723         vmslen ++;
7724         break;
7725     case '"':
7726         if (quoted && (&unixptr[1] == unixend)) {
7727             unixptr++;
7728             break;
7729         }
7730         in_cnt = copy_expand_unix_filename_escape
7731                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7732         vmsptr += out_cnt;
7733         unixptr += in_cnt;
7734         break;
7735     case '~':
7736     case ';':
7737     case '\\':
7738     case '?':
7739     case ' ':
7740     default:
7741         in_cnt = copy_expand_unix_filename_escape
7742                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7743         vmsptr += out_cnt;
7744         unixptr += in_cnt;
7745         break;
7746     }
7747   }
7748
7749   /* Make sure directory is closed */
7750   if (unixptr == lastslash) {
7751     char *vmsptr2;
7752     vmsptr2 = vmsptr - 1;
7753
7754     if (*vmsptr2 != ']') {
7755       *vmsptr2--;
7756
7757       /* directories do not end in a dot bracket */
7758       if (*vmsptr2 == '.') {
7759         vmsptr2--;
7760
7761         /* ^. is allowed */
7762         if (*vmsptr2 != '^') {
7763           vmsptr--; /* back up over the dot */
7764         }
7765       }
7766       *vmsptr++ = ']';
7767     }
7768   }
7769   else {
7770     char *vmsptr2;
7771     /* Add a trailing dot if a file with no extension */
7772     vmsptr2 = vmsptr - 1;
7773     if ((vmslen > 1) &&
7774         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
7775         (*vmsptr2 != ')') && (*lastdot != '.')) {
7776         *vmsptr++ = '.';
7777         vmslen++;
7778     }
7779   }
7780
7781   *vmsptr = '\0';
7782   return SS$_NORMAL;
7783 }
7784 #endif
7785
7786  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
7787 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
7788 {
7789 char * result;
7790 int utf8_flag;
7791
7792    /* If a UTF8 flag is being passed, honor it */
7793    utf8_flag = 0;
7794    if (utf8_fl != NULL) {
7795      utf8_flag = *utf8_fl;
7796     *utf8_fl = 0;
7797    }
7798
7799    if (utf8_flag) {
7800      /* If there is a possibility of UTF8, then if any UTF8 characters
7801         are present, then they must be converted to VTF-7
7802       */
7803      result = strcpy(rslt, path); /* FIX-ME */
7804    }
7805    else
7806      result = strcpy(rslt, path);
7807
7808    return result;
7809 }
7810
7811
7812 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
7813 static char *mp_do_tovmsspec
7814    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
7815   static char __tovmsspec_retbuf[VMS_MAXRSS];
7816   char *rslt, *dirend;
7817   char *lastdot;
7818   char *vms_delim;
7819   register char *cp1;
7820   const char *cp2;
7821   unsigned long int infront = 0, hasdir = 1;
7822   int rslt_len;
7823   int no_type_seen;
7824   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7825   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7826
7827   if (path == NULL) return NULL;
7828   rslt_len = VMS_MAXRSS-1;
7829   if (buf) rslt = buf;
7830   else if (ts) Newx(rslt, VMS_MAXRSS, char);
7831   else rslt = __tovmsspec_retbuf;
7832
7833   /* '.' and '..' are "[]" and "[-]" for a quick check */
7834   if (path[0] == '.') {
7835     if (path[1] == '\0') {
7836       strcpy(rslt,"[]");
7837       if (utf8_flag != NULL)
7838         *utf8_flag = 0;
7839       return rslt;
7840     }
7841     else {
7842       if (path[1] == '.' && path[2] == '\0') {
7843         strcpy(rslt,"[-]");
7844         if (utf8_flag != NULL)
7845            *utf8_flag = 0;
7846         return rslt;
7847       }
7848     }
7849   }
7850
7851    /* Posix specifications are now a native VMS format */
7852   /*--------------------------------------------------*/
7853 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7854   if (decc_posix_compliant_pathnames) {
7855     if (strncmp(path,"\"^UP^",5) == 0) {
7856       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7857       return rslt;
7858     }
7859   }
7860 #endif
7861
7862   /* This is really the only way to see if this is already in VMS format */
7863   sts = vms_split_path
7864        (path,
7865         &v_spec,
7866         &v_len,
7867         &r_spec,
7868         &r_len,
7869         &d_spec,
7870         &d_len,
7871         &n_spec,
7872         &n_len,
7873         &e_spec,
7874         &e_len,
7875         &vs_spec,
7876         &vs_len);
7877   if (sts == 0) {
7878     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
7879        replacement, because the above parse just took care of most of
7880        what is needed to do vmspath when the specification is already
7881        in VMS format.
7882
7883        And if it is not already, it is easier to do the conversion as
7884        part of this routine than to call this routine and then work on
7885        the result.
7886      */
7887
7888     /* If VMS punctuation was found, it is already VMS format */
7889     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
7890       if (utf8_flag != NULL)
7891         *utf8_flag = 0;
7892       strcpy(rslt, path);
7893       return rslt;
7894     }
7895     /* Now, what to do with trailing "." cases where there is no
7896        extension?  If this is a UNIX specification, and EFS characters
7897        are enabled, then the trailing "." should be converted to a "^.".
7898        But if this was already a VMS specification, then it should be
7899        left alone.
7900
7901        So in the case of ambiguity, leave the specification alone.
7902      */
7903
7904
7905     /* If there is a possibility of UTF8, then if any UTF8 characters
7906         are present, then they must be converted to VTF-7
7907      */
7908     if (utf8_flag != NULL)
7909       *utf8_flag = 0;
7910     strcpy(rslt, path);
7911     return rslt;
7912   }
7913
7914   dirend = strrchr(path,'/');
7915
7916   if (dirend == NULL) {
7917      /* If we get here with no UNIX directory delimiters, then this is
7918         not a complete file specification, either garbage a UNIX glob
7919         specification that can not be converted to a VMS wildcard, or
7920         it a UNIX shell macro.  MakeMaker wants these passed through AS-IS,
7921         so apparently other programs expect this also.
7922
7923         utf8 flag setting needs to be preserved.
7924       */
7925       strcpy(rslt, path);
7926       return rslt;
7927   }
7928
7929 /* If POSIX mode active, handle the conversion */
7930 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7931   if (decc_efs_charset) {
7932     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7933     return rslt;
7934   }
7935 #endif
7936
7937   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
7938     if (!*(dirend+2)) dirend +=2;
7939     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7940     if (decc_efs_charset == 0) {
7941       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7942     }
7943   }
7944
7945   cp1 = rslt;
7946   cp2 = path;
7947   lastdot = strrchr(cp2,'.');
7948   if (*cp2 == '/') {
7949     char *trndev;
7950     int islnm, rooted;
7951     STRLEN trnend;
7952
7953     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7954     if (!*(cp2+1)) {
7955       if (decc_disable_posix_root) {
7956         strcpy(rslt,"sys$disk:[000000]");
7957       }
7958       else {
7959         strcpy(rslt,"sys$posix_root:[000000]");
7960       }
7961       if (utf8_flag != NULL)
7962         *utf8_flag = 0;
7963       return rslt;
7964     }
7965     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7966     *cp1 = '\0';
7967     trndev = PerlMem_malloc(VMS_MAXRSS);
7968     if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7969     islnm =  my_trnlnm(rslt,trndev,0);
7970
7971      /* DECC special handling */
7972     if (!islnm) {
7973       if (strcmp(rslt,"bin") == 0) {
7974         strcpy(rslt,"sys$system");
7975         cp1 = rslt + 10;
7976         *cp1 = 0;
7977         islnm =  my_trnlnm(rslt,trndev,0);
7978       }
7979       else if (strcmp(rslt,"tmp") == 0) {
7980         strcpy(rslt,"sys$scratch");
7981         cp1 = rslt + 11;
7982         *cp1 = 0;
7983         islnm =  my_trnlnm(rslt,trndev,0);
7984       }
7985       else if (!decc_disable_posix_root) {
7986         strcpy(rslt, "sys$posix_root");
7987         cp1 = rslt + 13;
7988         *cp1 = 0;
7989         cp2 = path;
7990         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7991         islnm =  my_trnlnm(rslt,trndev,0);
7992       }
7993       else if (strcmp(rslt,"dev") == 0) {
7994         if (strncmp(cp2,"/null", 5) == 0) {
7995           if ((cp2[5] == 0) || (cp2[5] == '/')) {
7996             strcpy(rslt,"NLA0");
7997             cp1 = rslt + 4;
7998             *cp1 = 0;
7999             cp2 = cp2 + 5;
8000             islnm =  my_trnlnm(rslt,trndev,0);
8001           }
8002         }
8003       }
8004     }
8005
8006     trnend = islnm ? strlen(trndev) - 1 : 0;
8007     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8008     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8009     /* If the first element of the path is a logical name, determine
8010      * whether it has to be translated so we can add more directories. */
8011     if (!islnm || rooted) {
8012       *(cp1++) = ':';
8013       *(cp1++) = '[';
8014       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8015       else cp2++;
8016     }
8017     else {
8018       if (cp2 != dirend) {
8019         strcpy(rslt,trndev);
8020         cp1 = rslt + trnend;
8021         if (*cp2 != 0) {
8022           *(cp1++) = '.';
8023           cp2++;
8024         }
8025       }
8026       else {
8027         if (decc_disable_posix_root) {
8028           *(cp1++) = ':';
8029           hasdir = 0;
8030         }
8031       }
8032     }
8033     PerlMem_free(trndev);
8034   }
8035   else {
8036     *(cp1++) = '[';
8037     if (*cp2 == '.') {
8038       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8039         cp2 += 2;         /* skip over "./" - it's redundant */
8040         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8041       }
8042       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8043         *(cp1++) = '-';                                 /* "../" --> "-" */
8044         cp2 += 3;
8045       }
8046       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8047                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8048         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8049         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8050         cp2 += 4;
8051       }
8052       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8053         /* Escape the extra dots in EFS file specifications */
8054         *(cp1++) = '^';
8055       }
8056       if (cp2 > dirend) cp2 = dirend;
8057     }
8058     else *(cp1++) = '.';
8059   }
8060   for (; cp2 < dirend; cp2++) {
8061     if (*cp2 == '/') {
8062       if (*(cp2-1) == '/') continue;
8063       if (*(cp1-1) != '.') *(cp1++) = '.';
8064       infront = 0;
8065     }
8066     else if (!infront && *cp2 == '.') {
8067       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8068       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8069       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8070         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8071         else if (*(cp1-2) == '[') *(cp1-1) = '-';
8072         else {  /* back up over previous directory name */
8073           cp1--;
8074           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
8075           if (*(cp1-1) == '[') {
8076             memcpy(cp1,"000000.",7);
8077             cp1 += 7;
8078           }
8079         }
8080         cp2 += 2;
8081         if (cp2 == dirend) break;
8082       }
8083       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8084                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8085         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8086         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8087         if (!*(cp2+3)) {
8088           *(cp1++) = '.';  /* Simulate trailing '/' */
8089           cp2 += 2;  /* for loop will incr this to == dirend */
8090         }
8091         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8092       }
8093       else {
8094         if (decc_efs_charset == 0)
8095           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8096         else {
8097           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
8098           *(cp1++) = '.';
8099         }
8100       }
8101     }
8102     else {
8103       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
8104       if (*cp2 == '.') {
8105         if (decc_efs_charset == 0)
8106           *(cp1++) = '_';
8107         else {
8108           *(cp1++) = '^';
8109           *(cp1++) = '.';
8110         }
8111       }
8112       else                  *(cp1++) =  *cp2;
8113       infront = 1;
8114     }
8115   }
8116   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8117   if (hasdir) *(cp1++) = ']';
8118   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
8119   /* fixme for ODS5 */
8120   no_type_seen = 0;
8121   if (cp2 > lastdot)
8122     no_type_seen = 1;
8123   while (*cp2) {
8124     switch(*cp2) {
8125     case '?':
8126         if (decc_efs_charset == 0)
8127           *(cp1++) = '%';
8128         else
8129           *(cp1++) = '?';
8130         cp2++;
8131     case ' ':
8132         *(cp1)++ = '^';
8133         *(cp1)++ = '_';
8134         cp2++;
8135         break;
8136     case '.':
8137         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8138             decc_readdir_dropdotnotype) {
8139           *(cp1)++ = '^';
8140           *(cp1)++ = '.';
8141           cp2++;
8142
8143           /* trailing dot ==> '^..' on VMS */
8144           if (*cp2 == '\0') {
8145             *(cp1++) = '.';
8146             no_type_seen = 0;
8147           }
8148         }
8149         else {
8150           *(cp1++) = *(cp2++);
8151           no_type_seen = 0;
8152         }
8153         break;
8154     case '$':
8155          /* This could be a macro to be passed through */
8156         *(cp1++) = *(cp2++);
8157         if (*cp2 == '(') {
8158         const char * save_cp2;
8159         char * save_cp1;
8160         int is_macro;
8161
8162             /* paranoid check */
8163             save_cp2 = cp2;
8164             save_cp1 = cp1;
8165             is_macro = 0;
8166
8167             /* Test through */
8168             *(cp1++) = *(cp2++);
8169             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8170                 *(cp1++) = *(cp2++);
8171                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8172                     *(cp1++) = *(cp2++);
8173                 }
8174                 if (*cp2 == ')') {
8175                     *(cp1++) = *(cp2++);
8176                     is_macro = 1;
8177                 }
8178             }
8179             if (is_macro == 0) {
8180                 /* Not really a macro - never mind */
8181                 cp2 = save_cp2;
8182                 cp1 = save_cp1;
8183             }
8184         }
8185         break;
8186     case '\"':
8187     case '~':
8188     case '`':
8189     case '!':
8190     case '#':
8191     case '%':
8192     case '^':
8193         /* Don't escape again if following character is
8194          * already something we escape.
8195          */
8196         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8197             *(cp1++) = *(cp2++);
8198             break;
8199         }
8200         /* But otherwise fall through and escape it. */
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     case '<':
8216     case '>':
8217         *(cp1++) = '^';
8218         *(cp1++) = *(cp2++);
8219         break;
8220     case ';':
8221         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8222          * which is wrong.  UNIX notation should be ".dir." unless
8223          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8224          * changing this behavior could break more things at this time.
8225          * efs character set effectively does not allow "." to be a version
8226          * delimiter as a further complication about changing this.
8227          */
8228         if (decc_filename_unix_report != 0) {
8229           *(cp1++) = '^';
8230         }
8231         *(cp1++) = *(cp2++);
8232         break;
8233     default:
8234         *(cp1++) = *(cp2++);
8235     }
8236   }
8237   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8238   char *lcp1;
8239     lcp1 = cp1;
8240     lcp1--;
8241      /* Fix me for "^]", but that requires making sure that you do
8242       * not back up past the start of the filename
8243       */
8244     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8245       *cp1++ = '.';
8246   }
8247   *cp1 = '\0';
8248
8249   if (utf8_flag != NULL)
8250     *utf8_flag = 0;
8251   return rslt;
8252
8253 }  /* end of do_tovmsspec() */
8254 /*}}}*/
8255 /* External entry points */
8256 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8257   { return do_tovmsspec(path,buf,0,NULL); }
8258 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8259   { return do_tovmsspec(path,buf,1,NULL); }
8260 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8261   { return do_tovmsspec(path,buf,0,utf8_fl); }
8262 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8263   { return do_tovmsspec(path,buf,1,utf8_fl); }
8264
8265 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8266 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8267   static char __tovmspath_retbuf[VMS_MAXRSS];
8268   int vmslen;
8269   char *pathified, *vmsified, *cp;
8270
8271   if (path == NULL) return NULL;
8272   pathified = PerlMem_malloc(VMS_MAXRSS);
8273   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8274   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
8275     PerlMem_free(pathified);
8276     return NULL;
8277   }
8278
8279   vmsified = NULL;
8280   if (buf == NULL)
8281      Newx(vmsified, VMS_MAXRSS, char);
8282   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8283     PerlMem_free(pathified);
8284     if (vmsified) Safefree(vmsified);
8285     return NULL;
8286   }
8287   PerlMem_free(pathified);
8288   if (buf) {
8289     return buf;
8290   }
8291   else if (ts) {
8292     vmslen = strlen(vmsified);
8293     Newx(cp,vmslen+1,char);
8294     memcpy(cp,vmsified,vmslen);
8295     cp[vmslen] = '\0';
8296     Safefree(vmsified);
8297     return cp;
8298   }
8299   else {
8300     strcpy(__tovmspath_retbuf,vmsified);
8301     Safefree(vmsified);
8302     return __tovmspath_retbuf;
8303   }
8304
8305 }  /* end of do_tovmspath() */
8306 /*}}}*/
8307 /* External entry points */
8308 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8309   { return do_tovmspath(path,buf,0, NULL); }
8310 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8311   { return do_tovmspath(path,buf,1, NULL); }
8312 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8313   { return do_tovmspath(path,buf,0,utf8_fl); }
8314 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8315   { return do_tovmspath(path,buf,1,utf8_fl); }
8316
8317
8318 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8319 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8320   static char __tounixpath_retbuf[VMS_MAXRSS];
8321   int unixlen;
8322   char *pathified, *unixified, *cp;
8323
8324   if (path == NULL) return NULL;
8325   pathified = PerlMem_malloc(VMS_MAXRSS);
8326   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8327   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
8328     PerlMem_free(pathified);
8329     return NULL;
8330   }
8331
8332   unixified = NULL;
8333   if (buf == NULL) {
8334       Newx(unixified, VMS_MAXRSS, char);
8335   }
8336   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
8337     PerlMem_free(pathified);
8338     if (unixified) Safefree(unixified);
8339     return NULL;
8340   }
8341   PerlMem_free(pathified);
8342   if (buf) {
8343     return buf;
8344   }
8345   else if (ts) {
8346     unixlen = strlen(unixified);
8347     Newx(cp,unixlen+1,char);
8348     memcpy(cp,unixified,unixlen);
8349     cp[unixlen] = '\0';
8350     Safefree(unixified);
8351     return cp;
8352   }
8353   else {
8354     strcpy(__tounixpath_retbuf,unixified);
8355     Safefree(unixified);
8356     return __tounixpath_retbuf;
8357   }
8358
8359 }  /* end of do_tounixpath() */
8360 /*}}}*/
8361 /* External entry points */
8362 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8363   { return do_tounixpath(path,buf,0,NULL); }
8364 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8365   { return do_tounixpath(path,buf,1,NULL); }
8366 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8367   { return do_tounixpath(path,buf,0,utf8_fl); }
8368 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8369   { return do_tounixpath(path,buf,1,utf8_fl); }
8370
8371 /*
8372  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
8373  *
8374  *****************************************************************************
8375  *                                                                           *
8376  *  Copyright (C) 1989-1994, 2007 by                                         *
8377  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
8378  *                                                                           *
8379  *  Permission is hereby granted for the reproduction of this software       *
8380  *  on condition that this copyright notice is included in source            *
8381  *  distributions of the software.  The code may be modified and             *
8382  *  distributed under the same terms as Perl itself.                         *
8383  *                                                                           *
8384  *  27-Aug-1994 Modified for inclusion in perl5                              *
8385  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
8386  *****************************************************************************
8387  */
8388
8389 /*
8390  * getredirection() is intended to aid in porting C programs
8391  * to VMS (Vax-11 C).  The native VMS environment does not support
8392  * '>' and '<' I/O redirection, or command line wild card expansion,
8393  * or a command line pipe mechanism using the '|' AND background
8394  * command execution '&'.  All of these capabilities are provided to any
8395  * C program which calls this procedure as the first thing in the
8396  * main program.
8397  * The piping mechanism will probably work with almost any 'filter' type
8398  * of program.  With suitable modification, it may useful for other
8399  * portability problems as well.
8400  *
8401  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
8402  */
8403 struct list_item
8404     {
8405     struct list_item *next;
8406     char *value;
8407     };
8408
8409 static void add_item(struct list_item **head,
8410                      struct list_item **tail,
8411                      char *value,
8412                      int *count);
8413
8414 static void mp_expand_wild_cards(pTHX_ char *item,
8415                                 struct list_item **head,
8416                                 struct list_item **tail,
8417                                 int *count);
8418
8419 static int background_process(pTHX_ int argc, char **argv);
8420
8421 static void pipe_and_fork(pTHX_ char **cmargv);
8422
8423 /*{{{ void getredirection(int *ac, char ***av)*/
8424 static void
8425 mp_getredirection(pTHX_ int *ac, char ***av)
8426 /*
8427  * Process vms redirection arg's.  Exit if any error is seen.
8428  * If getredirection() processes an argument, it is erased
8429  * from the vector.  getredirection() returns a new argc and argv value.
8430  * In the event that a background command is requested (by a trailing "&"),
8431  * this routine creates a background subprocess, and simply exits the program.
8432  *
8433  * Warning: do not try to simplify the code for vms.  The code
8434  * presupposes that getredirection() is called before any data is
8435  * read from stdin or written to stdout.
8436  *
8437  * Normal usage is as follows:
8438  *
8439  *      main(argc, argv)
8440  *      int             argc;
8441  *      char            *argv[];
8442  *      {
8443  *              getredirection(&argc, &argv);
8444  *      }
8445  */
8446 {
8447     int                 argc = *ac;     /* Argument Count         */
8448     char                **argv = *av;   /* Argument Vector        */
8449     char                *ap;            /* Argument pointer       */
8450     int                 j;              /* argv[] index           */
8451     int                 item_count = 0; /* Count of Items in List */
8452     struct list_item    *list_head = 0; /* First Item in List       */
8453     struct list_item    *list_tail;     /* Last Item in List        */
8454     char                *in = NULL;     /* Input File Name          */
8455     char                *out = NULL;    /* Output File Name         */
8456     char                *outmode = "w"; /* Mode to Open Output File */
8457     char                *err = NULL;    /* Error File Name          */
8458     char                *errmode = "w"; /* Mode to Open Error File  */
8459     int                 cmargc = 0;     /* Piped Command Arg Count  */
8460     char                **cmargv = NULL;/* Piped Command Arg Vector */
8461
8462     /*
8463      * First handle the case where the last thing on the line ends with
8464      * a '&'.  This indicates the desire for the command to be run in a
8465      * subprocess, so we satisfy that desire.
8466      */
8467     ap = argv[argc-1];
8468     if (0 == strcmp("&", ap))
8469        exit(background_process(aTHX_ --argc, argv));
8470     if (*ap && '&' == ap[strlen(ap)-1])
8471         {
8472         ap[strlen(ap)-1] = '\0';
8473        exit(background_process(aTHX_ argc, argv));
8474         }
8475     /*
8476      * Now we handle the general redirection cases that involve '>', '>>',
8477      * '<', and pipes '|'.
8478      */
8479     for (j = 0; j < argc; ++j)
8480         {
8481         if (0 == strcmp("<", argv[j]))
8482             {
8483             if (j+1 >= argc)
8484                 {
8485                 fprintf(stderr,"No input file after < on command line");
8486                 exit(LIB$_WRONUMARG);
8487                 }
8488             in = argv[++j];
8489             continue;
8490             }
8491         if ('<' == *(ap = argv[j]))
8492             {
8493             in = 1 + ap;
8494             continue;
8495             }
8496         if (0 == strcmp(">", ap))
8497             {
8498             if (j+1 >= argc)
8499                 {
8500                 fprintf(stderr,"No output file after > on command line");
8501                 exit(LIB$_WRONUMARG);
8502                 }
8503             out = argv[++j];
8504             continue;
8505             }
8506         if ('>' == *ap)
8507             {
8508             if ('>' == ap[1])
8509                 {
8510                 outmode = "a";
8511                 if ('\0' == ap[2])
8512                     out = argv[++j];
8513                 else
8514                     out = 2 + ap;
8515                 }
8516             else
8517                 out = 1 + ap;
8518             if (j >= argc)
8519                 {
8520                 fprintf(stderr,"No output file after > or >> on command line");
8521                 exit(LIB$_WRONUMARG);
8522                 }
8523             continue;
8524             }
8525         if (('2' == *ap) && ('>' == ap[1]))
8526             {
8527             if ('>' == ap[2])
8528                 {
8529                 errmode = "a";
8530                 if ('\0' == ap[3])
8531                     err = argv[++j];
8532                 else
8533                     err = 3 + ap;
8534                 }
8535             else
8536                 if ('\0' == ap[2])
8537                     err = argv[++j];
8538                 else
8539                     err = 2 + ap;
8540             if (j >= argc)
8541                 {
8542                 fprintf(stderr,"No output file after 2> or 2>> on command line");
8543                 exit(LIB$_WRONUMARG);
8544                 }
8545             continue;
8546             }
8547         if (0 == strcmp("|", argv[j]))
8548             {
8549             if (j+1 >= argc)
8550                 {
8551                 fprintf(stderr,"No command into which to pipe on command line");
8552                 exit(LIB$_WRONUMARG);
8553                 }
8554             cmargc = argc-(j+1);
8555             cmargv = &argv[j+1];
8556             argc = j;
8557             continue;
8558             }
8559         if ('|' == *(ap = argv[j]))
8560             {
8561             ++argv[j];
8562             cmargc = argc-j;
8563             cmargv = &argv[j];
8564             argc = j;
8565             continue;
8566             }
8567         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
8568         }
8569     /*
8570      * Allocate and fill in the new argument vector, Some Unix's terminate
8571      * the list with an extra null pointer.
8572      */
8573     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
8574     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8575     *av = argv;
8576     for (j = 0; j < item_count; ++j, list_head = list_head->next)
8577         argv[j] = list_head->value;
8578     *ac = item_count;
8579     if (cmargv != NULL)
8580         {
8581         if (out != NULL)
8582             {
8583             fprintf(stderr,"'|' and '>' may not both be specified on command line");
8584             exit(LIB$_INVARGORD);
8585             }
8586         pipe_and_fork(aTHX_ cmargv);
8587         }
8588
8589     /* Check for input from a pipe (mailbox) */
8590
8591     if (in == NULL && 1 == isapipe(0))
8592         {
8593         char mbxname[L_tmpnam];
8594         long int bufsize;
8595         long int dvi_item = DVI$_DEVBUFSIZ;
8596         $DESCRIPTOR(mbxnam, "");
8597         $DESCRIPTOR(mbxdevnam, "");
8598
8599         /* Input from a pipe, reopen it in binary mode to disable       */
8600         /* carriage control processing.                                 */
8601
8602         fgetname(stdin, mbxname);
8603         mbxnam.dsc$a_pointer = mbxname;
8604         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
8605         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
8606         mbxdevnam.dsc$a_pointer = mbxname;
8607         mbxdevnam.dsc$w_length = sizeof(mbxname);
8608         dvi_item = DVI$_DEVNAM;
8609         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
8610         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
8611         set_errno(0);
8612         set_vaxc_errno(1);
8613         freopen(mbxname, "rb", stdin);
8614         if (errno != 0)
8615             {
8616             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
8617             exit(vaxc$errno);
8618             }
8619         }
8620     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
8621         {
8622         fprintf(stderr,"Can't open input file %s as stdin",in);
8623         exit(vaxc$errno);
8624         }
8625     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
8626         {
8627         fprintf(stderr,"Can't open output file %s as stdout",out);
8628         exit(vaxc$errno);
8629         }
8630         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
8631
8632     if (err != NULL) {
8633         if (strcmp(err,"&1") == 0) {
8634             dup2(fileno(stdout), fileno(stderr));
8635             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
8636         } else {
8637         FILE *tmperr;
8638         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
8639             {
8640             fprintf(stderr,"Can't open error file %s as stderr",err);
8641             exit(vaxc$errno);
8642             }
8643             fclose(tmperr);
8644            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
8645                 {
8646                 exit(vaxc$errno);
8647                 }
8648             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
8649         }
8650         }
8651 #ifdef ARGPROC_DEBUG
8652     PerlIO_printf(Perl_debug_log, "Arglist:\n");
8653     for (j = 0; j < *ac;  ++j)
8654         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
8655 #endif
8656    /* Clear errors we may have hit expanding wildcards, so they don't
8657       show up in Perl's $! later */
8658    set_errno(0); set_vaxc_errno(1);
8659 }  /* end of getredirection() */
8660 /*}}}*/
8661
8662 static void add_item(struct list_item **head,
8663                      struct list_item **tail,
8664                      char *value,
8665                      int *count)
8666 {
8667     if (*head == 0)
8668         {
8669         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8670         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8671         *tail = *head;
8672         }
8673     else {
8674         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8675         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8676         *tail = (*tail)->next;
8677         }
8678     (*tail)->value = value;
8679     ++(*count);
8680 }
8681
8682 static void mp_expand_wild_cards(pTHX_ char *item,
8683                               struct list_item **head,
8684                               struct list_item **tail,
8685                               int *count)
8686 {
8687 int expcount = 0;
8688 unsigned long int context = 0;
8689 int isunix = 0;
8690 int item_len = 0;
8691 char *had_version;
8692 char *had_device;
8693 int had_directory;
8694 char *devdir,*cp;
8695 char *vmsspec;
8696 $DESCRIPTOR(filespec, "");
8697 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
8698 $DESCRIPTOR(resultspec, "");
8699 unsigned long int lff_flags = 0;
8700 int sts;
8701 int rms_sts;
8702
8703 #ifdef VMS_LONGNAME_SUPPORT
8704     lff_flags = LIB$M_FIL_LONG_NAMES;
8705 #endif
8706
8707     for (cp = item; *cp; cp++) {
8708         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
8709         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
8710     }
8711     if (!*cp || isspace(*cp))
8712         {
8713         add_item(head, tail, item, count);
8714         return;
8715         }
8716     else
8717         {
8718      /* "double quoted" wild card expressions pass as is */
8719      /* From DCL that means using e.g.:                  */
8720      /* perl program """perl.*"""                        */
8721      item_len = strlen(item);
8722      if ( '"' == *item && '"' == item[item_len-1] )
8723        {
8724        item++;
8725        item[item_len-2] = '\0';
8726        add_item(head, tail, item, count);
8727        return;
8728        }
8729      }
8730     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
8731     resultspec.dsc$b_class = DSC$K_CLASS_D;
8732     resultspec.dsc$a_pointer = NULL;
8733     vmsspec = PerlMem_malloc(VMS_MAXRSS);
8734     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8735     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
8736       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
8737     if (!isunix || !filespec.dsc$a_pointer)
8738       filespec.dsc$a_pointer = item;
8739     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
8740     /*
8741      * Only return version specs, if the caller specified a version
8742      */
8743     had_version = strchr(item, ';');
8744     /*
8745      * Only return device and directory specs, if the caller specifed either.
8746      */
8747     had_device = strchr(item, ':');
8748     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
8749
8750     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
8751                                  (&filespec, &resultspec, &context,
8752                                   &defaultspec, 0, &rms_sts, &lff_flags)))
8753         {
8754         char *string;
8755         char *c;
8756
8757         string = PerlMem_malloc(resultspec.dsc$w_length+1);
8758         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8759         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
8760         string[resultspec.dsc$w_length] = '\0';
8761         if (NULL == had_version)
8762             *(strrchr(string, ';')) = '\0';
8763         if ((!had_directory) && (had_device == NULL))
8764             {
8765             if (NULL == (devdir = strrchr(string, ']')))
8766                 devdir = strrchr(string, '>');
8767             strcpy(string, devdir + 1);
8768             }
8769         /*
8770          * Be consistent with what the C RTL has already done to the rest of
8771          * the argv items and lowercase all of these names.
8772          */
8773         if (!decc_efs_case_preserve) {
8774             for (c = string; *c; ++c)
8775             if (isupper(*c))
8776                 *c = tolower(*c);
8777         }
8778         if (isunix) trim_unixpath(string,item,1);
8779         add_item(head, tail, string, count);
8780         ++expcount;
8781     }
8782     PerlMem_free(vmsspec);
8783     if (sts != RMS$_NMF)
8784         {
8785         set_vaxc_errno(sts);
8786         switch (sts)
8787             {
8788             case RMS$_FNF: case RMS$_DNF:
8789                 set_errno(ENOENT); break;
8790             case RMS$_DIR:
8791                 set_errno(ENOTDIR); break;
8792             case RMS$_DEV:
8793                 set_errno(ENODEV); break;
8794             case RMS$_FNM: case RMS$_SYN:
8795                 set_errno(EINVAL); break;
8796             case RMS$_PRV:
8797                 set_errno(EACCES); break;
8798             default:
8799                 _ckvmssts_noperl(sts);
8800             }
8801         }
8802     if (expcount == 0)
8803         add_item(head, tail, item, count);
8804     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
8805     _ckvmssts_noperl(lib$find_file_end(&context));
8806 }
8807
8808 static int child_st[2];/* Event Flag set when child process completes   */
8809
8810 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
8811
8812 static unsigned long int exit_handler(int *status)
8813 {
8814 short iosb[4];
8815
8816     if (0 == child_st[0])
8817         {
8818 #ifdef ARGPROC_DEBUG
8819         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
8820 #endif
8821         fflush(stdout);     /* Have to flush pipe for binary data to    */
8822                             /* terminate properly -- <tp@mccall.com>    */
8823         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
8824         sys$dassgn(child_chan);
8825         fclose(stdout);
8826         sys$synch(0, child_st);
8827         }
8828     return(1);
8829 }
8830
8831 static void sig_child(int chan)
8832 {
8833 #ifdef ARGPROC_DEBUG
8834     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
8835 #endif
8836     if (child_st[0] == 0)
8837         child_st[0] = 1;
8838 }
8839
8840 static struct exit_control_block exit_block =
8841     {
8842     0,
8843     exit_handler,
8844     1,
8845     &exit_block.exit_status,
8846     0
8847     };
8848
8849 static void
8850 pipe_and_fork(pTHX_ char **cmargv)
8851 {
8852     PerlIO *fp;
8853     struct dsc$descriptor_s *vmscmd;
8854     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
8855     int sts, j, l, ismcr, quote, tquote = 0;
8856
8857     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
8858     vms_execfree(vmscmd);
8859
8860     j = l = 0;
8861     p = subcmd;
8862     q = cmargv[0];
8863     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
8864               && toupper(*(q+2)) == 'R' && !*(q+3);
8865
8866     while (q && l < MAX_DCL_LINE_LENGTH) {
8867         if (!*q) {
8868             if (j > 0 && quote) {
8869                 *p++ = '"';
8870                 l++;
8871             }
8872             q = cmargv[++j];
8873             if (q) {
8874                 if (ismcr && j > 1) quote = 1;
8875                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
8876                 *p++ = ' ';
8877                 l++;
8878                 if (quote || tquote) {
8879                     *p++ = '"';
8880                     l++;
8881                 }
8882             }
8883         } else {
8884             if ((quote||tquote) && *q == '"') {
8885                 *p++ = '"';
8886                 l++;
8887             }
8888             *p++ = *q++;
8889             l++;
8890         }
8891     }
8892     *p = '\0';
8893
8894     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
8895     if (fp == Nullfp) {
8896         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
8897     }
8898 }
8899
8900 static int background_process(pTHX_ int argc, char **argv)
8901 {
8902 char command[MAX_DCL_SYMBOL + 1] = "$";
8903 $DESCRIPTOR(value, "");
8904 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
8905 static $DESCRIPTOR(null, "NLA0:");
8906 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
8907 char pidstring[80];
8908 $DESCRIPTOR(pidstr, "");
8909 int pid;
8910 unsigned long int flags = 17, one = 1, retsts;
8911 int len;
8912
8913     strcat(command, argv[0]);
8914     len = strlen(command);
8915     while (--argc && (len < MAX_DCL_SYMBOL))
8916         {
8917         strcat(command, " \"");
8918         strcat(command, *(++argv));
8919         strcat(command, "\"");
8920         len = strlen(command);
8921         }
8922     value.dsc$a_pointer = command;
8923     value.dsc$w_length = strlen(value.dsc$a_pointer);
8924     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
8925     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
8926     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
8927         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8928     }
8929     else {
8930         _ckvmssts_noperl(retsts);
8931     }
8932 #ifdef ARGPROC_DEBUG
8933     PerlIO_printf(Perl_debug_log, "%s\n", command);
8934 #endif
8935     sprintf(pidstring, "%08X", pid);
8936     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8937     pidstr.dsc$a_pointer = pidstring;
8938     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8939     lib$set_symbol(&pidsymbol, &pidstr);
8940     return(SS$_NORMAL);
8941 }
8942 /*}}}*/
8943 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8944
8945
8946 /* OS-specific initialization at image activation (not thread startup) */
8947 /* Older VAXC header files lack these constants */
8948 #ifndef JPI$_RIGHTS_SIZE
8949 #  define JPI$_RIGHTS_SIZE 817
8950 #endif
8951 #ifndef KGB$M_SUBSYSTEM
8952 #  define KGB$M_SUBSYSTEM 0x8
8953 #endif
8954
8955 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8956
8957 /*{{{void vms_image_init(int *, char ***)*/
8958 void
8959 vms_image_init(int *argcp, char ***argvp)
8960 {
8961   char eqv[LNM$C_NAMLENGTH+1] = "";
8962   unsigned int len, tabct = 8, tabidx = 0;
8963   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8964   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8965   unsigned short int dummy, rlen;
8966   struct dsc$descriptor_s **tabvec;
8967 #if defined(PERL_IMPLICIT_CONTEXT)
8968   pTHX = NULL;
8969 #endif
8970   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
8971                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
8972                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8973                                  {          0,                0,    0,      0} };
8974
8975 #ifdef KILL_BY_SIGPRC
8976     Perl_csighandler_init();
8977 #endif
8978
8979   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8980   _ckvmssts_noperl(iosb[0]);
8981   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8982     if (iprv[i]) {           /* Running image installed with privs? */
8983       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
8984       will_taint = TRUE;
8985       break;
8986     }
8987   }
8988   /* Rights identifiers might trigger tainting as well. */
8989   if (!will_taint && (rlen || rsz)) {
8990     while (rlen < rsz) {
8991       /* We didn't get all the identifiers on the first pass.  Allocate a
8992        * buffer much larger than $GETJPI wants (rsz is size in bytes that
8993        * were needed to hold all identifiers at time of last call; we'll
8994        * allocate that many unsigned long ints), and go back and get 'em.
8995        * If it gave us less than it wanted to despite ample buffer space,
8996        * something's broken.  Is your system missing a system identifier?
8997        */
8998       if (rsz <= jpilist[1].buflen) {
8999          /* Perl_croak accvios when used this early in startup. */
9000          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9001                          rsz, (unsigned long) jpilist[1].buflen,
9002                          "Check your rights database for corruption.\n");
9003          exit(SS$_ABORT);
9004       }
9005       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9006       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9007       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9008       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9009       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9010       _ckvmssts_noperl(iosb[0]);
9011     }
9012     mask = jpilist[1].bufadr;
9013     /* Check attribute flags for each identifier (2nd longword); protected
9014      * subsystem identifiers trigger tainting.
9015      */
9016     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9017       if (mask[i] & KGB$M_SUBSYSTEM) {
9018         will_taint = TRUE;
9019         break;
9020       }
9021     }
9022     if (mask != rlst) PerlMem_free(mask);
9023   }
9024
9025   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9026    * logical, some versions of the CRTL will add a phanthom /000000/
9027    * directory.  This needs to be removed.
9028    */
9029   if (decc_filename_unix_report) {
9030   char * zeros;
9031   int ulen;
9032     ulen = strlen(argvp[0][0]);
9033     if (ulen > 7) {
9034       zeros = strstr(argvp[0][0], "/000000/");
9035       if (zeros != NULL) {
9036         int mlen;
9037         mlen = ulen - (zeros - argvp[0][0]) - 7;
9038         memmove(zeros, &zeros[7], mlen);
9039         ulen = ulen - 7;
9040         argvp[0][0][ulen] = '\0';
9041       }
9042     }
9043     /* It also may have a trailing dot that needs to be removed otherwise
9044      * it will be converted to VMS mode incorrectly.
9045      */
9046     ulen--;
9047     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9048       argvp[0][0][ulen] = '\0';
9049   }
9050
9051   /* We need to use this hack to tell Perl it should run with tainting,
9052    * since its tainting flag may be part of the PL_curinterp struct, which
9053    * hasn't been allocated when vms_image_init() is called.
9054    */
9055   if (will_taint) {
9056     char **newargv, **oldargv;
9057     oldargv = *argvp;
9058     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9059     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9060     newargv[0] = oldargv[0];
9061     newargv[1] = PerlMem_malloc(3 * sizeof(char));
9062     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9063     strcpy(newargv[1], "-T");
9064     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9065     (*argcp)++;
9066     newargv[*argcp] = NULL;
9067     /* We orphan the old argv, since we don't know where it's come from,
9068      * so we don't know how to free it.
9069      */
9070     *argvp = newargv;
9071   }
9072   else {  /* Did user explicitly request tainting? */
9073     int i;
9074     char *cp, **av = *argvp;
9075     for (i = 1; i < *argcp; i++) {
9076       if (*av[i] != '-') break;
9077       for (cp = av[i]+1; *cp; cp++) {
9078         if (*cp == 'T') { will_taint = 1; break; }
9079         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9080                   strchr("DFIiMmx",*cp)) break;
9081       }
9082       if (will_taint) break;
9083     }
9084   }
9085
9086   for (tabidx = 0;
9087        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9088        tabidx++) {
9089     if (!tabidx) {
9090       tabvec = (struct dsc$descriptor_s **)
9091             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9092       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9093     }
9094     else if (tabidx >= tabct) {
9095       tabct += 8;
9096       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9097       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9098     }
9099     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9100     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9101     tabvec[tabidx]->dsc$w_length  = 0;
9102     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9103     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
9104     tabvec[tabidx]->dsc$a_pointer = NULL;
9105     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9106   }
9107   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9108
9109   getredirection(argcp,argvp);
9110 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9111   {
9112 # include <reentrancy.h>
9113   decc$set_reentrancy(C$C_MULTITHREAD);
9114   }
9115 #endif
9116   return;
9117 }
9118 /*}}}*/
9119
9120
9121 /* trim_unixpath()
9122  * Trim Unix-style prefix off filespec, so it looks like what a shell
9123  * glob expansion would return (i.e. from specified prefix on, not
9124  * full path).  Note that returned filespec is Unix-style, regardless
9125  * of whether input filespec was VMS-style or Unix-style.
9126  *
9127  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9128  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9129  * vector of options; at present, only bit 0 is used, and if set tells
9130  * trim unixpath to try the current default directory as a prefix when
9131  * presented with a possibly ambiguous ... wildcard.
9132  *
9133  * Returns !=0 on success, with trimmed filespec replacing contents of
9134  * fspec, and 0 on failure, with contents of fpsec unchanged.
9135  */
9136 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9137 int
9138 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9139 {
9140   char *unixified, *unixwild,
9141        *template, *base, *end, *cp1, *cp2;
9142   register int tmplen, reslen = 0, dirs = 0;
9143
9144   unixwild = PerlMem_malloc(VMS_MAXRSS);
9145   if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
9146   if (!wildspec || !fspec) return 0;
9147   template = unixwild;
9148   if (strpbrk(wildspec,"]>:") != NULL) {
9149     if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
9150         PerlMem_free(unixwild);
9151         return 0;
9152     }
9153   }
9154   else {
9155     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
9156     unixwild[VMS_MAXRSS-1] = 0;
9157   }
9158   unixified = PerlMem_malloc(VMS_MAXRSS);
9159   if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
9160   if (strpbrk(fspec,"]>:") != NULL) {
9161     if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
9162         PerlMem_free(unixwild);
9163         PerlMem_free(unixified);
9164         return 0;
9165     }
9166     else base = unixified;
9167     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9168      * check to see that final result fits into (isn't longer than) fspec */
9169     reslen = strlen(fspec);
9170   }
9171   else base = fspec;
9172
9173   /* No prefix or absolute path on wildcard, so nothing to remove */
9174   if (!*template || *template == '/') {
9175     PerlMem_free(unixwild);
9176     if (base == fspec) {
9177         PerlMem_free(unixified);
9178         return 1;
9179     }
9180     tmplen = strlen(unixified);
9181     if (tmplen > reslen) {
9182         PerlMem_free(unixified);
9183         return 0;  /* not enough space */
9184     }
9185     /* Copy unixified resultant, including trailing NUL */
9186     memmove(fspec,unixified,tmplen+1);
9187     PerlMem_free(unixified);
9188     return 1;
9189   }
9190
9191   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
9192   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
9193     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
9194     for (cp1 = end ;cp1 >= base; cp1--)
9195       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9196         { cp1++; break; }
9197     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9198     PerlMem_free(unixified);
9199     PerlMem_free(unixwild);
9200     return 1;
9201   }
9202   else {
9203     char *tpl, *lcres;
9204     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9205     int ells = 1, totells, segdirs, match;
9206     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9207                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9208
9209     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9210     totells = ells;
9211     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9212     tpl = PerlMem_malloc(VMS_MAXRSS);
9213     if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
9214     if (ellipsis == template && opts & 1) {
9215       /* Template begins with an ellipsis.  Since we can't tell how many
9216        * directory names at the front of the resultant to keep for an
9217        * arbitrary starting point, we arbitrarily choose the current
9218        * default directory as a starting point.  If it's there as a prefix,
9219        * clip it off.  If not, fall through and act as if the leading
9220        * ellipsis weren't there (i.e. return shortest possible path that
9221        * could match template).
9222        */
9223       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9224           PerlMem_free(tpl);
9225           PerlMem_free(unixified);
9226           PerlMem_free(unixwild);
9227           return 0;
9228       }
9229       if (!decc_efs_case_preserve) {
9230         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9231           if (_tolower(*cp1) != _tolower(*cp2)) break;
9232       }
9233       segdirs = dirs - totells;  /* Min # of dirs we must have left */
9234       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9235       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9236         memmove(fspec,cp2+1,end - cp2);
9237         PerlMem_free(tpl);
9238         PerlMem_free(unixified);
9239         PerlMem_free(unixwild);
9240         return 1;
9241       }
9242     }
9243     /* First off, back up over constant elements at end of path */
9244     if (dirs) {
9245       for (front = end ; front >= base; front--)
9246          if (*front == '/' && !dirs--) { front++; break; }
9247     }
9248     lcres = PerlMem_malloc(VMS_MAXRSS);
9249     if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
9250     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9251          cp1++,cp2++) {
9252             if (!decc_efs_case_preserve) {
9253                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
9254             }
9255             else {
9256                 *cp2 = *cp1;
9257             }
9258     }
9259     if (cp1 != '\0') {
9260         PerlMem_free(tpl);
9261         PerlMem_free(unixified);
9262         PerlMem_free(unixwild);
9263         PerlMem_free(lcres);
9264         return 0;  /* Path too long. */
9265     }
9266     lcend = cp2;
9267     *cp2 = '\0';  /* Pick up with memcpy later */
9268     lcfront = lcres + (front - base);
9269     /* Now skip over each ellipsis and try to match the path in front of it. */
9270     while (ells--) {
9271       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
9272         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
9273             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
9274       if (cp1 < template) break; /* template started with an ellipsis */
9275       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9276         ellipsis = cp1; continue;
9277       }
9278       wilddsc.dsc$a_pointer = tpl;
9279       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9280       nextell = cp1;
9281       for (segdirs = 0, cp2 = tpl;
9282            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9283            cp1++, cp2++) {
9284          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9285          else {
9286             if (!decc_efs_case_preserve) {
9287               *cp2 = _tolower(*cp1);  /* else lowercase for match */
9288             }
9289             else {
9290               *cp2 = *cp1;  /* else preserve case for match */
9291             }
9292          }
9293          if (*cp2 == '/') segdirs++;
9294       }
9295       if (cp1 != ellipsis - 1) {
9296           PerlMem_free(tpl);
9297           PerlMem_free(unixified);
9298           PerlMem_free(unixwild);
9299           PerlMem_free(lcres);
9300           return 0; /* Path too long */
9301       }
9302       /* Back up at least as many dirs as in template before matching */
9303       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9304         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9305       for (match = 0; cp1 > lcres;) {
9306         resdsc.dsc$a_pointer = cp1;
9307         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9308           match++;
9309           if (match == 1) lcfront = cp1;
9310         }
9311         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9312       }
9313       if (!match) {
9314         PerlMem_free(tpl);
9315         PerlMem_free(unixified);
9316         PerlMem_free(unixwild);
9317         PerlMem_free(lcres);
9318         return 0;  /* Can't find prefix ??? */
9319       }
9320       if (match > 1 && opts & 1) {
9321         /* This ... wildcard could cover more than one set of dirs (i.e.
9322          * a set of similar dir names is repeated).  If the template
9323          * contains more than 1 ..., upstream elements could resolve the
9324          * ambiguity, but it's not worth a full backtracking setup here.
9325          * As a quick heuristic, clip off the current default directory
9326          * if it's present to find the trimmed spec, else use the
9327          * shortest string that this ... could cover.
9328          */
9329         char def[NAM$C_MAXRSS+1], *st;
9330
9331         if (getcwd(def, sizeof def,0) == NULL) {
9332             Safefree(unixified);
9333             Safefree(unixwild);
9334             Safefree(lcres);
9335             Safefree(tpl);
9336             return 0;
9337         }
9338         if (!decc_efs_case_preserve) {
9339           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9340             if (_tolower(*cp1) != _tolower(*cp2)) break;
9341         }
9342         segdirs = dirs - totells;  /* Min # of dirs we must have left */
9343         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9344         if (*cp1 == '\0' && *cp2 == '/') {
9345           memmove(fspec,cp2+1,end - cp2);
9346           PerlMem_free(tpl);
9347           PerlMem_free(unixified);
9348           PerlMem_free(unixwild);
9349           PerlMem_free(lcres);
9350           return 1;
9351         }
9352         /* Nope -- stick with lcfront from above and keep going. */
9353       }
9354     }
9355     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
9356     PerlMem_free(tpl);
9357     PerlMem_free(unixified);
9358     PerlMem_free(unixwild);
9359     PerlMem_free(lcres);
9360     return 1;
9361     ellipsis = nextell;
9362   }
9363
9364 }  /* end of trim_unixpath() */
9365 /*}}}*/
9366
9367
9368 /*
9369  *  VMS readdir() routines.
9370  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
9371  *
9372  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
9373  *  Minor modifications to original routines.
9374  */
9375
9376 /* readdir may have been redefined by reentr.h, so make sure we get
9377  * the local version for what we do here.
9378  */
9379 #ifdef readdir
9380 # undef readdir
9381 #endif
9382 #if !defined(PERL_IMPLICIT_CONTEXT)
9383 # define readdir Perl_readdir
9384 #else
9385 # define readdir(a) Perl_readdir(aTHX_ a)
9386 #endif
9387
9388     /* Number of elements in vms_versions array */
9389 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
9390
9391 /*
9392  *  Open a directory, return a handle for later use.
9393  */
9394 /*{{{ DIR *opendir(char*name) */
9395 DIR *
9396 Perl_opendir(pTHX_ const char *name)
9397 {
9398     DIR *dd;
9399     char *dir;
9400     Stat_t sb;
9401
9402     Newx(dir, VMS_MAXRSS, char);
9403     if (do_tovmspath(name,dir,0,NULL) == NULL) {
9404       Safefree(dir);
9405       return NULL;
9406     }
9407     /* Check access before stat; otherwise stat does not
9408      * accurately report whether it's a directory.
9409      */
9410     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
9411       /* cando_by_name has already set errno */
9412       Safefree(dir);
9413       return NULL;
9414     }
9415     if (flex_stat(dir,&sb) == -1) return NULL;
9416     if (!S_ISDIR(sb.st_mode)) {
9417       Safefree(dir);
9418       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
9419       return NULL;
9420     }
9421     /* Get memory for the handle, and the pattern. */
9422     Newx(dd,1,DIR);
9423     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
9424
9425     /* Fill in the fields; mainly playing with the descriptor. */
9426     sprintf(dd->pattern, "%s*.*",dir);
9427     Safefree(dir);
9428     dd->context = 0;
9429     dd->count = 0;
9430     dd->flags = 0;
9431     /* By saying we always want the result of readdir() in unix format, we
9432      * are really saying we want all the escapes removed.  Otherwise the caller,
9433      * having no way to know whether it's already in VMS format, might send it
9434      * through tovmsspec again, thus double escaping.
9435      */
9436     dd->flags = PERL_VMSDIR_M_UNIXSPECS;
9437     dd->pat.dsc$a_pointer = dd->pattern;
9438     dd->pat.dsc$w_length = strlen(dd->pattern);
9439     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
9440     dd->pat.dsc$b_class = DSC$K_CLASS_S;
9441 #if defined(USE_ITHREADS)
9442     Newx(dd->mutex,1,perl_mutex);
9443     MUTEX_INIT( (perl_mutex *) dd->mutex );
9444 #else
9445     dd->mutex = NULL;
9446 #endif
9447
9448     return dd;
9449 }  /* end of opendir() */
9450 /*}}}*/
9451
9452 /*
9453  *  Set the flag to indicate we want versions or not.
9454  */
9455 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
9456 void
9457 vmsreaddirversions(DIR *dd, int flag)
9458 {
9459     if (flag)
9460         dd->flags |= PERL_VMSDIR_M_VERSIONS;
9461     else
9462         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9463 }
9464 /*}}}*/
9465
9466 /*
9467  *  Free up an opened directory.
9468  */
9469 /*{{{ void closedir(DIR *dd)*/
9470 void
9471 Perl_closedir(DIR *dd)
9472 {
9473     int sts;
9474
9475     sts = lib$find_file_end(&dd->context);
9476     Safefree(dd->pattern);
9477 #if defined(USE_ITHREADS)
9478     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
9479     Safefree(dd->mutex);
9480 #endif
9481     Safefree(dd);
9482 }
9483 /*}}}*/
9484
9485 /*
9486  *  Collect all the version numbers for the current file.
9487  */
9488 static void
9489 collectversions(pTHX_ DIR *dd)
9490 {
9491     struct dsc$descriptor_s     pat;
9492     struct dsc$descriptor_s     res;
9493     struct dirent *e;
9494     char *p, *text, *buff;
9495     int i;
9496     unsigned long context, tmpsts;
9497
9498     /* Convenient shorthand. */
9499     e = &dd->entry;
9500
9501     /* Add the version wildcard, ignoring the "*.*" put on before */
9502     i = strlen(dd->pattern);
9503     Newx(text,i + e->d_namlen + 3,char);
9504     strcpy(text, dd->pattern);
9505     sprintf(&text[i - 3], "%s;*", e->d_name);
9506
9507     /* Set up the pattern descriptor. */
9508     pat.dsc$a_pointer = text;
9509     pat.dsc$w_length = i + e->d_namlen - 1;
9510     pat.dsc$b_dtype = DSC$K_DTYPE_T;
9511     pat.dsc$b_class = DSC$K_CLASS_S;
9512
9513     /* Set up result descriptor. */
9514     Newx(buff, VMS_MAXRSS, char);
9515     res.dsc$a_pointer = buff;
9516     res.dsc$w_length = VMS_MAXRSS - 1;
9517     res.dsc$b_dtype = DSC$K_DTYPE_T;
9518     res.dsc$b_class = DSC$K_CLASS_S;
9519
9520     /* Read files, collecting versions. */
9521     for (context = 0, e->vms_verscount = 0;
9522          e->vms_verscount < VERSIZE(e);
9523          e->vms_verscount++) {
9524         unsigned long rsts;
9525         unsigned long flags = 0;
9526
9527 #ifdef VMS_LONGNAME_SUPPORT
9528         flags = LIB$M_FIL_LONG_NAMES;
9529 #endif
9530         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
9531         if (tmpsts == RMS$_NMF || context == 0) break;
9532         _ckvmssts(tmpsts);
9533         buff[VMS_MAXRSS - 1] = '\0';
9534         if ((p = strchr(buff, ';')))
9535             e->vms_versions[e->vms_verscount] = atoi(p + 1);
9536         else
9537             e->vms_versions[e->vms_verscount] = -1;
9538     }
9539
9540     _ckvmssts(lib$find_file_end(&context));
9541     Safefree(text);
9542     Safefree(buff);
9543
9544 }  /* end of collectversions() */
9545
9546 /*
9547  *  Read the next entry from the directory.
9548  */
9549 /*{{{ struct dirent *readdir(DIR *dd)*/
9550 struct dirent *
9551 Perl_readdir(pTHX_ DIR *dd)
9552 {
9553     struct dsc$descriptor_s     res;
9554     char *p, *buff;
9555     unsigned long int tmpsts;
9556     unsigned long rsts;
9557     unsigned long flags = 0;
9558     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
9559     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
9560
9561     /* Set up result descriptor, and get next file. */
9562     Newx(buff, VMS_MAXRSS, char);
9563     res.dsc$a_pointer = buff;
9564     res.dsc$w_length = VMS_MAXRSS - 1;
9565     res.dsc$b_dtype = DSC$K_DTYPE_T;
9566     res.dsc$b_class = DSC$K_CLASS_S;
9567
9568 #ifdef VMS_LONGNAME_SUPPORT
9569     flags = LIB$M_FIL_LONG_NAMES;
9570 #endif
9571
9572     tmpsts = lib$find_file
9573         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
9574     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
9575     if (!(tmpsts & 1)) {
9576       set_vaxc_errno(tmpsts);
9577       switch (tmpsts) {
9578         case RMS$_PRV:
9579           set_errno(EACCES); break;
9580         case RMS$_DEV:
9581           set_errno(ENODEV); break;
9582         case RMS$_DIR:
9583           set_errno(ENOTDIR); break;
9584         case RMS$_FNF: case RMS$_DNF:
9585           set_errno(ENOENT); break;
9586         default:
9587           set_errno(EVMSERR);
9588       }
9589       Safefree(buff);
9590       return NULL;
9591     }
9592     dd->count++;
9593     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
9594     if (!decc_efs_case_preserve) {
9595       buff[VMS_MAXRSS - 1] = '\0';
9596       for (p = buff; *p; p++) *p = _tolower(*p);
9597     }
9598     else {
9599       /* we don't want to force to lowercase, just null terminate */
9600       buff[res.dsc$w_length] = '\0';
9601     }
9602     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
9603     *p = '\0';
9604
9605     /* Skip any directory component and just copy the name. */
9606     sts = vms_split_path
9607        (buff,
9608         &v_spec,
9609         &v_len,
9610         &r_spec,
9611         &r_len,
9612         &d_spec,
9613         &d_len,
9614         &n_spec,
9615         &n_len,
9616         &e_spec,
9617         &e_len,
9618         &vs_spec,
9619         &vs_len);
9620
9621     /* Drop NULL extensions on UNIX file specification */
9622     if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
9623         (e_len == 1) && decc_readdir_dropdotnotype)) {
9624         e_len = 0;
9625         e_spec[0] = '\0';
9626     }
9627
9628     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
9629     dd->entry.d_name[n_len + e_len] = '\0';
9630     dd->entry.d_namlen = strlen(dd->entry.d_name);
9631
9632     /* Convert the filename to UNIX format if needed */
9633     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
9634
9635         /* Translate the encoded characters. */
9636         /* Fixme: Unicode handling could result in embedded 0 characters */
9637         if (strchr(dd->entry.d_name, '^') != NULL) {
9638             char new_name[256];
9639             char * q;
9640             p = dd->entry.d_name;
9641             q = new_name;
9642             while (*p != 0) {
9643                 int inchars_read, outchars_added;
9644                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
9645                 p += inchars_read;
9646                 q += outchars_added;
9647                 /* fix-me */
9648                 /* if outchars_added > 1, then this is a wide file specification */
9649                 /* Wide file specifications need to be passed in Perl */
9650                 /* counted strings apparently with a Unicode flag */
9651             }
9652             *q = 0;
9653             strcpy(dd->entry.d_name, new_name);
9654             dd->entry.d_namlen = strlen(dd->entry.d_name);
9655         }
9656     }
9657
9658     dd->entry.vms_verscount = 0;
9659     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
9660     Safefree(buff);
9661     return &dd->entry;
9662
9663 }  /* end of readdir() */
9664 /*}}}*/
9665
9666 /*
9667  *  Read the next entry from the directory -- thread-safe version.
9668  */
9669 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
9670 int
9671 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
9672 {
9673     int retval;
9674
9675     MUTEX_LOCK( (perl_mutex *) dd->mutex );
9676
9677     entry = readdir(dd);
9678     *result = entry;
9679     retval = ( *result == NULL ? errno : 0 );
9680
9681     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
9682
9683     return retval;
9684
9685 }  /* end of readdir_r() */
9686 /*}}}*/
9687
9688 /*
9689  *  Return something that can be used in a seekdir later.
9690  */
9691 /*{{{ long telldir(DIR *dd)*/
9692 long
9693 Perl_telldir(DIR *dd)
9694 {
9695     return dd->count;
9696 }
9697 /*}}}*/
9698
9699 /*
9700  *  Return to a spot where we used to be.  Brute force.
9701  */
9702 /*{{{ void seekdir(DIR *dd,long count)*/
9703 void
9704 Perl_seekdir(pTHX_ DIR *dd, long count)
9705 {
9706     int old_flags;
9707
9708     /* If we haven't done anything yet... */
9709     if (dd->count == 0)
9710         return;
9711
9712     /* Remember some state, and clear it. */
9713     old_flags = dd->flags;
9714     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9715     _ckvmssts(lib$find_file_end(&dd->context));
9716     dd->context = 0;
9717
9718     /* The increment is in readdir(). */
9719     for (dd->count = 0; dd->count < count; )
9720         readdir(dd);
9721
9722     dd->flags = old_flags;
9723
9724 }  /* end of seekdir() */
9725 /*}}}*/
9726
9727 /* VMS subprocess management
9728  *
9729  * my_vfork() - just a vfork(), after setting a flag to record that
9730  * the current script is trying a Unix-style fork/exec.
9731  *
9732  * vms_do_aexec() and vms_do_exec() are called in response to the
9733  * perl 'exec' function.  If this follows a vfork call, then they
9734  * call out the regular perl routines in doio.c which do an
9735  * execvp (for those who really want to try this under VMS).
9736  * Otherwise, they do exactly what the perl docs say exec should
9737  * do - terminate the current script and invoke a new command
9738  * (See below for notes on command syntax.)
9739  *
9740  * do_aspawn() and do_spawn() implement the VMS side of the perl
9741  * 'system' function.
9742  *
9743  * Note on command arguments to perl 'exec' and 'system': When handled
9744  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
9745  * are concatenated to form a DCL command string.  If the first non-numeric
9746  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
9747  * the command string is handed off to DCL directly.  Otherwise,
9748  * the first token of the command is taken as the filespec of an image
9749  * to run.  The filespec is expanded using a default type of '.EXE' and
9750  * the process defaults for device, directory, etc., and if found, the resultant
9751  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
9752  * the command string as parameters.  This is perhaps a bit complicated,
9753  * but I hope it will form a happy medium between what VMS folks expect
9754  * from lib$spawn and what Unix folks expect from exec.
9755  */
9756
9757 static int vfork_called;
9758
9759 /*{{{int my_vfork()*/
9760 int
9761 my_vfork()
9762 {
9763   vfork_called++;
9764   return vfork();
9765 }
9766 /*}}}*/
9767
9768
9769 static void
9770 vms_execfree(struct dsc$descriptor_s *vmscmd)
9771 {
9772   if (vmscmd) {
9773       if (vmscmd->dsc$a_pointer) {
9774           PerlMem_free(vmscmd->dsc$a_pointer);
9775       }
9776       PerlMem_free(vmscmd);
9777   }
9778 }
9779
9780 static char *
9781 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
9782 {
9783   char *junk, *tmps = Nullch;
9784   register size_t cmdlen = 0;
9785   size_t rlen;
9786   register SV **idx;
9787   STRLEN n_a;
9788
9789   idx = mark;
9790   if (really) {
9791     tmps = SvPV(really,rlen);
9792     if (*tmps) {
9793       cmdlen += rlen + 1;
9794       idx++;
9795     }
9796   }
9797
9798   for (idx++; idx <= sp; idx++) {
9799     if (*idx) {
9800       junk = SvPVx(*idx,rlen);
9801       cmdlen += rlen ? rlen + 1 : 0;
9802     }
9803   }
9804   Newx(PL_Cmd, cmdlen+1, char);
9805
9806   if (tmps && *tmps) {
9807     strcpy(PL_Cmd,tmps);
9808     mark++;
9809   }
9810   else *PL_Cmd = '\0';
9811   while (++mark <= sp) {
9812     if (*mark) {
9813       char *s = SvPVx(*mark,n_a);
9814       if (!*s) continue;
9815       if (*PL_Cmd) strcat(PL_Cmd," ");
9816       strcat(PL_Cmd,s);
9817     }
9818   }
9819   return PL_Cmd;
9820
9821 }  /* end of setup_argstr() */
9822
9823
9824 static unsigned long int
9825 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
9826                    struct dsc$descriptor_s **pvmscmd)
9827 {
9828   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
9829   char image_name[NAM$C_MAXRSS+1];
9830   char image_argv[NAM$C_MAXRSS+1];
9831   $DESCRIPTOR(defdsc,".EXE");
9832   $DESCRIPTOR(defdsc2,".");
9833   $DESCRIPTOR(resdsc,resspec);
9834   struct dsc$descriptor_s *vmscmd;
9835   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9836   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
9837   register char *s, *rest, *cp, *wordbreak;
9838   char * cmd;
9839   int cmdlen;
9840   register int isdcl;
9841
9842   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9843   if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
9844
9845   /* Make a copy for modification */
9846   cmdlen = strlen(incmd);
9847   cmd = PerlMem_malloc(cmdlen+1);
9848   if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
9849   strncpy(cmd, incmd, cmdlen);
9850   cmd[cmdlen] = 0;
9851   image_name[0] = 0;
9852   image_argv[0] = 0;
9853
9854   vmscmd->dsc$a_pointer = NULL;
9855   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
9856   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
9857   vmscmd->dsc$w_length = 0;
9858   if (pvmscmd) *pvmscmd = vmscmd;
9859
9860   if (suggest_quote) *suggest_quote = 0;
9861
9862   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
9863     PerlMem_free(cmd);
9864     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
9865   }
9866
9867   s = cmd;
9868
9869   while (*s && isspace(*s)) s++;
9870
9871   if (*s == '@' || *s == '$') {
9872     vmsspec[0] = *s;  rest = s + 1;
9873     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
9874   }
9875   else { cp = vmsspec; rest = s; }
9876   if (*rest == '.' || *rest == '/') {
9877     char *cp2;
9878     for (cp2 = resspec;
9879          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
9880          rest++, cp2++) *cp2 = *rest;
9881     *cp2 = '\0';
9882     if (do_tovmsspec(resspec,cp,0,NULL)) {
9883       s = vmsspec;
9884       if (*rest) {
9885         for (cp2 = vmsspec + strlen(vmsspec);
9886              *rest && cp2 - vmsspec < sizeof vmsspec;
9887              rest++, cp2++) *cp2 = *rest;
9888         *cp2 = '\0';
9889       }
9890     }
9891   }
9892   /* Intuit whether verb (first word of cmd) is a DCL command:
9893    *   - if first nonspace char is '@', it's a DCL indirection
9894    * otherwise
9895    *   - if verb contains a filespec separator, it's not a DCL command
9896    *   - if it doesn't, caller tells us whether to default to a DCL
9897    *     command, or to a local image unless told it's DCL (by leading '$')
9898    */
9899   if (*s == '@') {
9900       isdcl = 1;
9901       if (suggest_quote) *suggest_quote = 1;
9902   } else {
9903     register char *filespec = strpbrk(s,":<[.;");
9904     rest = wordbreak = strpbrk(s," \"\t/");
9905     if (!wordbreak) wordbreak = s + strlen(s);
9906     if (*s == '$') check_img = 0;
9907     if (filespec && (filespec < wordbreak)) isdcl = 0;
9908     else isdcl = !check_img;
9909   }
9910
9911   if (!isdcl) {
9912     int rsts;
9913     imgdsc.dsc$a_pointer = s;
9914     imgdsc.dsc$w_length = wordbreak - s;
9915     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9916     if (!(retsts&1)) {
9917         _ckvmssts(lib$find_file_end(&cxt));
9918         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9919       if (!(retsts & 1) && *s == '$') {
9920         _ckvmssts(lib$find_file_end(&cxt));
9921         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
9922         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9923         if (!(retsts&1)) {
9924           _ckvmssts(lib$find_file_end(&cxt));
9925           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9926         }
9927       }
9928     }
9929     _ckvmssts(lib$find_file_end(&cxt));
9930
9931     if (retsts & 1) {
9932       FILE *fp;
9933       s = resspec;
9934       while (*s && !isspace(*s)) s++;
9935       *s = '\0';
9936
9937       /* check that it's really not DCL with no file extension */
9938       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9939       if (fp) {
9940         char b[256] = {0,0,0,0};
9941         read(fileno(fp), b, 256);
9942         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9943         if (isdcl) {
9944           int shebang_len;
9945
9946           /* Check for script */
9947           shebang_len = 0;
9948           if ((b[0] == '#') && (b[1] == '!'))
9949              shebang_len = 2;
9950 #ifdef ALTERNATE_SHEBANG
9951           else {
9952             shebang_len = strlen(ALTERNATE_SHEBANG);
9953             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9954               char * perlstr;
9955                 perlstr = strstr("perl",b);
9956                 if (perlstr == NULL)
9957                   shebang_len = 0;
9958             }
9959             else
9960               shebang_len = 0;
9961           }
9962 #endif
9963
9964           if (shebang_len > 0) {
9965           int i;
9966           int j;
9967           char tmpspec[NAM$C_MAXRSS + 1];
9968
9969             i = shebang_len;
9970              /* Image is following after white space */
9971             /*--------------------------------------*/
9972             while (isprint(b[i]) && isspace(b[i]))
9973                 i++;
9974
9975             j = 0;
9976             while (isprint(b[i]) && !isspace(b[i])) {
9977                 tmpspec[j++] = b[i++];
9978                 if (j >= NAM$C_MAXRSS)
9979                    break;
9980             }
9981             tmpspec[j] = '\0';
9982
9983              /* There may be some default parameters to the image */
9984             /*---------------------------------------------------*/
9985             j = 0;
9986             while (isprint(b[i])) {
9987                 image_argv[j++] = b[i++];
9988                 if (j >= NAM$C_MAXRSS)
9989                    break;
9990             }
9991             while ((j > 0) && !isprint(image_argv[j-1]))
9992                 j--;
9993             image_argv[j] = 0;
9994
9995             /* It will need to be converted to VMS format and validated */
9996             if (tmpspec[0] != '\0') {
9997               char * iname;
9998
9999                /* Try to find the exact program requested to be run */
10000               /*---------------------------------------------------*/
10001               iname = do_rmsexpand
10002                  (tmpspec, image_name, 0, ".exe",
10003                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10004               if (iname != NULL) {
10005                 if (cando_by_name_int
10006                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10007                   /* MCR prefix needed */
10008                   isdcl = 0;
10009                 }
10010                 else {
10011                    /* Try again with a null type */
10012                   /*----------------------------*/
10013                   iname = do_rmsexpand
10014                     (tmpspec, image_name, 0, ".",
10015                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10016                   if (iname != NULL) {
10017                     if (cando_by_name_int
10018                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10019                       /* MCR prefix needed */
10020                       isdcl = 0;
10021                     }
10022                   }
10023                 }
10024
10025                  /* Did we find the image to run the script? */
10026                 /*------------------------------------------*/
10027                 if (isdcl) {
10028                   char *tchr;
10029
10030                    /* Assume DCL or foreign command exists */
10031                   /*--------------------------------------*/
10032                   tchr = strrchr(tmpspec, '/');
10033                   if (tchr != NULL) {
10034                     tchr++;
10035                   }
10036                   else {
10037                     tchr = tmpspec;
10038                   }
10039                   strcpy(image_name, tchr);
10040                 }
10041               }
10042             }
10043           }
10044         }
10045         fclose(fp);
10046       }
10047       if (check_img && isdcl) return RMS$_FNF;
10048
10049       if (cando_by_name(S_IXUSR,0,resspec)) {
10050         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10051         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
10052         if (!isdcl) {
10053             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
10054             if (image_name[0] != 0) {
10055                 strcat(vmscmd->dsc$a_pointer, image_name);
10056                 strcat(vmscmd->dsc$a_pointer, " ");
10057             }
10058         } else if (image_name[0] != 0) {
10059             strcpy(vmscmd->dsc$a_pointer, image_name);
10060             strcat(vmscmd->dsc$a_pointer, " ");
10061         } else {
10062             strcpy(vmscmd->dsc$a_pointer,"@");
10063         }
10064         if (suggest_quote) *suggest_quote = 1;
10065
10066         /* If there is an image name, use original command */
10067         if (image_name[0] == 0)
10068             strcat(vmscmd->dsc$a_pointer,resspec);
10069         else {
10070             rest = cmd;
10071             while (*rest && isspace(*rest)) rest++;
10072         }
10073
10074         if (image_argv[0] != 0) {
10075           strcat(vmscmd->dsc$a_pointer,image_argv);
10076           strcat(vmscmd->dsc$a_pointer, " ");
10077         }
10078         if (rest) {
10079            int rest_len;
10080            int vmscmd_len;
10081
10082            rest_len = strlen(rest);
10083            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10084            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10085               strcat(vmscmd->dsc$a_pointer,rest);
10086            else
10087              retsts = CLI$_BUFOVF;
10088         }
10089         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10090         PerlMem_free(cmd);
10091         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10092       }
10093       else
10094         retsts = RMS$_PRV;
10095     }
10096   }
10097   /* It's either a DCL command or we couldn't find a suitable image */
10098   vmscmd->dsc$w_length = strlen(cmd);
10099
10100   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
10101   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
10102   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
10103
10104   PerlMem_free(cmd);
10105
10106   /* check if it's a symbol (for quoting purposes) */
10107   if (suggest_quote && !*suggest_quote) {
10108     int iss;
10109     char equiv[LNM$C_NAMLENGTH];
10110     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10111     eqvdsc.dsc$a_pointer = equiv;
10112
10113     iss = lib$get_symbol(vmscmd,&eqvdsc);
10114     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10115   }
10116   if (!(retsts & 1)) {
10117     /* just hand off status values likely to be due to user error */
10118     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10119         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10120        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10121     else { _ckvmssts(retsts); }
10122   }
10123
10124   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10125
10126 }  /* end of setup_cmddsc() */
10127
10128
10129 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10130 bool
10131 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10132 {
10133 bool exec_sts;
10134 char * cmd;
10135
10136   if (sp > mark) {
10137     if (vfork_called) {           /* this follows a vfork - act Unixish */
10138       vfork_called--;
10139       if (vfork_called < 0) {
10140         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10141         vfork_called = 0;
10142       }
10143       else return do_aexec(really,mark,sp);
10144     }
10145                                            /* no vfork - act VMSish */
10146     cmd = setup_argstr(aTHX_ really,mark,sp);
10147     exec_sts = vms_do_exec(cmd);
10148     Safefree(cmd);  /* Clean up from setup_argstr() */
10149     return exec_sts;
10150   }
10151
10152   return FALSE;
10153 }  /* end of vms_do_aexec() */
10154 /*}}}*/
10155
10156 /* {{{bool vms_do_exec(char *cmd) */
10157 bool
10158 Perl_vms_do_exec(pTHX_ const char *cmd)
10159 {
10160   struct dsc$descriptor_s *vmscmd;
10161
10162   if (vfork_called) {             /* this follows a vfork - act Unixish */
10163     vfork_called--;
10164     if (vfork_called < 0) {
10165       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10166       vfork_called = 0;
10167     }
10168     else return do_exec(cmd);
10169   }
10170
10171   {                               /* no vfork - act VMSish */
10172     unsigned long int retsts;
10173
10174     TAINT_ENV();
10175     TAINT_PROPER("exec");
10176     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10177       retsts = lib$do_command(vmscmd);
10178
10179     switch (retsts) {
10180       case RMS$_FNF: case RMS$_DNF:
10181         set_errno(ENOENT); break;
10182       case RMS$_DIR:
10183         set_errno(ENOTDIR); break;
10184       case RMS$_DEV:
10185         set_errno(ENODEV); break;
10186       case RMS$_PRV:
10187         set_errno(EACCES); break;
10188       case RMS$_SYN:
10189         set_errno(EINVAL); break;
10190       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10191         set_errno(E2BIG); break;
10192       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10193         _ckvmssts(retsts); /* fall through */
10194       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10195         set_errno(EVMSERR);
10196     }
10197     set_vaxc_errno(retsts);
10198     if (ckWARN(WARN_EXEC)) {
10199       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10200              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10201     }
10202     vms_execfree(vmscmd);
10203   }
10204
10205   return FALSE;
10206
10207 }  /* end of vms_do_exec() */
10208 /*}}}*/
10209
10210 unsigned long int Perl_do_spawn(pTHX_ const char *);
10211 unsigned long int do_spawn2(pTHX_ const char *, int);
10212
10213 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
10214 unsigned long int
10215 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
10216 {
10217 unsigned long int sts;
10218 char * cmd;
10219 int flags = 0;
10220
10221   if (sp > mark) {
10222
10223     /* We'll copy the (undocumented?) Win32 behavior and allow a
10224      * numeric first argument.  But the only value we'll support
10225      * through do_aspawn is a value of 1, which means spawn without
10226      * waiting for completion -- other values are ignored.
10227      */
10228     if (SvNIOKp(*((SV**)mark+1)) && !SvPOKp(*((SV**)mark+1))) {
10229         ++mark;
10230         flags = SvIVx(*(SV**)mark);
10231     }
10232
10233     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
10234         flags = CLI$M_NOWAIT;
10235     else
10236         flags = 0;
10237
10238     cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
10239     sts = do_spawn2(aTHX_ cmd, flags);
10240     /* pp_sys will clean up cmd */
10241     return sts;
10242   }
10243   return SS$_ABORT;
10244 }  /* end of do_aspawn() */
10245 /*}}}*/
10246
10247
10248 /* {{{unsigned long int do_spawn(char *cmd) */
10249 unsigned long int
10250 Perl_do_spawn(pTHX_ const char *cmd)
10251 {
10252     return do_spawn2(aTHX_ cmd, 0);
10253 }
10254 /*}}}*/
10255
10256 /* {{{unsigned long int do_spawn2(char *cmd) */
10257 unsigned long int
10258 do_spawn2(pTHX_ const char *cmd, int flags)
10259 {
10260   unsigned long int sts, substs;
10261
10262   /* The caller of this routine expects to Safefree(PL_Cmd) */
10263   Newx(PL_Cmd,10,char);
10264
10265   TAINT_ENV();
10266   TAINT_PROPER("spawn");
10267   if (!cmd || !*cmd) {
10268     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
10269     if (!(sts & 1)) {
10270       switch (sts) {
10271         case RMS$_FNF:  case RMS$_DNF:
10272           set_errno(ENOENT); break;
10273         case RMS$_DIR:
10274           set_errno(ENOTDIR); break;
10275         case RMS$_DEV:
10276           set_errno(ENODEV); break;
10277         case RMS$_PRV:
10278           set_errno(EACCES); break;
10279         case RMS$_SYN:
10280           set_errno(EINVAL); break;
10281         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10282           set_errno(E2BIG); break;
10283         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10284           _ckvmssts(sts); /* fall through */
10285         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10286           set_errno(EVMSERR);
10287       }
10288       set_vaxc_errno(sts);
10289       if (ckWARN(WARN_EXEC)) {
10290         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
10291                     Strerror(errno));
10292       }
10293     }
10294     sts = substs;
10295   }
10296   else {
10297     char mode[3];
10298     PerlIO * fp;
10299     if (flags & CLI$M_NOWAIT)
10300         strcpy(mode, "n");
10301     else
10302         strcpy(mode, "nW");
10303
10304     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
10305     if (fp != NULL)
10306       my_pclose(fp);
10307     /* sts will be the pid in the nowait case */
10308   }
10309   return sts;
10310 }  /* end of do_spawn2() */
10311 /*}}}*/
10312
10313
10314 static unsigned int *sockflags, sockflagsize;
10315
10316 /*
10317  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
10318  * routines found in some versions of the CRTL can't deal with sockets.
10319  * We don't shim the other file open routines since a socket isn't
10320  * likely to be opened by a name.
10321  */
10322 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
10323 FILE *my_fdopen(int fd, const char *mode)
10324 {
10325   FILE *fp = fdopen(fd, mode);
10326
10327   if (fp) {
10328     unsigned int fdoff = fd / sizeof(unsigned int);
10329     Stat_t sbuf; /* native stat; we don't need flex_stat */
10330     if (!sockflagsize || fdoff > sockflagsize) {
10331       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
10332       else           Newx  (sockflags,fdoff+2,unsigned int);
10333       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
10334       sockflagsize = fdoff + 2;
10335     }
10336     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
10337       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
10338   }
10339   return fp;
10340
10341 }
10342 /*}}}*/
10343
10344
10345 /*
10346  * Clear the corresponding bit when the (possibly) socket stream is closed.
10347  * There still a small hole: we miss an implicit close which might occur
10348  * via freopen().  >> Todo
10349  */
10350 /*{{{ int my_fclose(FILE *fp)*/
10351 int my_fclose(FILE *fp) {
10352   if (fp) {
10353     unsigned int fd = fileno(fp);
10354     unsigned int fdoff = fd / sizeof(unsigned int);
10355
10356     if (sockflagsize && fdoff <= sockflagsize)
10357       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
10358   }
10359   return fclose(fp);
10360 }
10361 /*}}}*/
10362
10363
10364 /*
10365  * A simple fwrite replacement which outputs itmsz*nitm chars without
10366  * introducing record boundaries every itmsz chars.
10367  * We are using fputs, which depends on a terminating null.  We may
10368  * well be writing binary data, so we need to accommodate not only
10369  * data with nulls sprinkled in the middle but also data with no null
10370  * byte at the end.
10371  */
10372 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
10373 int
10374 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
10375 {
10376   register char *cp, *end, *cpd, *data;
10377   register unsigned int fd = fileno(dest);
10378   register unsigned int fdoff = fd / sizeof(unsigned int);
10379   int retval;
10380   int bufsize = itmsz * nitm + 1;
10381
10382   if (fdoff < sockflagsize &&
10383       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
10384     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
10385     return nitm;
10386   }
10387
10388   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
10389   memcpy( data, src, itmsz*nitm );
10390   data[itmsz*nitm] = '\0';
10391
10392   end = data + itmsz * nitm;
10393   retval = (int) nitm; /* on success return # items written */
10394
10395   cpd = data;
10396   while (cpd <= end) {
10397     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
10398     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
10399     if (cp < end)
10400       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
10401     cpd = cp + 1;
10402   }
10403
10404   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
10405   return retval;
10406
10407 }  /* end of my_fwrite() */
10408 /*}}}*/
10409
10410 /*{{{ int my_flush(FILE *fp)*/
10411 int
10412 Perl_my_flush(pTHX_ FILE *fp)
10413 {
10414     int res;
10415     if ((res = fflush(fp)) == 0 && fp) {
10416 #ifdef VMS_DO_SOCKETS
10417         Stat_t s;
10418         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
10419 #endif
10420             res = fsync(fileno(fp));
10421     }
10422 /*
10423  * If the flush succeeded but set end-of-file, we need to clear
10424  * the error because our caller may check ferror().  BTW, this
10425  * probably means we just flushed an empty file.
10426  */
10427     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
10428
10429     return res;
10430 }
10431 /*}}}*/
10432
10433 /*
10434  * Here are replacements for the following Unix routines in the VMS environment:
10435  *      getpwuid    Get information for a particular UIC or UID
10436  *      getpwnam    Get information for a named user
10437  *      getpwent    Get information for each user in the rights database
10438  *      setpwent    Reset search to the start of the rights database
10439  *      endpwent    Finish searching for users in the rights database
10440  *
10441  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
10442  * (defined in pwd.h), which contains the following fields:-
10443  *      struct passwd {
10444  *              char        *pw_name;    Username (in lower case)
10445  *              char        *pw_passwd;  Hashed password
10446  *              unsigned int pw_uid;     UIC
10447  *              unsigned int pw_gid;     UIC group  number
10448  *              char        *pw_unixdir; Default device/directory (VMS-style)
10449  *              char        *pw_gecos;   Owner name
10450  *              char        *pw_dir;     Default device/directory (Unix-style)
10451  *              char        *pw_shell;   Default CLI name (eg. DCL)
10452  *      };
10453  * If the specified user does not exist, getpwuid and getpwnam return NULL.
10454  *
10455  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
10456  * not the UIC member number (eg. what's returned by getuid()),
10457  * getpwuid() can accept either as input (if uid is specified, the caller's
10458  * UIC group is used), though it won't recognise gid=0.
10459  *
10460  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
10461  * information about other users in your group or in other groups, respectively.
10462  * If the required privilege is not available, then these routines fill only
10463  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
10464  * string).
10465  *
10466  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
10467  */
10468
10469 /* sizes of various UAF record fields */
10470 #define UAI$S_USERNAME 12
10471 #define UAI$S_IDENT    31
10472 #define UAI$S_OWNER    31
10473 #define UAI$S_DEFDEV   31
10474 #define UAI$S_DEFDIR   63
10475 #define UAI$S_DEFCLI   31
10476 #define UAI$S_PWD       8
10477
10478 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
10479                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
10480                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
10481
10482 static char __empty[]= "";
10483 static struct passwd __passwd_empty=
10484     {(char *) __empty, (char *) __empty, 0, 0,
10485      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
10486 static int contxt= 0;
10487 static struct passwd __pwdcache;
10488 static char __pw_namecache[UAI$S_IDENT+1];
10489
10490 /*
10491  * This routine does most of the work extracting the user information.
10492  */
10493 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
10494 {
10495     static struct {
10496         unsigned char length;
10497         char pw_gecos[UAI$S_OWNER+1];
10498     } owner;
10499     static union uicdef uic;
10500     static struct {
10501         unsigned char length;
10502         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
10503     } defdev;
10504     static struct {
10505         unsigned char length;
10506         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
10507     } defdir;
10508     static struct {
10509         unsigned char length;
10510         char pw_shell[UAI$S_DEFCLI+1];
10511     } defcli;
10512     static char pw_passwd[UAI$S_PWD+1];
10513
10514     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
10515     struct dsc$descriptor_s name_desc;
10516     unsigned long int sts;
10517
10518     static struct itmlst_3 itmlst[]= {
10519         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
10520         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
10521         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
10522         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
10523         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
10524         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
10525         {0,                0,           NULL,    NULL}};
10526
10527     name_desc.dsc$w_length=  strlen(name);
10528     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
10529     name_desc.dsc$b_class=   DSC$K_CLASS_S;
10530     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
10531
10532 /*  Note that sys$getuai returns many fields as counted strings. */
10533     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
10534     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
10535       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
10536     }
10537     else { _ckvmssts(sts); }
10538     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
10539
10540     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
10541     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
10542     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
10543     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
10544     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
10545     owner.pw_gecos[lowner]=            '\0';
10546     defdev.pw_dir[ldefdev+ldefdir]= '\0';
10547     defcli.pw_shell[ldefcli]=          '\0';
10548     if (valid_uic(uic)) {
10549         pwd->pw_uid= uic.uic$l_uic;
10550         pwd->pw_gid= uic.uic$v_group;
10551     }
10552     else
10553       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
10554     pwd->pw_passwd=  pw_passwd;
10555     pwd->pw_gecos=   owner.pw_gecos;
10556     pwd->pw_dir=     defdev.pw_dir;
10557     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
10558     pwd->pw_shell=   defcli.pw_shell;
10559     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
10560         int ldir;
10561         ldir= strlen(pwd->pw_unixdir) - 1;
10562         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
10563     }
10564     else
10565         strcpy(pwd->pw_unixdir, pwd->pw_dir);
10566     if (!decc_efs_case_preserve)
10567         __mystrtolower(pwd->pw_unixdir);
10568     return 1;
10569 }
10570
10571 /*
10572  * Get information for a named user.
10573 */
10574 /*{{{struct passwd *getpwnam(char *name)*/
10575 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
10576 {
10577     struct dsc$descriptor_s name_desc;
10578     union uicdef uic;
10579     unsigned long int status, sts;
10580
10581     __pwdcache = __passwd_empty;
10582     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
10583       /* We still may be able to determine pw_uid and pw_gid */
10584       name_desc.dsc$w_length=  strlen(name);
10585       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
10586       name_desc.dsc$b_class=   DSC$K_CLASS_S;
10587       name_desc.dsc$a_pointer= (char *) name;
10588       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
10589         __pwdcache.pw_uid= uic.uic$l_uic;
10590         __pwdcache.pw_gid= uic.uic$v_group;
10591       }
10592       else {
10593         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
10594           set_vaxc_errno(sts);
10595           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
10596           return NULL;
10597         }
10598         else { _ckvmssts(sts); }
10599       }
10600     }
10601     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
10602     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
10603     __pwdcache.pw_name= __pw_namecache;
10604     return &__pwdcache;
10605 }  /* end of my_getpwnam() */
10606 /*}}}*/
10607
10608 /*
10609  * Get information for a particular UIC or UID.
10610  * Called by my_getpwent with uid=-1 to list all users.
10611 */
10612 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
10613 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
10614 {
10615     const $DESCRIPTOR(name_desc,__pw_namecache);
10616     unsigned short lname;
10617     union uicdef uic;
10618     unsigned long int status;
10619
10620     if (uid == (unsigned int) -1) {
10621       do {
10622         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
10623         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
10624           set_vaxc_errno(status);
10625           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10626           my_endpwent();
10627           return NULL;
10628         }
10629         else { _ckvmssts(status); }
10630       } while (!valid_uic (uic));
10631     }
10632     else {
10633       uic.uic$l_uic= uid;
10634       if (!uic.uic$v_group)
10635         uic.uic$v_group= PerlProc_getgid();
10636       if (valid_uic(uic))
10637         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
10638       else status = SS$_IVIDENT;
10639       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
10640           status == RMS$_PRV) {
10641         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10642         return NULL;
10643       }
10644       else { _ckvmssts(status); }
10645     }
10646     __pw_namecache[lname]= '\0';
10647     __mystrtolower(__pw_namecache);
10648
10649     __pwdcache = __passwd_empty;
10650     __pwdcache.pw_name = __pw_namecache;
10651
10652 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
10653     The identifier's value is usually the UIC, but it doesn't have to be,
10654     so if we can, we let fillpasswd update this. */
10655     __pwdcache.pw_uid =  uic.uic$l_uic;
10656     __pwdcache.pw_gid =  uic.uic$v_group;
10657
10658     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
10659     return &__pwdcache;
10660
10661 }  /* end of my_getpwuid() */
10662 /*}}}*/
10663
10664 /*
10665  * Get information for next user.
10666 */
10667 /*{{{struct passwd *my_getpwent()*/
10668 struct passwd *Perl_my_getpwent(pTHX)
10669 {
10670     return (my_getpwuid((unsigned int) -1));
10671 }
10672 /*}}}*/
10673
10674 /*
10675  * Finish searching rights database for users.
10676 */
10677 /*{{{void my_endpwent()*/
10678 void Perl_my_endpwent(pTHX)
10679 {
10680     if (contxt) {
10681       _ckvmssts(sys$finish_rdb(&contxt));
10682       contxt= 0;
10683     }
10684 }
10685 /*}}}*/
10686
10687 #ifdef HOMEGROWN_POSIX_SIGNALS
10688   /* Signal handling routines, pulled into the core from POSIX.xs.
10689    *
10690    * We need these for threads, so they've been rolled into the core,
10691    * rather than left in POSIX.xs.
10692    *
10693    * (DRS, Oct 23, 1997)
10694    */
10695
10696   /* sigset_t is atomic under VMS, so these routines are easy */
10697 /*{{{int my_sigemptyset(sigset_t *) */
10698 int my_sigemptyset(sigset_t *set) {
10699     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10700     *set = 0; return 0;
10701 }
10702 /*}}}*/
10703
10704
10705 /*{{{int my_sigfillset(sigset_t *)*/
10706 int my_sigfillset(sigset_t *set) {
10707     int i;
10708     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10709     for (i = 0; i < NSIG; i++) *set |= (1 << i);
10710     return 0;
10711 }
10712 /*}}}*/
10713
10714
10715 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
10716 int my_sigaddset(sigset_t *set, int sig) {
10717     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10718     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10719     *set |= (1 << (sig - 1));
10720     return 0;
10721 }
10722 /*}}}*/
10723
10724
10725 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
10726 int my_sigdelset(sigset_t *set, int sig) {
10727     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10728     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10729     *set &= ~(1 << (sig - 1));
10730     return 0;
10731 }
10732 /*}}}*/
10733
10734
10735 /*{{{int my_sigismember(sigset_t *set, int sig)*/
10736 int my_sigismember(sigset_t *set, int sig) {
10737     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10738     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10739     return *set & (1 << (sig - 1));
10740 }
10741 /*}}}*/
10742
10743
10744 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10745 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10746     sigset_t tempmask;
10747
10748     /* If set and oset are both null, then things are badly wrong. Bail out. */
10749     if ((oset == NULL) && (set == NULL)) {
10750       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
10751       return -1;
10752     }
10753
10754     /* If set's null, then we're just handling a fetch. */
10755     if (set == NULL) {
10756         tempmask = sigblock(0);
10757     }
10758     else {
10759       switch (how) {
10760       case SIG_SETMASK:
10761         tempmask = sigsetmask(*set);
10762         break;
10763       case SIG_BLOCK:
10764         tempmask = sigblock(*set);
10765         break;
10766       case SIG_UNBLOCK:
10767         tempmask = sigblock(0);
10768         sigsetmask(*oset & ~tempmask);
10769         break;
10770       default:
10771         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10772         return -1;
10773       }
10774     }
10775
10776     /* Did they pass us an oset? If so, stick our holding mask into it */
10777     if (oset)
10778       *oset = tempmask;
10779
10780     return 0;
10781 }
10782 /*}}}*/
10783 #endif  /* HOMEGROWN_POSIX_SIGNALS */
10784
10785
10786 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
10787  * my_utime(), and flex_stat(), all of which operate on UTC unless
10788  * VMSISH_TIMES is true.
10789  */
10790 /* method used to handle UTC conversions:
10791  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
10792  */
10793 static int gmtime_emulation_type;
10794 /* number of secs to add to UTC POSIX-style time to get local time */
10795 static long int utc_offset_secs;
10796
10797 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
10798  * in vmsish.h.  #undef them here so we can call the CRTL routines
10799  * directly.
10800  */
10801 #undef gmtime
10802 #undef localtime
10803 #undef time
10804
10805
10806 /*
10807  * DEC C previous to 6.0 corrupts the behavior of the /prefix
10808  * qualifier with the extern prefix pragma.  This provisional
10809  * hack circumvents this prefix pragma problem in previous
10810  * precompilers.
10811  */
10812 #if defined(__VMS_VER) && __VMS_VER >= 70000000
10813 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
10814 #    pragma __extern_prefix save
10815 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
10816 #    define gmtime decc$__utctz_gmtime
10817 #    define localtime decc$__utctz_localtime
10818 #    define time decc$__utc_time
10819 #    pragma __extern_prefix restore
10820
10821      struct tm *gmtime(), *localtime();
10822
10823 #  endif
10824 #endif
10825
10826
10827 static time_t toutc_dst(time_t loc) {
10828   struct tm *rsltmp;
10829
10830   if ((rsltmp = localtime(&loc)) == NULL) return -1;
10831   loc -= utc_offset_secs;
10832   if (rsltmp->tm_isdst) loc -= 3600;
10833   return loc;
10834 }
10835 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10836        ((gmtime_emulation_type || my_time(NULL)), \
10837        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
10838        ((secs) - utc_offset_secs))))
10839
10840 static time_t toloc_dst(time_t utc) {
10841   struct tm *rsltmp;
10842
10843   utc += utc_offset_secs;
10844   if ((rsltmp = localtime(&utc)) == NULL) return -1;
10845   if (rsltmp->tm_isdst) utc += 3600;
10846   return utc;
10847 }
10848 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10849        ((gmtime_emulation_type || my_time(NULL)), \
10850        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
10851        ((secs) + utc_offset_secs))))
10852
10853 #ifndef RTL_USES_UTC
10854 /*
10855
10856     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
10857         DST starts on 1st sun of april      at 02:00  std time
10858             ends on last sun of october     at 02:00  dst time
10859     see the UCX management command reference, SET CONFIG TIMEZONE
10860     for formatting info.
10861
10862     No, it's not as general as it should be, but then again, NOTHING
10863     will handle UK times in a sensible way.
10864 */
10865
10866
10867 /*
10868     parse the DST start/end info:
10869     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
10870 */
10871
10872 static char *
10873 tz_parse_startend(char *s, struct tm *w, int *past)
10874 {
10875     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
10876     int ly, dozjd, d, m, n, hour, min, sec, j, k;
10877     time_t g;
10878
10879     if (!s)    return 0;
10880     if (!w) return 0;
10881     if (!past) return 0;
10882
10883     ly = 0;
10884     if (w->tm_year % 4        == 0) ly = 1;
10885     if (w->tm_year % 100      == 0) ly = 0;
10886     if (w->tm_year+1900 % 400 == 0) ly = 1;
10887     if (ly) dinm[1]++;
10888
10889     dozjd = isdigit(*s);
10890     if (*s == 'J' || *s == 'j' || dozjd) {
10891         if (!dozjd && !isdigit(*++s)) return 0;
10892         d = *s++ - '0';
10893         if (isdigit(*s)) {
10894             d = d*10 + *s++ - '0';
10895             if (isdigit(*s)) {
10896                 d = d*10 + *s++ - '0';
10897             }
10898         }
10899         if (d == 0) return 0;
10900         if (d > 366) return 0;
10901         d--;
10902         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
10903         g = d * 86400;
10904         dozjd = 1;
10905     } else if (*s == 'M' || *s == 'm') {
10906         if (!isdigit(*++s)) return 0;
10907         m = *s++ - '0';
10908         if (isdigit(*s)) m = 10*m + *s++ - '0';
10909         if (*s != '.') return 0;
10910         if (!isdigit(*++s)) return 0;
10911         n = *s++ - '0';
10912         if (n < 1 || n > 5) return 0;
10913         if (*s != '.') return 0;
10914         if (!isdigit(*++s)) return 0;
10915         d = *s++ - '0';
10916         if (d > 6) return 0;
10917     }
10918
10919     if (*s == '/') {
10920         if (!isdigit(*++s)) return 0;
10921         hour = *s++ - '0';
10922         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
10923         if (*s == ':') {
10924             if (!isdigit(*++s)) return 0;
10925             min = *s++ - '0';
10926             if (isdigit(*s)) min = 10*min + *s++ - '0';
10927             if (*s == ':') {
10928                 if (!isdigit(*++s)) return 0;
10929                 sec = *s++ - '0';
10930                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
10931             }
10932         }
10933     } else {
10934         hour = 2;
10935         min = 0;
10936         sec = 0;
10937     }
10938
10939     if (dozjd) {
10940         if (w->tm_yday < d) goto before;
10941         if (w->tm_yday > d) goto after;
10942     } else {
10943         if (w->tm_mon+1 < m) goto before;
10944         if (w->tm_mon+1 > m) goto after;
10945
10946         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
10947         k = d - j; /* mday of first d */
10948         if (k <= 0) k += 7;
10949         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
10950         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
10951         if (w->tm_mday < k) goto before;
10952         if (w->tm_mday > k) goto after;
10953     }
10954
10955     if (w->tm_hour < hour) goto before;
10956     if (w->tm_hour > hour) goto after;
10957     if (w->tm_min  < min)  goto before;
10958     if (w->tm_min  > min)  goto after;
10959     if (w->tm_sec  < sec)  goto before;
10960     goto after;
10961
10962 before:
10963     *past = 0;
10964     return s;
10965 after:
10966     *past = 1;
10967     return s;
10968 }
10969
10970
10971
10972
10973 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
10974
10975 static char *
10976 tz_parse_offset(char *s, int *offset)
10977 {
10978     int hour = 0, min = 0, sec = 0;
10979     int neg = 0;
10980     if (!s) return 0;
10981     if (!offset) return 0;
10982
10983     if (*s == '-') {neg++; s++;}
10984     if (*s == '+') s++;
10985     if (!isdigit(*s)) return 0;
10986     hour = *s++ - '0';
10987     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10988     if (hour > 24) return 0;
10989     if (*s == ':') {
10990         if (!isdigit(*++s)) return 0;
10991         min = *s++ - '0';
10992         if (isdigit(*s)) min = min*10 + (*s++ - '0');
10993         if (min > 59) return 0;
10994         if (*s == ':') {
10995             if (!isdigit(*++s)) return 0;
10996             sec = *s++ - '0';
10997             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10998             if (sec > 59) return 0;
10999         }
11000     }
11001
11002     *offset = (hour*60+min)*60 + sec;
11003     if (neg) *offset = -*offset;
11004     return s;
11005 }
11006
11007 /*
11008     input time is w, whatever type of time the CRTL localtime() uses.
11009     sets dst, the zone, and the gmtoff (seconds)
11010
11011     caches the value of TZ and UCX$TZ env variables; note that
11012     my_setenv looks for these and sets a flag if they're changed
11013     for efficiency.
11014
11015     We have to watch out for the "australian" case (dst starts in
11016     october, ends in april)...flagged by "reverse" and checked by
11017     scanning through the months of the previous year.
11018
11019 */
11020
11021 static int
11022 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
11023 {
11024     time_t when;
11025     struct tm *w2;
11026     char *s,*s2;
11027     char *dstzone, *tz, *s_start, *s_end;
11028     int std_off, dst_off, isdst;
11029     int y, dststart, dstend;
11030     static char envtz[1025];  /* longer than any logical, symbol, ... */
11031     static char ucxtz[1025];
11032     static char reversed = 0;
11033
11034     if (!w) return 0;
11035
11036     if (tz_updated) {
11037         tz_updated = 0;
11038         reversed = -1;  /* flag need to check  */
11039         envtz[0] = ucxtz[0] = '\0';
11040         tz = my_getenv("TZ",0);
11041         if (tz) strcpy(envtz, tz);
11042         tz = my_getenv("UCX$TZ",0);
11043         if (tz) strcpy(ucxtz, tz);
11044         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
11045     }
11046     tz = envtz;
11047     if (!*tz) tz = ucxtz;
11048
11049     s = tz;
11050     while (isalpha(*s)) s++;
11051     s = tz_parse_offset(s, &std_off);
11052     if (!s) return 0;
11053     if (!*s) {                  /* no DST, hurray we're done! */
11054         isdst = 0;
11055         goto done;
11056     }
11057
11058     dstzone = s;
11059     while (isalpha(*s)) s++;
11060     s2 = tz_parse_offset(s, &dst_off);
11061     if (s2) {
11062         s = s2;
11063     } else {
11064         dst_off = std_off - 3600;
11065     }
11066
11067     if (!*s) {      /* default dst start/end?? */
11068         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
11069             s = strchr(ucxtz,',');
11070         }
11071         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
11072     }
11073     if (*s != ',') return 0;
11074
11075     when = *w;
11076     when = _toutc(when);      /* convert to utc */
11077     when = when - std_off;    /* convert to pseudolocal time*/
11078
11079     w2 = localtime(&when);
11080     y = w2->tm_year;
11081     s_start = s+1;
11082     s = tz_parse_startend(s_start,w2,&dststart);
11083     if (!s) return 0;
11084     if (*s != ',') return 0;
11085
11086     when = *w;
11087     when = _toutc(when);      /* convert to utc */
11088     when = when - dst_off;    /* convert to pseudolocal time*/
11089     w2 = localtime(&when);
11090     if (w2->tm_year != y) {   /* spans a year, just check one time */
11091         when += dst_off - std_off;
11092         w2 = localtime(&when);
11093     }
11094     s_end = s+1;
11095     s = tz_parse_startend(s_end,w2,&dstend);
11096     if (!s) return 0;
11097
11098     if (reversed == -1) {  /* need to check if start later than end */
11099         int j, ds, de;
11100
11101         when = *w;
11102         if (when < 2*365*86400) {
11103             when += 2*365*86400;
11104         } else {
11105             when -= 365*86400;
11106         }
11107         w2 =localtime(&when);
11108         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
11109
11110         for (j = 0; j < 12; j++) {
11111             w2 =localtime(&when);
11112             tz_parse_startend(s_start,w2,&ds);
11113             tz_parse_startend(s_end,w2,&de);
11114             if (ds != de) break;
11115             when += 30*86400;
11116         }
11117         reversed = 0;
11118         if (de && !ds) reversed = 1;
11119     }
11120
11121     isdst = dststart && !dstend;
11122     if (reversed) isdst = dststart  || !dstend;
11123
11124 done:
11125     if (dst)    *dst = isdst;
11126     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
11127     if (isdst)  tz = dstzone;
11128     if (zone) {
11129         while(isalpha(*tz))  *zone++ = *tz++;
11130         *zone = '\0';
11131     }
11132     return 1;
11133 }
11134
11135 #endif /* !RTL_USES_UTC */
11136
11137 /* my_time(), my_localtime(), my_gmtime()
11138  * By default traffic in UTC time values, using CRTL gmtime() or
11139  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11140  * Note: We need to use these functions even when the CRTL has working
11141  * UTC support, since they also handle C<use vmsish qw(times);>
11142  *
11143  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
11144  * Modified by Charles Bailey <bailey@newman.upenn.edu>
11145  */
11146
11147 /*{{{time_t my_time(time_t *timep)*/
11148 time_t Perl_my_time(pTHX_ time_t *timep)
11149 {
11150   time_t when;
11151   struct tm *tm_p;
11152
11153   if (gmtime_emulation_type == 0) {
11154     int dstnow;
11155     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
11156                               /* results of calls to gmtime() and localtime() */
11157                               /* for same &base */
11158
11159     gmtime_emulation_type++;
11160     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11161       char off[LNM$C_NAMLENGTH+1];;
11162
11163       gmtime_emulation_type++;
11164       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11165         gmtime_emulation_type++;
11166         utc_offset_secs = 0;
11167         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11168       }
11169       else { utc_offset_secs = atol(off); }
11170     }
11171     else { /* We've got a working gmtime() */
11172       struct tm gmt, local;
11173
11174       gmt = *tm_p;
11175       tm_p = localtime(&base);
11176       local = *tm_p;
11177       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
11178       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11179       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
11180       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
11181     }
11182   }
11183
11184   when = time(NULL);
11185 # ifdef VMSISH_TIME
11186 # ifdef RTL_USES_UTC
11187   if (VMSISH_TIME) when = _toloc(when);
11188 # else
11189   if (!VMSISH_TIME) when = _toutc(when);
11190 # endif
11191 # endif
11192   if (timep != NULL) *timep = when;
11193   return when;
11194
11195 }  /* end of my_time() */
11196 /*}}}*/
11197
11198
11199 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11200 struct tm *
11201 Perl_my_gmtime(pTHX_ const time_t *timep)
11202 {
11203   char *p;
11204   time_t when;
11205   struct tm *rsltmp;
11206
11207   if (timep == NULL) {
11208     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11209     return NULL;
11210   }
11211   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11212
11213   when = *timep;
11214 # ifdef VMSISH_TIME
11215   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11216 #  endif
11217 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
11218   return gmtime(&when);
11219 # else
11220   /* CRTL localtime() wants local time as input, so does no tz correction */
11221   rsltmp = localtime(&when);
11222   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
11223   return rsltmp;
11224 #endif
11225 }  /* end of my_gmtime() */
11226 /*}}}*/
11227
11228
11229 /*{{{struct tm *my_localtime(const time_t *timep)*/
11230 struct tm *
11231 Perl_my_localtime(pTHX_ const time_t *timep)
11232 {
11233   time_t when, whenutc;
11234   struct tm *rsltmp;
11235   int dst, offset;
11236
11237   if (timep == NULL) {
11238     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11239     return NULL;
11240   }
11241   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11242   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11243
11244   when = *timep;
11245 # ifdef RTL_USES_UTC
11246 # ifdef VMSISH_TIME
11247   if (VMSISH_TIME) when = _toutc(when);
11248 # endif
11249   /* CRTL localtime() wants UTC as input, does tz correction itself */
11250   return localtime(&when);
11251
11252 # else /* !RTL_USES_UTC */
11253   whenutc = when;
11254 # ifdef VMSISH_TIME
11255   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
11256   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
11257 # endif
11258   dst = -1;
11259 #ifndef RTL_USES_UTC
11260   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
11261       when = whenutc - offset;                   /* pseudolocal time*/
11262   }
11263 # endif
11264   /* CRTL localtime() wants local time as input, so does no tz correction */
11265   rsltmp = localtime(&when);
11266   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
11267   return rsltmp;
11268 # endif
11269
11270 } /*  end of my_localtime() */
11271 /*}}}*/
11272
11273 /* Reset definitions for later calls */
11274 #define gmtime(t)    my_gmtime(t)
11275 #define localtime(t) my_localtime(t)
11276 #define time(t)      my_time(t)
11277
11278
11279 /* my_utime - update modification/access time of a file
11280  *
11281  * VMS 7.3 and later implementation
11282  * Only the UTC translation is home-grown. The rest is handled by the
11283  * CRTL utime(), which will take into account the relevant feature
11284  * logicals and ODS-5 volume characteristics for true access times.
11285  *
11286  * pre VMS 7.3 implementation:
11287  * The calling sequence is identical to POSIX utime(), but under
11288  * VMS with ODS-2, only the modification time is changed; ODS-2 does
11289  * not maintain access times.  Restrictions differ from the POSIX
11290  * definition in that the time can be changed as long as the
11291  * caller has permission to execute the necessary IO$_MODIFY $QIO;
11292  * no separate checks are made to insure that the caller is the
11293  * owner of the file or has special privs enabled.
11294  * Code here is based on Joe Meadows' FILE utility.
11295  *
11296  */
11297
11298 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11299  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
11300  * in 100 ns intervals.
11301  */
11302 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11303
11304 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11305 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11306 {
11307 #if __CRTL_VER >= 70300000
11308   struct utimbuf utc_utimes, *utc_utimesp;
11309
11310   if (utimes != NULL) {
11311     utc_utimes.actime = utimes->actime;
11312     utc_utimes.modtime = utimes->modtime;
11313 # ifdef VMSISH_TIME
11314     /* If input was local; convert to UTC for sys svc */
11315     if (VMSISH_TIME) {
11316       utc_utimes.actime = _toutc(utimes->actime);
11317       utc_utimes.modtime = _toutc(utimes->modtime);
11318     }
11319 # endif
11320     utc_utimesp = &utc_utimes;
11321   }
11322   else {
11323     utc_utimesp = NULL;
11324   }
11325
11326   return utime(file, utc_utimesp);
11327
11328 #else /* __CRTL_VER < 70300000 */
11329
11330   register int i;
11331   int sts;
11332   long int bintime[2], len = 2, lowbit, unixtime,
11333            secscale = 10000000; /* seconds --> 100 ns intervals */
11334   unsigned long int chan, iosb[2], retsts;
11335   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11336   struct FAB myfab = cc$rms_fab;
11337   struct NAM mynam = cc$rms_nam;
11338 #if defined (__DECC) && defined (__VAX)
11339   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11340    * at least through VMS V6.1, which causes a type-conversion warning.
11341    */
11342 #  pragma message save
11343 #  pragma message disable cvtdiftypes
11344 #endif
11345   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11346   struct fibdef myfib;
11347 #if defined (__DECC) && defined (__VAX)
11348   /* This should be right after the declaration of myatr, but due
11349    * to a bug in VAX DEC C, this takes effect a statement early.
11350    */
11351 #  pragma message restore
11352 #endif
11353   /* cast ok for read only parameter */
11354   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11355                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11356                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
11357
11358   if (file == NULL || *file == '\0') {
11359     SETERRNO(ENOENT, LIB$_INVARG);
11360     return -1;
11361   }
11362
11363   /* Convert to VMS format ensuring that it will fit in 255 characters */
11364   if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
11365       SETERRNO(ENOENT, LIB$_INVARG);
11366       return -1;
11367   }
11368   if (utimes != NULL) {
11369     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
11370      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11371      * Since time_t is unsigned long int, and lib$emul takes a signed long int
11372      * as input, we force the sign bit to be clear by shifting unixtime right
11373      * one bit, then multiplying by an extra factor of 2 in lib$emul().
11374      */
11375     lowbit = (utimes->modtime & 1) ? secscale : 0;
11376     unixtime = (long int) utimes->modtime;
11377 #   ifdef VMSISH_TIME
11378     /* If input was UTC; convert to local for sys svc */
11379     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
11380 #   endif
11381     unixtime >>= 1;  secscale <<= 1;
11382     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11383     if (!(retsts & 1)) {
11384       SETERRNO(EVMSERR, retsts);
11385       return -1;
11386     }
11387     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11388     if (!(retsts & 1)) {
11389       SETERRNO(EVMSERR, retsts);
11390       return -1;
11391     }
11392   }
11393   else {
11394     /* Just get the current time in VMS format directly */
11395     retsts = sys$gettim(bintime);
11396     if (!(retsts & 1)) {
11397       SETERRNO(EVMSERR, retsts);
11398       return -1;
11399     }
11400   }
11401
11402   myfab.fab$l_fna = vmsspec;
11403   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11404   myfab.fab$l_nam = &mynam;
11405   mynam.nam$l_esa = esa;
11406   mynam.nam$b_ess = (unsigned char) sizeof esa;
11407   mynam.nam$l_rsa = rsa;
11408   mynam.nam$b_rss = (unsigned char) sizeof rsa;
11409   if (decc_efs_case_preserve)
11410       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
11411
11412   /* Look for the file to be affected, letting RMS parse the file
11413    * specification for us as well.  I have set errno using only
11414    * values documented in the utime() man page for VMS POSIX.
11415    */
11416   retsts = sys$parse(&myfab,0,0);
11417   if (!(retsts & 1)) {
11418     set_vaxc_errno(retsts);
11419     if      (retsts == RMS$_PRV) set_errno(EACCES);
11420     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11421     else                         set_errno(EVMSERR);
11422     return -1;
11423   }
11424   retsts = sys$search(&myfab,0,0);
11425   if (!(retsts & 1)) {
11426     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11427     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11428     set_vaxc_errno(retsts);
11429     if      (retsts == RMS$_PRV) set_errno(EACCES);
11430     else if (retsts == RMS$_FNF) set_errno(ENOENT);
11431     else                         set_errno(EVMSERR);
11432     return -1;
11433   }
11434
11435   devdsc.dsc$w_length = mynam.nam$b_dev;
11436   /* cast ok for read only parameter */
11437   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11438
11439   retsts = sys$assign(&devdsc,&chan,0,0);
11440   if (!(retsts & 1)) {
11441     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11442     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11443     set_vaxc_errno(retsts);
11444     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
11445     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
11446     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
11447     else                               set_errno(EVMSERR);
11448     return -1;
11449   }
11450
11451   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11452   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11453
11454   memset((void *) &myfib, 0, sizeof myfib);
11455 #if defined(__DECC) || defined(__DECCXX)
11456   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11457   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11458   /* This prevents the revision time of the file being reset to the current
11459    * time as a result of our IO$_MODIFY $QIO. */
11460   myfib.fib$l_acctl = FIB$M_NORECORD;
11461 #else
11462   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11463   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11464   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11465 #endif
11466   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
11467   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11468   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11469   _ckvmssts(sys$dassgn(chan));
11470   if (retsts & 1) retsts = iosb[0];
11471   if (!(retsts & 1)) {
11472     set_vaxc_errno(retsts);
11473     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11474     else                      set_errno(EVMSERR);
11475     return -1;
11476   }
11477
11478   return 0;
11479
11480 #endif /* #if __CRTL_VER >= 70300000 */
11481
11482 }  /* end of my_utime() */
11483 /*}}}*/
11484
11485 /*
11486  * flex_stat, flex_lstat, flex_fstat
11487  * basic stat, but gets it right when asked to stat
11488  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11489  */
11490
11491 #ifndef _USE_STD_STAT
11492 /* encode_dev packs a VMS device name string into an integer to allow
11493  * simple comparisons. This can be used, for example, to check whether two
11494  * files are located on the same device, by comparing their encoded device
11495  * names. Even a string comparison would not do, because stat() reuses the
11496  * device name buffer for each call; so without encode_dev, it would be
11497  * necessary to save the buffer and use strcmp (this would mean a number of
11498  * changes to the standard Perl code, to say nothing of what a Perl script
11499  * would have to do.
11500  *
11501  * The device lock id, if it exists, should be unique (unless perhaps compared
11502  * with lock ids transferred from other nodes). We have a lock id if the disk is
11503  * mounted cluster-wide, which is when we tend to get long (host-qualified)
11504  * device names. Thus we use the lock id in preference, and only if that isn't
11505  * available, do we try to pack the device name into an integer (flagged by
11506  * the sign bit (LOCKID_MASK) being set).
11507  *
11508  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11509  * name and its encoded form, but it seems very unlikely that we will find
11510  * two files on different disks that share the same encoded device names,
11511  * and even more remote that they will share the same file id (if the test
11512  * is to check for the same file).
11513  *
11514  * A better method might be to use sys$device_scan on the first call, and to
11515  * search for the device, returning an index into the cached array.
11516  * The number returned would be more intelligible.
11517  * This is probably not worth it, and anyway would take quite a bit longer
11518  * on the first call.
11519  */
11520 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
11521 static mydev_t encode_dev (pTHX_ const char *dev)
11522 {
11523   int i;
11524   unsigned long int f;
11525   mydev_t enc;
11526   char c;
11527   const char *q;
11528
11529   if (!dev || !dev[0]) return 0;
11530
11531 #if LOCKID_MASK
11532   {
11533     struct dsc$descriptor_s dev_desc;
11534     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11535
11536     /* For cluster-mounted disks, the disk lock identifier is unique, so we
11537        can try that first. */
11538     dev_desc.dsc$w_length =  strlen (dev);
11539     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
11540     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
11541     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
11542     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11543     if (!$VMS_STATUS_SUCCESS(status)) {
11544       switch (status) {
11545         case SS$_NOSUCHDEV:
11546           SETERRNO(ENODEV, status);
11547           return 0;
11548         default:
11549           _ckvmssts(status);
11550       }
11551     }
11552     if (lockid) return (lockid & ~LOCKID_MASK);
11553   }
11554 #endif
11555
11556   /* Otherwise we try to encode the device name */
11557   enc = 0;
11558   f = 1;
11559   i = 0;
11560   for (q = dev + strlen(dev); q--; q >= dev) {
11561     if (*q == ':')
11562         break;
11563     if (isdigit (*q))
11564       c= (*q) - '0';
11565     else if (isalpha (toupper (*q)))
11566       c= toupper (*q) - 'A' + (char)10;
11567     else
11568       continue; /* Skip '$'s */
11569     i++;
11570     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
11571     if (i>1) f *= 36;
11572     enc += f * (unsigned long int) c;
11573   }
11574   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
11575
11576 }  /* end of encode_dev() */
11577 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11578         device_no = encode_dev(aTHX_ devname)
11579 #else
11580 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11581         device_no = new_dev_no
11582 #endif
11583
11584 static int
11585 is_null_device(name)
11586     const char *name;
11587 {
11588   if (decc_bug_devnull != 0) {
11589     if (strncmp("/dev/null", name, 9) == 0)
11590       return 1;
11591   }
11592     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11593        The underscore prefix, controller letter, and unit number are
11594        independently optional; for our purposes, the colon punctuation
11595        is not.  The colon can be trailed by optional directory and/or
11596        filename, but two consecutive colons indicates a nodename rather
11597        than a device.  [pr]  */
11598   if (*name == '_') ++name;
11599   if (tolower(*name++) != 'n') return 0;
11600   if (tolower(*name++) != 'l') return 0;
11601   if (tolower(*name) == 'a') ++name;
11602   if (*name == '0') ++name;
11603   return (*name++ == ':') && (*name != ':');
11604 }
11605
11606
11607 static I32
11608 Perl_cando_by_name_int
11609    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
11610 {
11611   char usrname[L_cuserid];
11612   struct dsc$descriptor_s usrdsc =
11613          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11614   char *vmsname = NULL, *fileified = NULL;
11615   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11616   unsigned short int retlen, trnlnm_iter_count;
11617   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11618   union prvdef curprv;
11619   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11620          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11621          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11622   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11623          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11624          {0,0,0,0}};
11625   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11626          {0,0,0,0}};
11627   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11628   Stat_t st;
11629   static int profile_context = -1;
11630
11631   if (!fname || !*fname) return FALSE;
11632
11633   /* Make sure we expand logical names, since sys$check_access doesn't */
11634   fileified = PerlMem_malloc(VMS_MAXRSS);
11635   if (fileified == NULL) _ckvmssts(SS$_INSFMEM);
11636   if (!strpbrk(fname,"/]>:")) {
11637       strcpy(fileified,fname);
11638       trnlnm_iter_count = 0;
11639       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11640         trnlnm_iter_count++;
11641         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11642       }
11643       fname = fileified;
11644   }
11645
11646   vmsname = PerlMem_malloc(VMS_MAXRSS);
11647   if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
11648   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11649     /* Don't know if already in VMS format, so make sure */
11650     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11651       PerlMem_free(fileified);
11652       PerlMem_free(vmsname);
11653       return FALSE;
11654     }
11655   }
11656   else {
11657     strcpy(vmsname,fname);
11658   }
11659
11660   /* sys$check_access needs a file spec, not a directory spec.
11661    * Don't use flex_stat here, as that depends on thread context
11662    * having been initialized, and we may get here during startup.
11663    */
11664
11665   retlen = namdsc.dsc$w_length = strlen(vmsname);
11666   if (vmsname[retlen-1] == ']'
11667       || vmsname[retlen-1] == '>'
11668       || vmsname[retlen-1] == ':'
11669       || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
11670
11671       if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) {
11672         PerlMem_free(fileified);
11673         PerlMem_free(vmsname);
11674         return FALSE;
11675       }
11676       fname = fileified;
11677   }
11678   else {
11679       fname = vmsname;
11680   }
11681
11682   retlen = namdsc.dsc$w_length = strlen(fname);
11683   namdsc.dsc$a_pointer = (char *)fname;
11684
11685   switch (bit) {
11686     case S_IXUSR: case S_IXGRP: case S_IXOTH:
11687       access = ARM$M_EXECUTE;
11688       flags = CHP$M_READ;
11689       break;
11690     case S_IRUSR: case S_IRGRP: case S_IROTH:
11691       access = ARM$M_READ;
11692       flags = CHP$M_READ | CHP$M_USEREADALL;
11693       break;
11694     case S_IWUSR: case S_IWGRP: case S_IWOTH:
11695       access = ARM$M_WRITE;
11696       flags = CHP$M_READ | CHP$M_WRITE;
11697       break;
11698     case S_IDUSR: case S_IDGRP: case S_IDOTH:
11699       access = ARM$M_DELETE;
11700       flags = CHP$M_READ | CHP$M_WRITE;
11701       break;
11702     default:
11703       if (fileified != NULL)
11704         PerlMem_free(fileified);
11705       if (vmsname != NULL)
11706         PerlMem_free(vmsname);
11707       return FALSE;
11708   }
11709
11710   /* Before we call $check_access, create a user profile with the current
11711    * process privs since otherwise it just uses the default privs from the
11712    * UAF and might give false positives or negatives.  This only works on
11713    * VMS versions v6.0 and later since that's when sys$create_user_profile
11714    * became available.
11715    */
11716
11717   /* get current process privs and username */
11718   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11719   _ckvmssts(iosb[0]);
11720
11721 #if defined(__VMS_VER) && __VMS_VER >= 60000000
11722
11723   /* find out the space required for the profile */
11724   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11725                                     &usrprodsc.dsc$w_length,&profile_context));
11726
11727   /* allocate space for the profile and get it filled in */
11728   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11729   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
11730   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11731                                     &usrprodsc.dsc$w_length,&profile_context));
11732
11733   /* use the profile to check access to the file; free profile & analyze results */
11734   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
11735   PerlMem_free(usrprodsc.dsc$a_pointer);
11736   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11737
11738 #else
11739
11740   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11741
11742 #endif
11743
11744   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
11745       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11746       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11747     set_vaxc_errno(retsts);
11748     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11749     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11750     else set_errno(ENOENT);
11751     if (fileified != NULL)
11752       PerlMem_free(fileified);
11753     if (vmsname != NULL)
11754       PerlMem_free(vmsname);
11755     return FALSE;
11756   }
11757   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11758     if (fileified != NULL)
11759       PerlMem_free(fileified);
11760     if (vmsname != NULL)
11761       PerlMem_free(vmsname);
11762     return TRUE;
11763   }
11764   _ckvmssts(retsts);
11765
11766   if (fileified != NULL)
11767     PerlMem_free(fileified);
11768   if (vmsname != NULL)
11769     PerlMem_free(vmsname);
11770   return FALSE;  /* Should never get here */
11771
11772 }
11773
11774 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
11775 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11776  * subset of the applicable information.
11777  */
11778 bool
11779 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11780 {
11781   return cando_by_name_int
11782         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11783 }  /* end of cando() */
11784 /*}}}*/
11785
11786
11787 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11788 I32
11789 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11790 {
11791    return cando_by_name_int(bit, effective, fname, 0);
11792
11793 }  /* end of cando_by_name() */
11794 /*}}}*/
11795
11796
11797 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
11798 int
11799 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
11800 {
11801   if (!fstat(fd,(stat_t *) statbufp)) {
11802     char *cptr;
11803     char *vms_filename;
11804     vms_filename = PerlMem_malloc(VMS_MAXRSS);
11805     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
11806
11807     /* Save name for cando by name in VMS format */
11808     cptr = getname(fd, vms_filename, 1);
11809
11810     /* This should not happen, but just in case */
11811     if (cptr == NULL) {
11812         statbufp->st_devnam[0] = 0;
11813     }
11814     else {
11815         /* Make sure that the saved name fits in 255 characters */
11816         cptr = do_rmsexpand
11817                        (vms_filename,
11818                         statbufp->st_devnam,
11819                         0,
11820                         NULL,
11821                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
11822                         NULL,
11823                         NULL);
11824         if (cptr == NULL)
11825             statbufp->st_devnam[0] = 0;
11826     }
11827     PerlMem_free(vms_filename);
11828
11829     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11830     VMS_DEVICE_ENCODE
11831         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11832
11833 #   ifdef RTL_USES_UTC
11834 #   ifdef VMSISH_TIME
11835     if (VMSISH_TIME) {
11836       statbufp->st_mtime = _toloc(statbufp->st_mtime);
11837       statbufp->st_atime = _toloc(statbufp->st_atime);
11838       statbufp->st_ctime = _toloc(statbufp->st_ctime);
11839     }
11840 #   endif
11841 #   else
11842 #   ifdef VMSISH_TIME
11843     if (!VMSISH_TIME) { /* Return UTC instead of local time */
11844 #   else
11845     if (1) {
11846 #   endif
11847       statbufp->st_mtime = _toutc(statbufp->st_mtime);
11848       statbufp->st_atime = _toutc(statbufp->st_atime);
11849       statbufp->st_ctime = _toutc(statbufp->st_ctime);
11850     }
11851 #endif
11852     return 0;
11853   }
11854   return -1;
11855
11856 }  /* end of flex_fstat() */
11857 /*}}}*/
11858
11859 #if !defined(__VAX) && __CRTL_VER >= 80200000
11860 #ifdef lstat
11861 #undef lstat
11862 #endif
11863 #else
11864 #ifdef lstat
11865 #undef lstat
11866 #endif
11867 #define lstat(_x, _y) stat(_x, _y)
11868 #endif
11869
11870 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11871
11872 static int
11873 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
11874 {
11875     char fileified[VMS_MAXRSS];
11876     char temp_fspec[VMS_MAXRSS];
11877     char *save_spec;
11878     int retval = -1;
11879     int saved_errno, saved_vaxc_errno;
11880
11881     if (!fspec) return retval;
11882     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
11883     strcpy(temp_fspec, fspec);
11884
11885     if (decc_bug_devnull != 0) {
11886       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
11887         memset(statbufp,0,sizeof *statbufp);
11888         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
11889         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
11890         statbufp->st_uid = 0x00010001;
11891         statbufp->st_gid = 0x0001;
11892         time((time_t *)&statbufp->st_mtime);
11893         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
11894         return 0;
11895       }
11896     }
11897
11898     /* Try for a directory name first.  If fspec contains a filename without
11899      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
11900      * and sea:[wine.dark]water. exist, we prefer the directory here.
11901      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
11902      * not sea:[wine.dark]., if the latter exists.  If the intended target is
11903      * the file with null type, specify this by calling flex_stat() with
11904      * a '.' at the end of fspec.
11905      *
11906      * If we are in Posix filespec mode, accept the filename as is.
11907      */
11908
11909
11910 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11911   /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
11912    * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
11913    */
11914   if (!decc_efs_charset)
11915     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
11916 #endif
11917
11918 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11919   if (decc_posix_compliant_pathnames == 0) {
11920 #endif
11921     if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
11922       if (lstat_flag == 0)
11923         retval = stat(fileified,(stat_t *) statbufp);
11924       else
11925         retval = lstat(fileified,(stat_t *) statbufp);
11926       save_spec = fileified;
11927     }
11928     if (retval) {
11929       if (lstat_flag == 0)
11930         retval = stat(temp_fspec,(stat_t *) statbufp);
11931       else
11932         retval = lstat(temp_fspec,(stat_t *) statbufp);
11933       save_spec = temp_fspec;
11934     }
11935 /*
11936  * In debugging, on 8.3 Alpha, I found a case where stat was returning a
11937  * file not found error for a directory named foo:[bar.t] or /foo/bar/t
11938  * and lstat was working correctly for the same file.
11939  * The only syntax that was working for stat was "foo:[bar]t.dir".
11940  *
11941  * Other directories with the same syntax worked fine.
11942  * So work around the problem when it shows up here.
11943  */
11944     if (retval) {
11945         int save_errno = errno;
11946         if (do_tovmsspec(fspec, temp_fspec, 0, NULL) != NULL) {
11947             if (do_fileify_dirspec(temp_fspec, fileified, 0, NULL) != NULL) {
11948                 retval = stat(fileified, (stat_t *) statbufp);
11949                 save_spec = fileified;
11950             }
11951         }
11952         /* Restore the errno value if third stat does not succeed */
11953         if (retval != 0)
11954             errno = save_errno;
11955     }
11956 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11957   } else {
11958     if (lstat_flag == 0)
11959       retval = stat(temp_fspec,(stat_t *) statbufp);
11960     else
11961       retval = lstat(temp_fspec,(stat_t *) statbufp);
11962       save_spec = temp_fspec;
11963   }
11964 #endif
11965
11966 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11967   /* As you were... */
11968   if (!decc_efs_charset)
11969     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
11970 #endif
11971
11972     if (!retval) {
11973     char * cptr;
11974     int rmsex_flags = PERL_RMSEXPAND_M_VMS;
11975
11976       /* If this is an lstat, do not follow the link */
11977       if (lstat_flag)
11978         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
11979
11980       cptr = do_rmsexpand
11981        (save_spec, statbufp->st_devnam, 0, NULL, rmsex_flags, NULL, NULL);
11982       if (cptr == NULL)
11983         statbufp->st_devnam[0] = 0;
11984
11985       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11986       VMS_DEVICE_ENCODE
11987         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11988 #     ifdef RTL_USES_UTC
11989 #     ifdef VMSISH_TIME
11990       if (VMSISH_TIME) {
11991         statbufp->st_mtime = _toloc(statbufp->st_mtime);
11992         statbufp->st_atime = _toloc(statbufp->st_atime);
11993         statbufp->st_ctime = _toloc(statbufp->st_ctime);
11994       }
11995 #     endif
11996 #     else
11997 #     ifdef VMSISH_TIME
11998       if (!VMSISH_TIME) { /* Return UTC instead of local time */
11999 #     else
12000       if (1) {
12001 #     endif
12002         statbufp->st_mtime = _toutc(statbufp->st_mtime);
12003         statbufp->st_atime = _toutc(statbufp->st_atime);
12004         statbufp->st_ctime = _toutc(statbufp->st_ctime);
12005       }
12006 #     endif
12007     }
12008     /* If we were successful, leave errno where we found it */
12009     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
12010     return retval;
12011
12012 }  /* end of flex_stat_int() */
12013
12014
12015 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12016 int
12017 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12018 {
12019    return flex_stat_int(fspec, statbufp, 0);
12020 }
12021 /*}}}*/
12022
12023 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12024 int
12025 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12026 {
12027    return flex_stat_int(fspec, statbufp, 1);
12028 }
12029 /*}}}*/
12030
12031
12032 /*{{{char *my_getlogin()*/
12033 /* VMS cuserid == Unix getlogin, except calling sequence */
12034 char *
12035 my_getlogin(void)
12036 {
12037     static char user[L_cuserid];
12038     return cuserid(user);
12039 }
12040 /*}}}*/
12041
12042
12043 /*  rmscopy - copy a file using VMS RMS routines
12044  *
12045  *  Copies contents and attributes of spec_in to spec_out, except owner
12046  *  and protection information.  Name and type of spec_in are used as
12047  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
12048  *  should try to propagate timestamps from the input file to the output file.
12049  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
12050  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
12051  *  propagated to the output file at creation iff the output file specification
12052  *  did not contain an explicit name or type, and the revision date is always
12053  *  updated at the end of the copy operation.  If it is greater than 0, then
12054  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12055  *  other than the revision date should be propagated, and bit 1 indicates
12056  *  that the revision date should be propagated.
12057  *
12058  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12059  *
12060  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12061  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
12062  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
12063  * as part of the Perl standard distribution under the terms of the
12064  * GNU General Public License or the Perl Artistic License.  Copies
12065  * of each may be found in the Perl standard distribution.
12066  */ /* FIXME */
12067 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12068 int
12069 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12070 {
12071     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12072          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12073     unsigned long int i, sts, sts2;
12074     int dna_len;
12075     struct FAB fab_in, fab_out;
12076     struct RAB rab_in, rab_out;
12077     rms_setup_nam(nam);
12078     rms_setup_nam(nam_out);
12079     struct XABDAT xabdat;
12080     struct XABFHC xabfhc;
12081     struct XABRDT xabrdt;
12082     struct XABSUM xabsum;
12083
12084     vmsin = PerlMem_malloc(VMS_MAXRSS);
12085     if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
12086     vmsout = PerlMem_malloc(VMS_MAXRSS);
12087     if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
12088     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
12089         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
12090       PerlMem_free(vmsin);
12091       PerlMem_free(vmsout);
12092       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12093       return 0;
12094     }
12095
12096     esa = PerlMem_malloc(VMS_MAXRSS);
12097     if (esa == NULL) _ckvmssts(SS$_INSFMEM);
12098     esal = NULL;
12099 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12100     esal = PerlMem_malloc(VMS_MAXRSS);
12101     if (esal == NULL) _ckvmssts(SS$_INSFMEM);
12102 #endif
12103     fab_in = cc$rms_fab;
12104     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12105     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12106     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12107     fab_in.fab$l_fop = FAB$M_SQO;
12108     rms_bind_fab_nam(fab_in, nam);
12109     fab_in.fab$l_xab = (void *) &xabdat;
12110
12111     rsa = PerlMem_malloc(VMS_MAXRSS);
12112     if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
12113     rsal = NULL;
12114 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12115     rsal = PerlMem_malloc(VMS_MAXRSS);
12116     if (rsal == NULL) _ckvmssts(SS$_INSFMEM);
12117 #endif
12118     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12119     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12120     rms_nam_esl(nam) = 0;
12121     rms_nam_rsl(nam) = 0;
12122     rms_nam_esll(nam) = 0;
12123     rms_nam_rsll(nam) = 0;
12124 #ifdef NAM$M_NO_SHORT_UPCASE
12125     if (decc_efs_case_preserve)
12126         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12127 #endif
12128
12129     xabdat = cc$rms_xabdat;        /* To get creation date */
12130     xabdat.xab$l_nxt = (void *) &xabfhc;
12131
12132     xabfhc = cc$rms_xabfhc;        /* To get record length */
12133     xabfhc.xab$l_nxt = (void *) &xabsum;
12134
12135     xabsum = cc$rms_xabsum;        /* To get key and area information */
12136
12137     if (!((sts = sys$open(&fab_in)) & 1)) {
12138       PerlMem_free(vmsin);
12139       PerlMem_free(vmsout);
12140       PerlMem_free(esa);
12141       if (esal != NULL)
12142         PerlMem_free(esal);
12143       PerlMem_free(rsa);
12144       if (rsal != NULL)
12145         PerlMem_free(rsal);
12146       set_vaxc_errno(sts);
12147       switch (sts) {
12148         case RMS$_FNF: case RMS$_DNF:
12149           set_errno(ENOENT); break;
12150         case RMS$_DIR:
12151           set_errno(ENOTDIR); break;
12152         case RMS$_DEV:
12153           set_errno(ENODEV); break;
12154         case RMS$_SYN:
12155           set_errno(EINVAL); break;
12156         case RMS$_PRV:
12157           set_errno(EACCES); break;
12158         default:
12159           set_errno(EVMSERR);
12160       }
12161       return 0;
12162     }
12163
12164     nam_out = nam;
12165     fab_out = fab_in;
12166     fab_out.fab$w_ifi = 0;
12167     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12168     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12169     fab_out.fab$l_fop = FAB$M_SQO;
12170     rms_bind_fab_nam(fab_out, nam_out);
12171     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12172     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12173     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12174     esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12175     if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
12176     rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12177     if (rsa_out == NULL) _ckvmssts(SS$_INSFMEM);
12178     esal_out = NULL;
12179     rsal_out = NULL;
12180 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12181     esal_out = PerlMem_malloc(VMS_MAXRSS);
12182     if (esal_out == NULL) _ckvmssts(SS$_INSFMEM);
12183     rsal_out = PerlMem_malloc(VMS_MAXRSS);
12184     if (rsal_out == NULL) _ckvmssts(SS$_INSFMEM);
12185 #endif
12186     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12187     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12188
12189     if (preserve_dates == 0) {  /* Act like DCL COPY */
12190       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12191       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
12192       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12193         PerlMem_free(vmsin);
12194         PerlMem_free(vmsout);
12195         PerlMem_free(esa);
12196         if (esal != NULL)
12197             PerlMem_free(esal);
12198         PerlMem_free(rsa);
12199         if (rsal != NULL)
12200             PerlMem_free(rsal);
12201         PerlMem_free(esa_out);
12202         if (esal_out != NULL)
12203             PerlMem_free(esal_out);
12204         PerlMem_free(rsa_out);
12205         if (rsal_out != NULL)
12206             PerlMem_free(rsal_out);
12207         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12208         set_vaxc_errno(sts);
12209         return 0;
12210       }
12211       fab_out.fab$l_xab = (void *) &xabdat;
12212       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12213         preserve_dates = 1;
12214     }
12215     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
12216       preserve_dates =0;      /* bitmask from this point forward   */
12217
12218     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12219     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12220       PerlMem_free(vmsin);
12221       PerlMem_free(vmsout);
12222       PerlMem_free(esa);
12223       if (esal != NULL)
12224           PerlMem_free(esal);
12225       PerlMem_free(rsa);
12226       if (rsal != NULL)
12227           PerlMem_free(rsal);
12228       PerlMem_free(esa_out);
12229       if (esal_out != NULL)
12230           PerlMem_free(esal_out);
12231       PerlMem_free(rsa_out);
12232       if (rsal_out != NULL)
12233           PerlMem_free(rsal_out);
12234       set_vaxc_errno(sts);
12235       switch (sts) {
12236         case RMS$_DNF:
12237           set_errno(ENOENT); break;
12238         case RMS$_DIR:
12239           set_errno(ENOTDIR); break;
12240         case RMS$_DEV:
12241           set_errno(ENODEV); break;
12242         case RMS$_SYN:
12243           set_errno(EINVAL); break;
12244         case RMS$_PRV:
12245           set_errno(EACCES); break;
12246         default:
12247           set_errno(EVMSERR);
12248       }
12249       return 0;
12250     }
12251     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
12252     if (preserve_dates & 2) {
12253       /* sys$close() will process xabrdt, not xabdat */
12254       xabrdt = cc$rms_xabrdt;
12255 #ifndef __GNUC__
12256       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12257 #else
12258       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12259        * is unsigned long[2], while DECC & VAXC use a struct */
12260       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12261 #endif
12262       fab_out.fab$l_xab = (void *) &xabrdt;
12263     }
12264
12265     ubf = PerlMem_malloc(32256);
12266     if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
12267     rab_in = cc$rms_rab;
12268     rab_in.rab$l_fab = &fab_in;
12269     rab_in.rab$l_rop = RAB$M_BIO;
12270     rab_in.rab$l_ubf = ubf;
12271     rab_in.rab$w_usz = 32256;
12272     if (!((sts = sys$connect(&rab_in)) & 1)) {
12273       sys$close(&fab_in); sys$close(&fab_out);
12274       PerlMem_free(vmsin);
12275       PerlMem_free(vmsout);
12276       PerlMem_free(ubf);
12277       PerlMem_free(esa);
12278       if (esal != NULL)
12279           PerlMem_free(esal);
12280       PerlMem_free(rsa);
12281       if (rsal != NULL)
12282           PerlMem_free(rsal);
12283       PerlMem_free(esa_out);
12284       if (esal_out != NULL)
12285           PerlMem_free(esal_out);
12286       PerlMem_free(rsa_out);
12287       if (rsal_out != NULL)
12288           PerlMem_free(rsal_out);
12289       set_errno(EVMSERR); set_vaxc_errno(sts);
12290       return 0;
12291     }
12292
12293     rab_out = cc$rms_rab;
12294     rab_out.rab$l_fab = &fab_out;
12295     rab_out.rab$l_rbf = ubf;
12296     if (!((sts = sys$connect(&rab_out)) & 1)) {
12297       sys$close(&fab_in); sys$close(&fab_out);
12298       PerlMem_free(vmsin);
12299       PerlMem_free(vmsout);
12300       PerlMem_free(ubf);
12301       PerlMem_free(esa);
12302       if (esal != NULL)
12303           PerlMem_free(esal);
12304       PerlMem_free(rsa);
12305       if (rsal != NULL)
12306           PerlMem_free(rsal);
12307       PerlMem_free(esa_out);
12308       if (esal_out != NULL)
12309           PerlMem_free(esal_out);
12310       PerlMem_free(rsa_out);
12311       if (rsal_out != NULL)
12312           PerlMem_free(rsal_out);
12313       set_errno(EVMSERR); set_vaxc_errno(sts);
12314       return 0;
12315     }
12316
12317     while ((sts = sys$read(&rab_in))) {  /* always true  */
12318       if (sts == RMS$_EOF) break;
12319       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12320       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12321         sys$close(&fab_in); sys$close(&fab_out);
12322         PerlMem_free(vmsin);
12323         PerlMem_free(vmsout);
12324         PerlMem_free(ubf);
12325         PerlMem_free(esa);
12326         if (esal != NULL)
12327             PerlMem_free(esal);
12328         PerlMem_free(rsa);
12329         if (rsal != NULL)
12330             PerlMem_free(rsal);
12331         PerlMem_free(esa_out);
12332         if (esal_out != NULL)
12333             PerlMem_free(esal_out);
12334         PerlMem_free(rsa_out);
12335         if (rsal_out != NULL)
12336             PerlMem_free(rsal_out);
12337         set_errno(EVMSERR); set_vaxc_errno(sts);
12338         return 0;
12339       }
12340     }
12341
12342
12343     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
12344     sys$close(&fab_in);  sys$close(&fab_out);
12345     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12346
12347     PerlMem_free(vmsin);
12348     PerlMem_free(vmsout);
12349     PerlMem_free(ubf);
12350     PerlMem_free(esa);
12351     if (esal != NULL)
12352         PerlMem_free(esal);
12353     PerlMem_free(rsa);
12354     if (rsal != NULL)
12355         PerlMem_free(rsal);
12356     PerlMem_free(esa_out);
12357     if (esal_out != NULL)
12358         PerlMem_free(esal_out);
12359     PerlMem_free(rsa_out);
12360     if (rsal_out != NULL)
12361         PerlMem_free(rsal_out);
12362
12363     if (!(sts & 1)) {
12364       set_errno(EVMSERR); set_vaxc_errno(sts);
12365       return 0;
12366     }
12367
12368     return 1;
12369
12370 }  /* end of rmscopy() */
12371 /*}}}*/
12372
12373
12374 /***  The following glue provides 'hooks' to make some of the routines
12375  * from this file available from Perl.  These routines are sufficiently
12376  * basic, and are required sufficiently early in the build process,
12377  * that's it's nice to have them available to miniperl as well as the
12378  * full Perl, so they're set up here instead of in an extension.  The
12379  * Perl code which handles importation of these names into a given
12380  * package lives in [.VMS]Filespec.pm in @INC.
12381  */
12382
12383 void
12384 rmsexpand_fromperl(pTHX_ CV *cv)
12385 {
12386   dXSARGS;
12387   char *fspec, *defspec = NULL, *rslt;
12388   STRLEN n_a;
12389   int fs_utf8, dfs_utf8;
12390
12391   fs_utf8 = 0;
12392   dfs_utf8 = 0;
12393   if (!items || items > 2)
12394     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12395   fspec = SvPV(ST(0),n_a);
12396   fs_utf8 = SvUTF8(ST(0));
12397   if (!fspec || !*fspec) XSRETURN_UNDEF;
12398   if (items == 2) {
12399     defspec = SvPV(ST(1),n_a);
12400     dfs_utf8 = SvUTF8(ST(1));
12401   }
12402   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12403   ST(0) = sv_newmortal();
12404   if (rslt != NULL) {
12405     sv_usepvn(ST(0),rslt,strlen(rslt));
12406     if (fs_utf8) {
12407         SvUTF8_on(ST(0));
12408     }
12409   }
12410   XSRETURN(1);
12411 }
12412
12413 void
12414 vmsify_fromperl(pTHX_ CV *cv)
12415 {
12416   dXSARGS;
12417   char *vmsified;
12418   STRLEN n_a;
12419   int utf8_fl;
12420
12421   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12422   utf8_fl = SvUTF8(ST(0));
12423   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12424   ST(0) = sv_newmortal();
12425   if (vmsified != NULL) {
12426     sv_usepvn(ST(0),vmsified,strlen(vmsified));
12427     if (utf8_fl) {
12428         SvUTF8_on(ST(0));
12429     }
12430   }
12431   XSRETURN(1);
12432 }
12433
12434 void
12435 unixify_fromperl(pTHX_ CV *cv)
12436 {
12437   dXSARGS;
12438   char *unixified;
12439   STRLEN n_a;
12440   int utf8_fl;
12441
12442   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12443   utf8_fl = SvUTF8(ST(0));
12444   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12445   ST(0) = sv_newmortal();
12446   if (unixified != NULL) {
12447     sv_usepvn(ST(0),unixified,strlen(unixified));
12448     if (utf8_fl) {
12449         SvUTF8_on(ST(0));
12450     }
12451   }
12452   XSRETURN(1);
12453 }
12454
12455 void
12456 fileify_fromperl(pTHX_ CV *cv)
12457 {
12458   dXSARGS;
12459   char *fileified;
12460   STRLEN n_a;
12461   int utf8_fl;
12462
12463   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12464   utf8_fl = SvUTF8(ST(0));
12465   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12466   ST(0) = sv_newmortal();
12467   if (fileified != NULL) {
12468     sv_usepvn(ST(0),fileified,strlen(fileified));
12469     if (utf8_fl) {
12470         SvUTF8_on(ST(0));
12471     }
12472   }
12473   XSRETURN(1);
12474 }
12475
12476 void
12477 pathify_fromperl(pTHX_ CV *cv)
12478 {
12479   dXSARGS;
12480   char *pathified;
12481   STRLEN n_a;
12482   int utf8_fl;
12483
12484   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12485   utf8_fl = SvUTF8(ST(0));
12486   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12487   ST(0) = sv_newmortal();
12488   if (pathified != NULL) {
12489     sv_usepvn(ST(0),pathified,strlen(pathified));
12490     if (utf8_fl) {
12491         SvUTF8_on(ST(0));
12492     }
12493   }
12494   XSRETURN(1);
12495 }
12496
12497 void
12498 vmspath_fromperl(pTHX_ CV *cv)
12499 {
12500   dXSARGS;
12501   char *vmspath;
12502   STRLEN n_a;
12503   int utf8_fl;
12504
12505   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12506   utf8_fl = SvUTF8(ST(0));
12507   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12508   ST(0) = sv_newmortal();
12509   if (vmspath != NULL) {
12510     sv_usepvn(ST(0),vmspath,strlen(vmspath));
12511     if (utf8_fl) {
12512         SvUTF8_on(ST(0));
12513     }
12514   }
12515   XSRETURN(1);
12516 }
12517
12518 void
12519 unixpath_fromperl(pTHX_ CV *cv)
12520 {
12521   dXSARGS;
12522   char *unixpath;
12523   STRLEN n_a;
12524   int utf8_fl;
12525
12526   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12527   utf8_fl = SvUTF8(ST(0));
12528   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12529   ST(0) = sv_newmortal();
12530   if (unixpath != NULL) {
12531     sv_usepvn(ST(0),unixpath,strlen(unixpath));
12532     if (utf8_fl) {
12533         SvUTF8_on(ST(0));
12534     }
12535   }
12536   XSRETURN(1);
12537 }
12538
12539 void
12540 candelete_fromperl(pTHX_ CV *cv)
12541 {
12542   dXSARGS;
12543   char *fspec, *fsp;
12544   SV *mysv;
12545   IO *io;
12546   STRLEN n_a;
12547
12548   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12549
12550   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12551   Newx(fspec, VMS_MAXRSS, char);
12552   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12553   if (SvTYPE(mysv) == SVt_PVGV) {
12554     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12555       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12556       ST(0) = &PL_sv_no;
12557       Safefree(fspec);
12558       XSRETURN(1);
12559     }
12560     fsp = fspec;
12561   }
12562   else {
12563     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12564       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12565       ST(0) = &PL_sv_no;
12566       Safefree(fspec);
12567       XSRETURN(1);
12568     }
12569   }
12570
12571   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12572   Safefree(fspec);
12573   XSRETURN(1);
12574 }
12575
12576 void
12577 rmscopy_fromperl(pTHX_ CV *cv)
12578 {
12579   dXSARGS;
12580   char *inspec, *outspec, *inp, *outp;
12581   int date_flag;
12582   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
12583                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12584   unsigned long int sts;
12585   SV *mysv;
12586   IO *io;
12587   STRLEN n_a;
12588
12589   if (items < 2 || items > 3)
12590     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12591
12592   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12593   Newx(inspec, VMS_MAXRSS, char);
12594   if (SvTYPE(mysv) == SVt_PVGV) {
12595     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12596       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12597       ST(0) = &PL_sv_no;
12598       Safefree(inspec);
12599       XSRETURN(1);
12600     }
12601     inp = inspec;
12602   }
12603   else {
12604     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12605       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12606       ST(0) = &PL_sv_no;
12607       Safefree(inspec);
12608       XSRETURN(1);
12609     }
12610   }
12611   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12612   Newx(outspec, VMS_MAXRSS, char);
12613   if (SvTYPE(mysv) == SVt_PVGV) {
12614     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12615       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12616       ST(0) = &PL_sv_no;
12617       Safefree(inspec);
12618       Safefree(outspec);
12619       XSRETURN(1);
12620     }
12621     outp = outspec;
12622   }
12623   else {
12624     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12625       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12626       ST(0) = &PL_sv_no;
12627       Safefree(inspec);
12628       Safefree(outspec);
12629       XSRETURN(1);
12630     }
12631   }
12632   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12633
12634   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
12635   Safefree(inspec);
12636   Safefree(outspec);
12637   XSRETURN(1);
12638 }
12639
12640 /* The mod2fname is limited to shorter filenames by design, so it should
12641  * not be modified to support longer EFS pathnames
12642  */
12643 void
12644 mod2fname(pTHX_ CV *cv)
12645 {
12646   dXSARGS;
12647   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12648        workbuff[NAM$C_MAXRSS*1 + 1];
12649   int total_namelen = 3, counter, num_entries;
12650   /* ODS-5 ups this, but we want to be consistent, so... */
12651   int max_name_len = 39;
12652   AV *in_array = (AV *)SvRV(ST(0));
12653
12654   num_entries = av_len(in_array);
12655
12656   /* All the names start with PL_. */
12657   strcpy(ultimate_name, "PL_");
12658
12659   /* Clean up our working buffer */
12660   Zero(work_name, sizeof(work_name), char);
12661
12662   /* Run through the entries and build up a working name */
12663   for(counter = 0; counter <= num_entries; counter++) {
12664     /* If it's not the first name then tack on a __ */
12665     if (counter) {
12666       strcat(work_name, "__");
12667     }
12668     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
12669                            PL_na));
12670   }
12671
12672   /* Check to see if we actually have to bother...*/
12673   if (strlen(work_name) + 3 <= max_name_len) {
12674     strcat(ultimate_name, work_name);
12675   } else {
12676     /* It's too darned big, so we need to go strip. We use the same */
12677     /* algorithm as xsubpp does. First, strip out doubled __ */
12678     char *source, *dest, last;
12679     dest = workbuff;
12680     last = 0;
12681     for (source = work_name; *source; source++) {
12682       if (last == *source && last == '_') {
12683         continue;
12684       }
12685       *dest++ = *source;
12686       last = *source;
12687     }
12688     /* Go put it back */
12689     strcpy(work_name, workbuff);
12690     /* Is it still too big? */
12691     if (strlen(work_name) + 3 > max_name_len) {
12692       /* Strip duplicate letters */
12693       last = 0;
12694       dest = workbuff;
12695       for (source = work_name; *source; source++) {
12696         if (last == toupper(*source)) {
12697         continue;
12698         }
12699         *dest++ = *source;
12700         last = toupper(*source);
12701       }
12702       strcpy(work_name, workbuff);
12703     }
12704
12705     /* Is it *still* too big? */
12706     if (strlen(work_name) + 3 > max_name_len) {
12707       /* Too bad, we truncate */
12708       work_name[max_name_len - 2] = 0;
12709     }
12710     strcat(ultimate_name, work_name);
12711   }
12712
12713   /* Okay, return it */
12714   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
12715   XSRETURN(1);
12716 }
12717
12718 void
12719 hushexit_fromperl(pTHX_ CV *cv)
12720 {
12721     dXSARGS;
12722
12723     if (items > 0) {
12724         VMSISH_HUSHED = SvTRUE(ST(0));
12725     }
12726     ST(0) = boolSV(VMSISH_HUSHED);
12727     XSRETURN(1);
12728 }
12729
12730
12731 PerlIO *
12732 Perl_vms_start_glob
12733    (pTHX_ SV *tmpglob,
12734     IO *io)
12735 {
12736     PerlIO *fp;
12737     struct vs_str_st *rslt;
12738     char *vmsspec;
12739     char *rstr;
12740     char *begin, *cp;
12741     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
12742     PerlIO *tmpfp;
12743     STRLEN i;
12744     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12745     struct dsc$descriptor_vs rsdsc;
12746     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
12747     unsigned long hasver = 0, isunix = 0;
12748     unsigned long int lff_flags = 0;
12749     int rms_sts;
12750
12751 #ifdef VMS_LONGNAME_SUPPORT
12752     lff_flags = LIB$M_FIL_LONG_NAMES;
12753 #endif
12754     /* The Newx macro will not allow me to assign a smaller array
12755      * to the rslt pointer, so we will assign it to the begin char pointer
12756      * and then copy the value into the rslt pointer.
12757      */
12758     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
12759     rslt = (struct vs_str_st *)begin;
12760     rslt->length = 0;
12761     rstr = &rslt->str[0];
12762     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
12763     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
12764     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
12765     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
12766
12767     Newx(vmsspec, VMS_MAXRSS, char);
12768
12769         /* We could find out if there's an explicit dev/dir or version
12770            by peeking into lib$find_file's internal context at
12771            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
12772            but that's unsupported, so I don't want to do it now and
12773            have it bite someone in the future. */
12774         /* Fix-me: vms_split_path() is the only way to do this, the
12775            existing method will fail with many legal EFS or UNIX specifications
12776          */
12777
12778     cp = SvPV(tmpglob,i);
12779
12780     for (; i; i--) {
12781         if (cp[i] == ';') hasver = 1;
12782         if (cp[i] == '.') {
12783             if (sts) hasver = 1;
12784             else sts = 1;
12785         }
12786         if (cp[i] == '/') {
12787             hasdir = isunix = 1;
12788             break;
12789         }
12790         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
12791             hasdir = 1;
12792             break;
12793         }
12794     }
12795     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
12796         int found = 0;
12797         Stat_t st;
12798         int stat_sts;
12799         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
12800         if (!stat_sts && S_ISDIR(st.st_mode)) {
12801             wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
12802             ok = (wilddsc.dsc$a_pointer != NULL);
12803             /* maybe passed 'foo' rather than '[.foo]', thus not detected above */
12804             hasdir = 1;
12805         }
12806         else {
12807             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
12808             ok = (wilddsc.dsc$a_pointer != NULL);
12809         }
12810         if (ok)
12811             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
12812
12813         /* If not extended character set, replace ? with % */
12814         /* With extended character set, ? is a wildcard single character */
12815         if (!decc_efs_case_preserve) {
12816             for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
12817                 if (*cp == '?') *cp = '%';
12818         }
12819         sts = SS$_NORMAL;
12820         while (ok && $VMS_STATUS_SUCCESS(sts)) {
12821          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
12822          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
12823
12824             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
12825                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
12826             if (!$VMS_STATUS_SUCCESS(sts))
12827                 break;
12828
12829             found++;
12830
12831             /* with varying string, 1st word of buffer contains result length */
12832             rstr[rslt->length] = '\0';
12833
12834              /* Find where all the components are */
12835              v_sts = vms_split_path
12836                        (rstr,
12837                         &v_spec,
12838                         &v_len,
12839                         &r_spec,
12840                         &r_len,
12841                         &d_spec,
12842                         &d_len,
12843                         &n_spec,
12844                         &n_len,
12845                         &e_spec,
12846                         &e_len,
12847                         &vs_spec,
12848                         &vs_len);
12849
12850             /* If no version on input, truncate the version on output */
12851             if (!hasver && (vs_len > 0)) {
12852                 *vs_spec = '\0';
12853                 vs_len = 0;
12854
12855                 /* No version & a null extension on UNIX handling */
12856                 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
12857                     e_len = 0;
12858                     *e_spec = '\0';
12859                 }
12860             }
12861
12862             if (!decc_efs_case_preserve) {
12863                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
12864             }
12865
12866             if (hasdir) {
12867                 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
12868                 begin = rstr;
12869             }
12870             else {
12871                 /* Start with the name */
12872                 begin = n_spec;
12873             }
12874             strcat(begin,"\n");
12875             ok = (PerlIO_puts(tmpfp,begin) != EOF);
12876         }
12877         if (cxt) (void)lib$find_file_end(&cxt);
12878
12879         if (!found) {
12880             /* Be POSIXish: return the input pattern when no matches */
12881             strcpy(rstr,SvPVX(tmpglob));
12882             strcat(rstr,"\n");
12883             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
12884         }
12885
12886         if (ok && sts != RMS$_NMF &&
12887             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
12888         if (!ok) {
12889             if (!(sts & 1)) {
12890                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
12891             }
12892             PerlIO_close(tmpfp);
12893             fp = NULL;
12894         }
12895         else {
12896             PerlIO_rewind(tmpfp);
12897             IoTYPE(io) = IoTYPE_RDONLY;
12898             IoIFP(io) = fp = tmpfp;
12899             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
12900         }
12901     }
12902     Safefree(vmsspec);
12903     Safefree(rslt);
12904     return fp;
12905 }
12906
12907
12908 static char *
12909 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
12910                    int *utf8_fl);
12911
12912 void
12913 vms_realpath_fromperl(pTHX_ CV *cv)
12914 {
12915     dXSARGS;
12916     char *fspec, *rslt_spec, *rslt;
12917     STRLEN n_a;
12918
12919     if (!items || items != 1)
12920         Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
12921
12922     fspec = SvPV(ST(0),n_a);
12923     if (!fspec || !*fspec) XSRETURN_UNDEF;
12924
12925     Newx(rslt_spec, VMS_MAXRSS + 1, char);
12926     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
12927
12928     ST(0) = sv_newmortal();
12929     if (rslt != NULL)
12930         sv_usepvn(ST(0),rslt,strlen(rslt));
12931     else
12932         Safefree(rslt_spec);
12933         XSRETURN(1);
12934 }
12935
12936 static char *
12937 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
12938                    int *utf8_fl);
12939
12940 void
12941 vms_realname_fromperl(pTHX_ CV *cv)
12942 {
12943     dXSARGS;
12944     char *fspec, *rslt_spec, *rslt;
12945     STRLEN n_a;
12946
12947     if (!items || items != 1)
12948         Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realname(spec)");
12949
12950     fspec = SvPV(ST(0),n_a);
12951     if (!fspec || !*fspec) XSRETURN_UNDEF;
12952
12953     Newx(rslt_spec, VMS_MAXRSS + 1, char);
12954     rslt = do_vms_realname(fspec, rslt_spec, NULL);
12955
12956     ST(0) = sv_newmortal();
12957     if (rslt != NULL)
12958         sv_usepvn(ST(0),rslt,strlen(rslt));
12959     else
12960         Safefree(rslt_spec);
12961         XSRETURN(1);
12962 }
12963
12964 #ifdef HAS_SYMLINK
12965 /*
12966  * A thin wrapper around decc$symlink to make sure we follow the
12967  * standard and do not create a symlink with a zero-length name.
12968  */
12969 /*{{{ int my_symlink(const char *path1, const char *path2)*/
12970 int my_symlink(const char *path1, const char *path2) {
12971   if (!path2 || !*path2) {
12972     SETERRNO(ENOENT, SS$_NOSUCHFILE);
12973     return -1;
12974   }
12975   return symlink(path1, path2);
12976 }
12977 /*}}}*/
12978
12979 #endif /* HAS_SYMLINK */
12980
12981 int do_vms_case_tolerant(void);
12982
12983 void
12984 vms_case_tolerant_fromperl(pTHX_ CV *cv)
12985 {
12986   dXSARGS;
12987   ST(0) = boolSV(do_vms_case_tolerant());
12988   XSRETURN(1);
12989 }
12990
12991 void
12992 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
12993                           struct interp_intern *dst)
12994 {
12995     memcpy(dst,src,sizeof(struct interp_intern));
12996 }
12997
12998 void
12999 Perl_sys_intern_clear(pTHX)
13000 {
13001 }
13002
13003 void
13004 Perl_sys_intern_init(pTHX)
13005 {
13006     unsigned int ix = RAND_MAX;
13007     double x;
13008
13009     VMSISH_HUSHED = 0;
13010
13011     /* fix me later to track running under GNV */
13012     /* this allows some limited testing */
13013     MY_POSIX_EXIT = decc_filename_unix_report;
13014
13015     x = (float)ix;
13016     MY_INV_RAND_MAX = 1./x;
13017 }
13018
13019 void
13020 init_os_extras(void)
13021 {
13022   dTHX;
13023   char* file = __FILE__;
13024   if (decc_disable_to_vms_logname_translation) {
13025     no_translate_barewords = TRUE;
13026   } else {
13027     no_translate_barewords = FALSE;
13028   }
13029
13030   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13031   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13032   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13033   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13034   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13035   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13036   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13037   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13038   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13039   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13040   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13041   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
13042   newXSproto("VMS::Filespec::vms_realname",vms_realname_fromperl,file,"$;$");
13043   newXSproto("VMS::Filepec::vms_case_tolerant",
13044              vms_case_tolerant_fromperl, file, "$");
13045
13046   store_pipelocs(aTHX);         /* will redo any earlier attempts */
13047
13048   return;
13049 }
13050
13051 #if __CRTL_VER == 80200000
13052 /* This missed getting in to the DECC SDK for 8.2 */
13053 char *realpath(const char *file_name, char * resolved_name, ...);
13054 #endif
13055
13056 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13057 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13058  * The perl fallback routine to provide realpath() is not as efficient
13059  * on OpenVMS.
13060  */
13061
13062 /* Hack, use old stat() as fastest way of getting ino_t and device */
13063 int decc$stat(const char *name, void * statbuf);
13064
13065
13066 /* Realpath is fragile.  In 8.3 it does not work if the feature
13067  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13068  * links are implemented in RMS, not the CRTL. It also can fail if the
13069  * user does not have read/execute access to some of the directories.
13070  * So in order for Do What I Mean mode to work, if realpath() fails,
13071  * fall back to looking up the filename by the device name and FID.
13072  */
13073
13074 int vms_fid_to_name(char * outname, int outlen, const char * name)
13075 {
13076 struct statbuf_t {
13077     char           * st_dev;
13078     unsigned short st_ino[3];
13079     unsigned short padw;
13080     unsigned long  padl[30];  /* plenty of room */
13081 } statbuf;
13082 int sts;
13083 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13084 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13085
13086     sts = decc$stat(name, &statbuf);
13087     if (sts == 0) {
13088
13089         dvidsc.dsc$a_pointer=statbuf.st_dev;
13090        dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13091
13092         specdsc.dsc$a_pointer = outname;
13093         specdsc.dsc$w_length = outlen-1;
13094
13095        sts = lib$fid_to_name
13096             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13097        if ($VMS_STATUS_SUCCESS(sts)) {
13098             outname[specdsc.dsc$w_length] = 0;
13099             return 0;
13100         }
13101     }
13102     return sts;
13103 }
13104
13105
13106
13107 static char *
13108 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13109                    int *utf8_fl)
13110 {
13111     char * rslt = NULL;
13112
13113 #ifdef HAS_SYMLINK
13114     if (decc_posix_compliant_pathnames > 0 ) {
13115         /* realpath currently only works if posix compliant pathnames are
13116          * enabled.  It may start working when they are not, but in that
13117          * case we still want the fallback behavior for backwards compatibility
13118          */
13119         rslt = realpath(filespec, outbuf);
13120     }
13121 #endif
13122
13123     if (rslt == NULL) {
13124         char * vms_spec;
13125         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13126         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13127         int file_len;
13128
13129         /* Fall back to fid_to_name */
13130
13131         Newx(vms_spec, VMS_MAXRSS + 1, char);
13132
13133          sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec);
13134          if (sts == 0) {
13135
13136
13137             /* Now need to trim the version off */
13138             sts = vms_split_path
13139                   (vms_spec,
13140                    &v_spec,
13141                    &v_len,
13142                    &r_spec,
13143                    &r_len,
13144                    &d_spec,
13145                    &d_len,
13146                    &n_spec,
13147                    &n_len,
13148                    &e_spec,
13149                    &e_len,
13150                    &vs_spec,
13151                    &vs_len);
13152
13153
13154              if (sts == 0) {
13155                 int file_len;
13156
13157                 /* Trim off the version */
13158                 file_len = v_len + r_len + d_len + n_len + e_len;
13159                 vms_spec[file_len] = 0;
13160
13161                 /* The result is expected to be in UNIX format */
13162                 rslt = do_tounixspec(vms_spec, outbuf, 0, utf8_fl);
13163              }
13164          }
13165
13166         Safefree(vms_spec);
13167     }
13168     return rslt;
13169 }
13170
13171 static char *
13172 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13173                    int *utf8_fl)
13174 {
13175     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13176     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13177     int file_len;
13178
13179     /* Fall back to fid_to_name */
13180
13181     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec);
13182     if (sts == 0) {
13183
13184
13185         /* Now need to trim the version off */
13186         sts = vms_split_path
13187                   (outbuf,
13188                    &v_spec,
13189                    &v_len,
13190                    &r_spec,
13191                    &r_len,
13192                    &d_spec,
13193                    &d_len,
13194                    &n_spec,
13195                    &n_len,
13196                    &e_spec,
13197                    &e_len,
13198                    &vs_spec,
13199                    &vs_len);
13200
13201
13202         if (sts == 0) {
13203             int file_len;
13204
13205         /* Trim off the version */
13206         file_len = v_len + r_len + d_len + n_len + e_len;
13207         outbuf[file_len] = 0;
13208         }
13209     }
13210     return outbuf;
13211 }
13212
13213
13214 /*}}}*/
13215 /* External entry points */
13216 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13217 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
13218
13219 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13220 { return do_vms_realname(filespec, outbuf, utf8_fl); }
13221
13222 /* case_tolerant */
13223
13224 /*{{{int do_vms_case_tolerant(void)*/
13225 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13226  * controlled by a process setting.
13227  */
13228 int do_vms_case_tolerant(void)
13229 {
13230     return vms_process_case_tolerant;
13231 }
13232 /*}}}*/
13233 /* External entry points */
13234 #if __CRTL_VER >= 70301000 && !defined(__VAX)
13235 int Perl_vms_case_tolerant(void)
13236 { return do_vms_case_tolerant(); }
13237 #else
13238 int Perl_vms_case_tolerant(void)
13239 { return vms_process_case_tolerant; }
13240 #endif
13241
13242
13243  /* Start of DECC RTL Feature handling */
13244
13245 static int sys_trnlnm
13246    (const char * logname,
13247     char * value,
13248     int value_len)
13249 {
13250     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
13251     const unsigned long attr = LNM$M_CASE_BLIND;
13252     struct dsc$descriptor_s name_dsc;
13253     int status;
13254     unsigned short result;
13255     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
13256                                 {0, 0, 0, 0}};
13257
13258     name_dsc.dsc$w_length = strlen(logname);
13259     name_dsc.dsc$a_pointer = (char *)logname;
13260     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13261     name_dsc.dsc$b_class = DSC$K_CLASS_S;
13262
13263     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
13264
13265     if ($VMS_STATUS_SUCCESS(status)) {
13266
13267          /* Null terminate and return the string */
13268         /*--------------------------------------*/
13269         value[result] = 0;
13270     }
13271
13272     return status;
13273 }
13274
13275 static int sys_crelnm
13276    (const char * logname,
13277     const char * value)
13278 {
13279     int ret_val;
13280     const char * proc_table = "LNM$PROCESS_TABLE";
13281     struct dsc$descriptor_s proc_table_dsc;
13282     struct dsc$descriptor_s logname_dsc;
13283     struct itmlst_3 item_list[2];
13284
13285     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
13286     proc_table_dsc.dsc$w_length = strlen(proc_table);
13287     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13288     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
13289
13290     logname_dsc.dsc$a_pointer = (char *) logname;
13291     logname_dsc.dsc$w_length = strlen(logname);
13292     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13293     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
13294
13295     item_list[0].buflen = strlen(value);
13296     item_list[0].itmcode = LNM$_STRING;
13297     item_list[0].bufadr = (char *)value;
13298     item_list[0].retlen = NULL;
13299
13300     item_list[1].buflen = 0;
13301     item_list[1].itmcode = 0;
13302
13303     ret_val = sys$crelnm
13304                        (NULL,
13305                         (const struct dsc$descriptor_s *)&proc_table_dsc,
13306                         (const struct dsc$descriptor_s *)&logname_dsc,
13307                         NULL,
13308                         (const struct item_list_3 *) item_list);
13309
13310     return ret_val;
13311 }
13312
13313 /* C RTL Feature settings */
13314
13315 static int set_features
13316    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
13317     int (* cli_routine)(void),  /* Not documented */
13318     void *image_info)           /* Not documented */
13319 {
13320     int status;
13321     int s;
13322     int dflt;
13323     char* str;
13324     char val_str[10];
13325 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13326     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13327     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13328     unsigned long case_perm;
13329     unsigned long case_image;
13330 #endif
13331
13332     /* Allow an exception to bring Perl into the VMS debugger */
13333     vms_debug_on_exception = 0;
13334     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
13335     if ($VMS_STATUS_SUCCESS(status)) {
13336        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13337          vms_debug_on_exception = 1;
13338        else
13339          vms_debug_on_exception = 0;
13340     }
13341
13342     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
13343     vms_vtf7_filenames = 0;
13344     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
13345     if ($VMS_STATUS_SUCCESS(status)) {
13346        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13347          vms_vtf7_filenames = 1;
13348        else
13349          vms_vtf7_filenames = 0;
13350     }
13351
13352
13353     /* unlink all versions on unlink() or rename() */
13354     vms_unlink_all_versions = 0;
13355     status = sys_trnlnm
13356         ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13357     if ($VMS_STATUS_SUCCESS(status)) {
13358        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13359          vms_unlink_all_versions = 1;
13360        else
13361          vms_unlink_all_versions = 0;
13362     }
13363
13364     /* Dectect running under GNV Bash or other UNIX like shell */
13365 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13366     gnv_unix_shell = 0;
13367     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
13368     if ($VMS_STATUS_SUCCESS(status)) {
13369        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13370          gnv_unix_shell = 1;
13371          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
13372          set_feature_default("DECC$EFS_CHARSET", 1);
13373          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
13374          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
13375          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
13376          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
13377          vms_unlink_all_versions = 1;
13378        }
13379        else
13380          gnv_unix_shell = 0;
13381     }
13382 #endif
13383
13384     /* hacks to see if known bugs are still present for testing */
13385
13386     /* Readdir is returning filenames in VMS syntax always */
13387     decc_bug_readdir_efs1 = 1;
13388     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
13389     if ($VMS_STATUS_SUCCESS(status)) {
13390        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13391          decc_bug_readdir_efs1 = 1;
13392        else
13393          decc_bug_readdir_efs1 = 0;
13394     }
13395
13396     /* PCP mode requires creating /dev/null special device file */
13397     decc_bug_devnull = 0;
13398     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
13399     if ($VMS_STATUS_SUCCESS(status)) {
13400        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13401           decc_bug_devnull = 1;
13402        else
13403           decc_bug_devnull = 0;
13404     }
13405
13406     /* fgetname returning a VMS name in UNIX mode */
13407     decc_bug_fgetname = 1;
13408     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
13409     if ($VMS_STATUS_SUCCESS(status)) {
13410       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13411         decc_bug_fgetname = 1;
13412       else
13413         decc_bug_fgetname = 0;
13414     }
13415
13416     /* UNIX directory names with no paths are broken in a lot of places */
13417     decc_dir_barename = 1;
13418     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
13419     if ($VMS_STATUS_SUCCESS(status)) {
13420       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13421         decc_dir_barename = 1;
13422       else
13423         decc_dir_barename = 0;
13424     }
13425
13426 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13427     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
13428     if (s >= 0) {
13429         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
13430         if (decc_disable_to_vms_logname_translation < 0)
13431             decc_disable_to_vms_logname_translation = 0;
13432     }
13433
13434     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
13435     if (s >= 0) {
13436         decc_efs_case_preserve = decc$feature_get_value(s, 1);
13437         if (decc_efs_case_preserve < 0)
13438             decc_efs_case_preserve = 0;
13439     }
13440
13441     s = decc$feature_get_index("DECC$EFS_CHARSET");
13442     if (s >= 0) {
13443         decc_efs_charset = decc$feature_get_value(s, 1);
13444         if (decc_efs_charset < 0)
13445             decc_efs_charset = 0;
13446     }
13447
13448     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
13449     if (s >= 0) {
13450         decc_filename_unix_report = decc$feature_get_value(s, 1);
13451         if (decc_filename_unix_report > 0)
13452             decc_filename_unix_report = 1;
13453         else
13454             decc_filename_unix_report = 0;
13455     }
13456
13457     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
13458     if (s >= 0) {
13459         decc_filename_unix_only = decc$feature_get_value(s, 1);
13460         if (decc_filename_unix_only > 0) {
13461             decc_filename_unix_only = 1;
13462         }
13463         else {
13464             decc_filename_unix_only = 0;
13465         }
13466     }
13467
13468     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
13469     if (s >= 0) {
13470         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
13471         if (decc_filename_unix_no_version < 0)
13472             decc_filename_unix_no_version = 0;
13473     }
13474
13475     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
13476     if (s >= 0) {
13477         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
13478         if (decc_readdir_dropdotnotype < 0)
13479             decc_readdir_dropdotnotype = 0;
13480     }
13481
13482     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
13483     if ($VMS_STATUS_SUCCESS(status)) {
13484         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
13485         if (s >= 0) {
13486             dflt = decc$feature_get_value(s, 4);
13487             if (dflt > 0) {
13488                 decc_disable_posix_root = decc$feature_get_value(s, 1);
13489                 if (decc_disable_posix_root <= 0) {
13490                     decc$feature_set_value(s, 1, 1);
13491                     decc_disable_posix_root = 1;
13492                 }
13493             }
13494             else {
13495                 /* Traditionally Perl assumes this is off */
13496                 decc_disable_posix_root = 1;
13497                 decc$feature_set_value(s, 1, 1);
13498             }
13499         }
13500     }
13501
13502 #if __CRTL_VER >= 80200000
13503     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
13504     if (s >= 0) {
13505         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
13506         if (decc_posix_compliant_pathnames < 0)
13507             decc_posix_compliant_pathnames = 0;
13508         if (decc_posix_compliant_pathnames > 4)
13509             decc_posix_compliant_pathnames = 0;
13510     }
13511
13512 #endif
13513 #else
13514     status = sys_trnlnm
13515         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
13516     if ($VMS_STATUS_SUCCESS(status)) {
13517         val_str[0] = _toupper(val_str[0]);
13518         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13519            decc_disable_to_vms_logname_translation = 1;
13520         }
13521     }
13522
13523 #ifndef __VAX
13524     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
13525     if ($VMS_STATUS_SUCCESS(status)) {
13526         val_str[0] = _toupper(val_str[0]);
13527         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13528            decc_efs_case_preserve = 1;
13529         }
13530     }
13531 #endif
13532
13533     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
13534     if ($VMS_STATUS_SUCCESS(status)) {
13535         val_str[0] = _toupper(val_str[0]);
13536         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13537            decc_filename_unix_report = 1;
13538         }
13539     }
13540     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
13541     if ($VMS_STATUS_SUCCESS(status)) {
13542         val_str[0] = _toupper(val_str[0]);
13543         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13544            decc_filename_unix_only = 1;
13545            decc_filename_unix_report = 1;
13546         }
13547     }
13548     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
13549     if ($VMS_STATUS_SUCCESS(status)) {
13550         val_str[0] = _toupper(val_str[0]);
13551         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13552            decc_filename_unix_no_version = 1;
13553         }
13554     }
13555     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
13556     if ($VMS_STATUS_SUCCESS(status)) {
13557         val_str[0] = _toupper(val_str[0]);
13558         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13559            decc_readdir_dropdotnotype = 1;
13560         }
13561     }
13562 #endif
13563
13564 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13565
13566      /* Report true case tolerance */
13567     /*----------------------------*/
13568     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
13569     if (!$VMS_STATUS_SUCCESS(status))
13570         case_perm = PPROP$K_CASE_BLIND;
13571     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
13572     if (!$VMS_STATUS_SUCCESS(status))
13573         case_image = PPROP$K_CASE_BLIND;
13574     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
13575         (case_image == PPROP$K_CASE_SENSITIVE))
13576         vms_process_case_tolerant = 0;
13577
13578 #endif
13579
13580
13581     /* CRTL can be initialized past this point, but not before. */
13582 /*    DECC$CRTL_INIT(); */
13583
13584     return SS$_NORMAL;
13585 }
13586
13587 #ifdef __DECC
13588 #pragma nostandard
13589 #pragma extern_model save
13590 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
13591         const __align (LONGWORD) int spare[8] = {0};
13592
13593 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
13594 #if __DECC_VER >= 60560002
13595 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
13596 #else
13597 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
13598 #endif
13599 #endif /* __DECC */
13600
13601 const long vms_cc_features = (const long)set_features;
13602
13603 /*
13604 ** Force a reference to LIB$INITIALIZE to ensure it
13605 ** exists in the image.
13606 */
13607 int lib$initialize(void);
13608 #ifdef __DECC
13609 #pragma extern_model strict_refdef
13610 #endif
13611     int lib_init_ref = (int) lib$initialize;
13612
13613 #ifdef __DECC
13614 #pragma extern_model restore
13615 #pragma standard
13616 #endif
13617
13618 /*  End of vms.c */