vms/vms.c

   1 *    vms.c
   2  *
   3  *    VMS-specific routines for perl5
   4  *
   5  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
   6  *    2002, 2003, 2004, 2005, 2006, 2007 by Charles Bailey and others.
   7  *
   8  *    You may distribute under the terms of either the GNU General Public
   9  *    License or the Artistic License, as specified in the README file.
  10  *
  11  *    Please see Changes*.* or the Perl Repository Browser for revision history.
  12  */
  13
  14 #include <acedef.h>
  15 #include <acldef.h>
  16 #include <armdef.h>
  17 #include <atrdef.h>
  18 #include <chpdef.h>
  19 #include <clidef.h>
  20 #include <climsgdef.h>
  21 #include <dcdef.h>
  22 #include <descrip.h>
  23 #include <devdef.h>
  24 #include <dvidef.h>
  25 #include <fibdef.h>
  26 #include <float.h>
  27 #include <fscndef.h>
  28 #include <iodef.h>
  29 #include <jpidef.h>
  30 #include <kgbdef.h>
  31 #include <libclidef.h>
  32 #include <libdef.h>
  33 #include <lib$routines.h>
  34 #include <lnmdef.h>
  35 #include <msgdef.h>
  36 #include <ossdef.h>
  37 #if __CRTL_VER >= 70301000 && !defined(__VAX)
  38 #include <ppropdef.h>
  39 #endif
  40 #include <prvdef.h>
  41 #include <psldef.h>
  42 #include <rms.h>
  43 #include <shrdef.h>
  44 #include <ssdef.h>
  45 #include <starlet.h>
  46 #include <strdef.h>
  47 #include <str$routines.h>
  48 #include <syidef.h>
  49 #include <uaidef.h>
  50 #include <uicdef.h>
  51 #include <stsdef.h>
  52 #include <rmsdef.h>
  53 #include <smgdef.h>
  54 #if __CRTL_VER >= 70000000 /* FIXME to earliest version */
  55 #include <efndef.h>
  56 #define NO_EFN EFN$C_ENF
  57 #else
  58 #define NO_EFN 0;
  59 #endif
  60
  61 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  62 int   decc$feature_get_index(const char *name);
  63 char* decc$feature_get_name(int index);
  64 int   decc$feature_get_value(int index, int mode);
  65 int   decc$feature_set_value(int index, int mode, int value);
  66 #else
  67 #include <unixlib.h>
  68 #endif
  69
  70 #pragma member_alignment save
  71 #pragma nomember_alignment longword
  72 struct item_list_3 {
  73         unsigned short len;
  74         unsigned short code;
  75         void * bufadr;
  76         unsigned short * retadr;
  77 };
  78 #pragma member_alignment restore
  79
  80 /* More specific prototype than in starlet_c.h makes programming errors
  81    more visible.
  82  */
  83 #ifdef sys$getdviw
  84 #undef sys$getdviw
  85 int sys$getdviw
  86        (unsigned long efn,
  87         unsigned short chan,
  88         const struct dsc$descriptor_s * devnam,
  89         const struct item_list_3 * itmlst,
  90         void * iosb,
  91         void * (astadr)(unsigned long),
  92         void * astprm,
  93         void * nullarg);
  94 #endif
  95
  96 #ifdef sys$get_security
  97 #undef sys$get_security
  98 int sys$get_security
  99        (const struct dsc$descriptor_s * clsnam,
 100         const struct dsc$descriptor_s * objnam,
 101         const unsigned int *objhan,
 102         unsigned int flags,
 103         const struct item_list_3 * itmlst,
 104         unsigned int * contxt,
 105         const unsigned int * acmode);
 106 #endif
 107
 108 #ifdef sys$set_security
 109 #undef sys$set_security
 110 int sys$set_security
 111        (const struct dsc$descriptor_s * clsnam,
 112         const struct dsc$descriptor_s * objnam,
 113         const unsigned int *objhan,
 114         unsigned int flags,
 115         const struct item_list_3 * itmlst,
 116         unsigned int * contxt,
 117         const unsigned int * acmode);
 118 #endif
 119
 120 #ifdef lib$find_image_symbol
 121 #undef lib$find_image_symbol
 122 int lib$find_image_symbol
 123        (const struct dsc$descriptor_s * imgname,
 124         const struct dsc$descriptor_s * symname,
 125         void * symval,
 126         const struct dsc$descriptor_s * defspec,
 127         unsigned long flag);
 128 #endif
 129
 130 #ifdef lib$rename_file
 131 #undef lib$rename_file
 132 int lib$rename_file
 133        (const struct dsc$descriptor_s * old_file_dsc,
 134         const struct dsc$descriptor_s * new_file_dsc,
 135         const struct dsc$descriptor_s * default_file_dsc,
 136         const struct dsc$descriptor_s * related_file_dsc,
 137         const unsigned long * flags,
 138         void * (success)(const struct dsc$descriptor_s * old_dsc,
 139                          const struct dsc$descriptor_s * new_dsc,
 140                          const void *),
 141         void * (error)(const struct dsc$descriptor_s * old_dsc,
 142                        const struct dsc$descriptor_s * new_dsc,
 143                        const int * rms_sts,
 144                        const int * rms_stv,
 145                        const int * error_src,
 146                        const void * usr_arg),
 147         int (confirm)(const struct dsc$descriptor_s * old_dsc,
 148                       const struct dsc$descriptor_s * new_dsc,
 149                       const void * old_fab,
 150                       const void * usr_arg),
 151         void * user_arg,
 152         struct dsc$descriptor_s * old_result_name_dsc,
 153         struct dsc$descriptor_s * new_result_name_dsc,
 154         unsigned long * file_scan_context);
 155 #endif
 156
 157 #if __CRTL_VER >= 70300000 && !defined(__VAX)
 158
 159 static int set_feature_default(const char *name, int value)
 160 {
 161     int status;
 162     int index;
 163
 164     index = decc$feature_get_index(name);
 165
 166     status = decc$feature_set_value(index, 1, value);
 167     if (index == -1 || (status == -1)) {
 168       return -1;
 169     }
 170
 171     status = decc$feature_get_value(index, 1);
 172     if (status != value) {
 173       return -1;
 174     }
 175
 176 return 0;
 177 }
 178 #endif
 179
 180 /* Older versions of ssdef.h don't have these */
 181 #ifndef SS$_INVFILFOROP
 182 #  define SS$_INVFILFOROP 3930
 183 #endif
 184 #ifndef SS$_NOSUCHOBJECT
 185 #  define SS$_NOSUCHOBJECT 2696
 186 #endif
 187
 188 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
 189 #define PERLIO_NOT_STDIO 0
 190
 191 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
 192  * code below needs to get to the underlying CRTL routines. */
 193 #define DONT_MASK_RTL_CALLS
 194 #include "EXTERN.h"
 195 #include "perl.h"
 196 #include "XSUB.h"
 197 /* Anticipating future expansion in lexical warnings . . . */
 198 #ifndef WARN_INTERNAL
 199 #  define WARN_INTERNAL WARN_MISC
 200 #endif
 201
 202 #ifdef VMS_LONGNAME_SUPPORT
 203 #include <libfildef.h>
 204 #endif
 205
 206 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
 207 #  define RTL_USES_UTC 1
 208 #endif
 209
 210 /* Routine to create a decterm for use with the Perl debugger */
 211 /* No headers, this information was found in the Programming Concepts Manual */
 212
 213 static int (*decw_term_port)
 214    (const struct dsc$descriptor_s * display,
 215     const struct dsc$descriptor_s * setup_file,
 216     const struct dsc$descriptor_s * customization,
 217     struct dsc$descriptor_s * result_device_name,
 218     unsigned short * result_device_name_length,
 219     void * controller,
 220     void * char_buffer,
 221     void * char_change_buffer) = 0;
 222
 223 /* gcc's header files don't #define direct access macros
 224  * corresponding to VAXC's variant structs */
 225 #ifdef __GNUC__
 226 #  define uic$v_format uic$r_uic_form.uic$v_format
 227 #  define uic$v_group uic$r_uic_form.uic$v_group
 228 #  define uic$v_member uic$r_uic_form.uic$v_member
 229 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 230 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 231 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 232 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 233 #endif
 234
 235 #if defined(NEED_AN_H_ERRNO)
 236 dEXT int h_errno;
 237 #endif
 238
 239 #ifdef __DECC
 240 #pragma message disable pragma
 241 #pragma member_alignment save
 242 #pragma nomember_alignment longword
 243 #pragma message save
 244 #pragma message disable misalgndmem
 245 #endif
 246 struct itmlst_3 {
 247   unsigned short int buflen;
 248   unsigned short int itmcode;
 249   void *bufadr;
 250   unsigned short int *retlen;
 251 };
 252
 253 struct filescan_itmlst_2 {
 254     unsigned short length;
 255     unsigned short itmcode;
 256     char * component;
 257 };
 258
 259 struct vs_str_st {
 260     unsigned short length;
 261     char str[65536];
 262 };
 263
 264 #ifdef __DECC
 265 #pragma message restore
 266 #pragma member_alignment restore
 267 #endif
 268
 269 #define do_fileify_dirspec(a,b,c,d)     mp_do_fileify_dirspec(aTHX_ a,b,c,d)
 270 #define do_pathify_dirspec(a,b,c,d)     mp_do_pathify_dirspec(aTHX_ a,b,c,d)
 271 #define do_tovmsspec(a,b,c,d)           mp_do_tovmsspec(aTHX_ a,b,c,0,d)
 272 #define do_tovmspath(a,b,c,d)           mp_do_tovmspath(aTHX_ a,b,c,d)
 273 #define do_rmsexpand(a,b,c,d,e,f,g)     mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
 274 #define do_vms_realpath(a,b,c)          mp_do_vms_realpath(aTHX_ a,b,c)
 275 #define do_tounixspec(a,b,c,d)          mp_do_tounixspec(aTHX_ a,b,c,d)
 276 #define do_tounixpath(a,b,c,d)          mp_do_tounixpath(aTHX_ a,b,c,d)
 277 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 278 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 279 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 280
 281 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
 282 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
 283 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
 284 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
 285
 286 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 287 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 288
 289 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 290  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 291  * the Perl facility.
 292  */
 293 #define PERL_LNM_MAX_ITER 10
 294
 295   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 296 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 297 #define MAX_DCL_SYMBOL          (8192)
 298 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 299 #else
 300 #define MAX_DCL_SYMBOL          (1024)
 301 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 302 #endif
 303
 304 static char *__mystrtolower(char *str)
 305 {
 306   if (str) for (; *str; ++str) *str= tolower(*str);
 307   return str;
 308 }
 309
 310 static struct dsc$descriptor_s fildevdsc =
 311   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 312 static struct dsc$descriptor_s crtlenvdsc =
 313   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 314 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 315 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 316 static struct dsc$descriptor_s **env_tables = defenv;
 317 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 318
 319 /* True if we shouldn't treat barewords as logicals during directory */
 320 /* munching */
 321 static int no_translate_barewords;
 322
 323 #ifndef RTL_USES_UTC
 324 static int tz_updated = 1;
 325 #endif
 326
 327 /* DECC Features that may need to affect how Perl interprets
 328  * displays filename information
 329  */
 330 static int decc_disable_to_vms_logname_translation = 1;
 331 static int decc_disable_posix_root = 1;
 332 int decc_efs_case_preserve = 0;
 333 static int decc_efs_charset = 0;
 334 static int decc_filename_unix_no_version = 0;
 335 static int decc_filename_unix_only = 0;
 336 int decc_filename_unix_report = 0;
 337 int decc_posix_compliant_pathnames = 0;
 338 int decc_readdir_dropdotnotype = 0;
 339 static int vms_process_case_tolerant = 1;
 340 int vms_vtf7_filenames = 0;
 341 int gnv_unix_shell = 0;
 342 static int vms_unlink_all_versions = 0;
 343
 344 /* bug workarounds if needed */
 345 int decc_bug_readdir_efs1 = 0;
 346 int decc_bug_devnull = 1;
 347 int decc_bug_fgetname = 0;
 348 int decc_dir_barename = 0;
 349
 350 static int vms_debug_on_exception = 0;
 351
 352 /* Is this a UNIX file specification?
 353  *   No longer a simple check with EFS file specs
 354  *   For now, not a full check, but need to
 355  *   handle POSIX ^UP^ specifications
 356  *   Fixing to handle ^/ cases would require
 357  *   changes to many other conversion routines.
 358  */
 359
 360 static int is_unix_filespec(const char *path)
 361 {
 362 int ret_val;
 363 const char * pch1;
 364
 365     ret_val = 0;
 366     if (strncmp(path,"\"^UP^",5) != 0) {
 367         pch1 = strchr(path, '/');
 368         if (pch1 != NULL)
 369             ret_val = 1;
 370         else {
 371
 372             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 373             if (decc_filename_unix_report || decc_filename_unix_only) {
 374             if (strcmp(path,".") == 0)
 375                 ret_val = 1;
 376             }
 377         }
 378     }
 379     return ret_val;
 380 }
 381
 382 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 383  */
 384
 385 static void ucs2_to_vtf7
 386    (char *outspec,
 387     unsigned long ucs2_char,
 388     int * output_cnt)
 389 {
 390 unsigned char * ucs_ptr;
 391 int hex;
 392
 393     ucs_ptr = (unsigned char *)&ucs2_char;
 394
 395     outspec[0] = '^';
 396     outspec[1] = 'U';
 397     hex = (ucs_ptr[1] >> 4) & 0xf;
 398     if (hex < 0xA)
 399         outspec[2] = hex + '0';
 400     else
 401         outspec[2] = (hex - 9) + 'A';
 402     hex = ucs_ptr[1] & 0xF;
 403     if (hex < 0xA)
 404         outspec[3] = hex + '0';
 405     else {
 406         outspec[3] = (hex - 9) + 'A';
 407     }
 408     hex = (ucs_ptr[0] >> 4) & 0xf;
 409     if (hex < 0xA)
 410         outspec[4] = hex + '0';
 411     else
 412         outspec[4] = (hex - 9) + 'A';
 413     hex = ucs_ptr[1] & 0xF;
 414     if (hex < 0xA)
 415         outspec[5] = hex + '0';
 416     else {
 417         outspec[5] = (hex - 9) + 'A';
 418     }
 419     *output_cnt = 6;
 420 }
 421
 422
 423 /* This handles the conversion of a UNIX extended character set to a ^
 424  * escaped VMS character.
 425  * in a UNIX file specification.
 426  *
 427  * The output count variable contains the number of characters added
 428  * to the output string.
 429  *
 430  * The return value is the number of characters read from the input string
 431  */
 432 static int copy_expand_unix_filename_escape
 433   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 434 {
 435 int count;
 436 int scnt;
 437 int utf8_flag;
 438
 439     utf8_flag = 0;
 440     if (utf8_fl)
 441       utf8_flag = *utf8_fl;
 442
 443     count = 0;
 444     *output_cnt = 0;
 445     if (*inspec >= 0x80) {
 446         if (utf8_fl && vms_vtf7_filenames) {
 447         unsigned long ucs_char;
 448
 449             ucs_char = 0;
 450
 451             if ((*inspec & 0xE0) == 0xC0) {
 452                 /* 2 byte Unicode */
 453                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 454                 if (ucs_char >= 0x80) {
 455                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 456                     return 2;
 457                 }
 458             } else if ((*inspec & 0xF0) == 0xE0) {
 459                 /* 3 byte Unicode */
 460                 ucs_char = ((inspec[0] & 0xF) << 12) +
 461                    ((inspec[1] & 0x3f) << 6) +
 462                    (inspec[2] & 0x3f);
 463                 if (ucs_char >= 0x800) {
 464                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 465                     return 3;
 466                 }
 467
 468 #if 0 /* I do not see longer sequences supported by OpenVMS */
 469       /* Maybe some one can fix this later */
 470             } else if ((*inspec & 0xF8) == 0xF0) {
 471                 /* 4 byte Unicode */
 472                 /* UCS-4 to UCS-2 */
 473             } else if ((*inspec & 0xFC) == 0xF8) {
 474                 /* 5 byte Unicode */
 475                 /* UCS-4 to UCS-2 */
 476             } else if ((*inspec & 0xFE) == 0xFC) {
 477                 /* 6 byte Unicode */
 478                 /* UCS-4 to UCS-2 */
 479 #endif
 480             }
 481         }
 482
 483         /* High bit set, but not a Unicode character! */
 484
 485         /* Non printing DECMCS or ISO Latin-1 character? */
 486         if (*inspec <= 0x9F) {
 487         int hex;
 488             outspec[0] = '^';
 489             outspec++;
 490             hex = (*inspec >> 4) & 0xF;
 491             if (hex < 0xA)
 492                 outspec[1] = hex + '0';
 493             else {
 494                 outspec[1] = (hex - 9) + 'A';
 495             }
 496             hex = *inspec & 0xF;
 497             if (hex < 0xA)
 498                 outspec[2] = hex + '0';
 499             else {
 500                 outspec[2] = (hex - 9) + 'A';
 501             }
 502             *output_cnt = 3;
 503             return 1;
 504         } else if (*inspec == 0xA0) {
 505             outspec[0] = '^';
 506             outspec[1] = 'A';
 507             outspec[2] = '0';
 508             *output_cnt = 3;
 509             return 1;
 510         } else if (*inspec == 0xFF) {
 511             outspec[0] = '^';
 512             outspec[1] = 'F';
 513             outspec[2] = 'F';
 514             *output_cnt = 3;
 515             return 1;
 516         }
 517         *outspec = *inspec;
 518         *output_cnt = 1;
 519         return 1;
 520     }
 521
 522     /* Is this a macro that needs to be passed through?
 523      * Macros start with $( and an alpha character, followed
 524      * by a string of alpha numeric characters ending with a )
 525      * If this does not match, then encode it as ODS-5.
 526      */
 527     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 528     int tcnt;
 529
 530         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 531             tcnt = 3;
 532             outspec[0] = inspec[0];
 533             outspec[1] = inspec[1];
 534             outspec[2] = inspec[2];
 535
 536             while(isalnum(inspec[tcnt]) ||
 537                   (inspec[2] == '.') || (inspec[2] == '_')) {
 538                 outspec[tcnt] = inspec[tcnt];
 539                 tcnt++;
 540             }
 541             if (inspec[tcnt] == ')') {
 542                 outspec[tcnt] = inspec[tcnt];
 543                 tcnt++;
 544                 *output_cnt = tcnt;
 545                 return tcnt;
 546             }
 547         }
 548     }
 549
 550     switch (*inspec) {
 551     case 0x7f:
 552         outspec[0] = '^';
 553         outspec[1] = '7';
 554         outspec[2] = 'F';
 555         *output_cnt = 3;
 556         return 1;
 557         break;
 558     case '?':
 559         if (decc_efs_charset == 0)
 560           outspec[0] = '%';
 561         else
 562           outspec[0] = '?';
 563         *output_cnt = 1;
 564         return 1;
 565         break;
 566     case '.':
 567     case '~':
 568     case '!':
 569     case '#':
 570     case '&':
 571     case '\'':
 572     case '`':
 573     case '(':
 574     case ')':
 575     case '+':
 576     case '@':
 577     case '{':
 578     case '}':
 579     case ',':
 580     case ';':
 581     case '[':
 582     case ']':
 583     case '%':
 584     case '^':
 585         /* Don't escape again if following character is
 586          * already something we escape.
 587          */
 588         if (strchr(".~!#&\'`()+@{},;[]%^=_", *(inspec+1))) {
 589             *outspec = *inspec;
 590             *output_cnt = 1;
 591             return 1;
 592             break;
 593         }
 594         /* But otherwise fall through and escape it. */
 595     case '=':
 596         /* Assume that this is to be escaped */
 597         outspec[0] = '^';
 598         outspec[1] = *inspec;
 599         *output_cnt = 2;
 600         return 1;
 601         break;
 602     case ' ': /* space */
 603         /* Assume that this is to be escaped */
 604         outspec[0] = '^';
 605         outspec[1] = '_';
 606         *output_cnt = 2;
 607         return 1;
 608         break;
 609     default:
 610         *outspec = *inspec;
 611         *output_cnt = 1;
 612         return 1;
 613         break;
 614     }
 615 }
 616
 617
 618 /* This handles the expansion of a '^' prefix to the proper character
 619  * in a UNIX file specification.
 620  *
 621  * The output count variable contains the number of characters added
 622  * to the output string.
 623  *
 624  * The return value is the number of characters read from the input
 625  * string
 626  */
 627 static int copy_expand_vms_filename_escape
 628   (char *outspec, const char *inspec, int *output_cnt)
 629 {
 630 int count;
 631 int scnt;
 632
 633     count = 0;
 634     *output_cnt = 0;
 635     if (*inspec == '^') {
 636         inspec++;
 637         switch (*inspec) {
 638         /* Spaces and non-trailing dots should just be passed through,
 639          * but eat the escape character.
 640          */
 641         case '.':
 642             *outspec = *inspec;
 643             count += 2;
 644             (*output_cnt)++;
 645             break;
 646         case '_': /* space */
 647             *outspec = ' ';
 648             count += 2;
 649             (*output_cnt)++;
 650             break;
 651         case '^':
 652             /* Hmm.  Better leave the escape escaped. */
 653             outspec[0] = '^';
 654             outspec[1] = '^';
 655             count += 2;
 656             (*output_cnt) += 2;
 657             break;
 658         case 'U': /* Unicode - FIX-ME this is wrong. */
 659             inspec++;
 660             count++;
 661             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 662             if (scnt == 4) {
 663                 unsigned int c1, c2;
 664                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 665                 outspec[0] == c1 & 0xff;
 666                 outspec[1] == c2 & 0xff;
 667                 if (scnt > 1) {
 668                     (*output_cnt) += 2;
 669                     count += 4;
 670                 }
 671             }
 672             else {
 673                 /* Error - do best we can to continue */
 674                 *outspec = 'U';
 675                 outspec++;
 676                 (*output_cnt++);
 677                 *outspec = *inspec;
 678                 count++;
 679                 (*output_cnt++);
 680             }
 681             break;
 682         default:
 683             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 684             if (scnt == 2) {
 685                 /* Hex encoded */
 686                 unsigned int c1;
 687                 scnt = sscanf(inspec, "%2x", &c1);
 688                 outspec[0] = c1 & 0xff;
 689                 if (scnt > 0) {
 690                     (*output_cnt++);
 691                     count += 2;
 692                 }
 693             }
 694             else {
 695                 *outspec = *inspec;
 696                 count++;
 697                 (*output_cnt++);
 698             }
 699         }
 700     }
 701     else {
 702         *outspec = *inspec;
 703         count++;
 704         (*output_cnt)++;
 705     }
 706     return count;
 707 }
 708
 709 #ifdef sys$filescan
 710 #undef sys$filescan
 711 int sys$filescan
 712    (const struct dsc$descriptor_s * srcstr,
 713     struct filescan_itmlst_2 * valuelist,
 714     unsigned long * fldflags,
 715     struct dsc$descriptor_s *auxout,
 716     unsigned short * retlen);
 717 #endif
 718
 719 /* vms_split_path - Verify that the input file specification is a
 720  * VMS format file specification, and provide pointers to the components of
 721  * it.  With EFS format filenames, this is virtually the only way to
 722  * parse a VMS path specification into components.
 723  *
 724  * If the sum of the components do not add up to the length of the
 725  * string, then the passed file specification is probably a UNIX style
 726  * path.
 727  */
 728 static int vms_split_path
 729    (const char * path,
 730     char * * volume,
 731     int * vol_len,
 732     char * * root,
 733     int * root_len,
 734     char * * dir,
 735     int * dir_len,
 736     char * * name,
 737     int * name_len,
 738     char * * ext,
 739     int * ext_len,
 740     char * * version,
 741     int * ver_len)
 742 {
 743 struct dsc$descriptor path_desc;
 744 int status;
 745 unsigned long flags;
 746 int ret_stat;
 747 struct filescan_itmlst_2 item_list[9];
 748 const int filespec = 0;
 749 const int nodespec = 1;
 750 const int devspec = 2;
 751 const int rootspec = 3;
 752 const int dirspec = 4;
 753 const int namespec = 5;
 754 const int typespec = 6;
 755 const int verspec = 7;
 756
 757     /* Assume the worst for an easy exit */
 758     ret_stat = -1;
 759     *volume = NULL;
 760     *vol_len = 0;
 761     *root = NULL;
 762     *root_len = 0;
 763     *dir = NULL;
 764     *dir_len;
 765     *name = NULL;
 766     *name_len = 0;
 767     *ext = NULL;
 768     *ext_len = 0;
 769     *version = NULL;
 770     *ver_len = 0;
 771
 772     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 773     path_desc.dsc$w_length = strlen(path);
 774     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 775     path_desc.dsc$b_class = DSC$K_CLASS_S;
 776
 777     /* Get the total length, if it is shorter than the string passed
 778      * then this was probably not a VMS formatted file specification
 779      */
 780     item_list[filespec].itmcode = FSCN$_FILESPEC;
 781     item_list[filespec].length = 0;
 782     item_list[filespec].component = NULL;
 783
 784     /* If the node is present, then it gets considered as part of the
 785      * volume name to hopefully make things simple.
 786      */
 787     item_list[nodespec].itmcode = FSCN$_NODE;
 788     item_list[nodespec].length = 0;
 789     item_list[nodespec].component = NULL;
 790
 791     item_list[devspec].itmcode = FSCN$_DEVICE;
 792     item_list[devspec].length = 0;
 793     item_list[devspec].component = NULL;
 794
 795     /* root is a special case,  adding it to either the directory or
 796      * the device components will probalby complicate things for the
 797      * callers of this routine, so leave it separate.
 798      */
 799     item_list[rootspec].itmcode = FSCN$_ROOT;
 800     item_list[rootspec].length = 0;
 801     item_list[rootspec].component = NULL;
 802
 803     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 804     item_list[dirspec].length = 0;
 805     item_list[dirspec].component = NULL;
 806
 807     item_list[namespec].itmcode = FSCN$_NAME;
 808     item_list[namespec].length = 0;
 809     item_list[namespec].component = NULL;
 810
 811     item_list[typespec].itmcode = FSCN$_TYPE;
 812     item_list[typespec].length = 0;
 813     item_list[typespec].component = NULL;
 814
 815     item_list[verspec].itmcode = FSCN$_VERSION;
 816     item_list[verspec].length = 0;
 817     item_list[verspec].component = NULL;
 818
 819     item_list[8].itmcode = 0;
 820     item_list[8].length = 0;
 821     item_list[8].component = NULL;
 822
 823     status = sys$filescan
 824        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 825         &flags, NULL, NULL);
 826     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 827
 828     /* If we parsed it successfully these two lengths should be the same */
 829     if (path_desc.dsc$w_length != item_list[filespec].length)
 830         return ret_stat;
 831
 832     /* If we got here, then it is a VMS file specification */
 833     ret_stat = 0;
 834
 835     /* set the volume name */
 836     if (item_list[nodespec].length > 0) {
 837         *volume = item_list[nodespec].component;
 838         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 839     }
 840     else {
 841         *volume = item_list[devspec].component;
 842         *vol_len = item_list[devspec].length;
 843     }
 844
 845     *root = item_list[rootspec].component;
 846     *root_len = item_list[rootspec].length;
 847
 848     *dir = item_list[dirspec].component;
 849     *dir_len = item_list[dirspec].length;
 850
 851     /* Now fun with versions and EFS file specifications
 852      * The parser can not tell the difference when a "." is a version
 853      * delimiter or a part of the file specification.
 854      */
 855     if ((decc_efs_charset) &&
 856         (item_list[verspec].length > 0) &&
 857         (item_list[verspec].component[0] == '.')) {
 858         *name = item_list[namespec].component;
 859         *name_len = item_list[namespec].length + item_list[typespec].length;
 860         *ext = item_list[verspec].component;
 861         *ext_len = item_list[verspec].length;
 862         *version = NULL;
 863         *ver_len = 0;
 864     }
 865     else {
 866         *name = item_list[namespec].component;
 867         *name_len = item_list[namespec].length;
 868         *ext = item_list[typespec].component;
 869         *ext_len = item_list[typespec].length;
 870         *version = item_list[verspec].component;
 871         *ver_len = item_list[verspec].length;
 872     }
 873     return ret_stat;
 874 }
 875
 876
 877 /* my_maxidx
 878  * Routine to retrieve the maximum equivalence index for an input
 879  * logical name.  Some calls to this routine have no knowledge if
 880  * the variable is a logical or not.  So on error we return a max
 881  * index of zero.
 882  */
 883 /*{{{int my_maxidx(const char *lnm) */
 884 static int
 885 my_maxidx(const char *lnm)
 886 {
 887     int status;
 888     int midx;
 889     int attr = LNM$M_CASE_BLIND;
 890     struct dsc$descriptor lnmdsc;
 891     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 892                                 {0, 0, 0, 0}};
 893
 894     lnmdsc.dsc$w_length = strlen(lnm);
 895     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 896     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 897     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 898
 899     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 900     if ((status & 1) == 0)
 901        midx = 0;
 902
 903     return (midx);
 904 }
 905 /*}}}*/
 906
 907 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 908 int
 909 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 910   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 911 {
 912     const char *cp1;
 913     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 914     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 915     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 916     int midx;
 917     unsigned char acmode;
 918     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 919                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 920     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 921                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 922                                  {0, 0, 0, 0}};
 923     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 924 #if defined(PERL_IMPLICIT_CONTEXT)
 925     pTHX = NULL;
 926     if (PL_curinterp) {
 927       aTHX = PERL_GET_INTERP;
 928     } else {
 929       aTHX = NULL;
 930     }
 931 #endif
 932
 933     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 934       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 935     }
 936     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 937       *cp2 = _toupper(*cp1);
 938       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 939         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 940         return 0;
 941       }
 942     }
 943     lnmdsc.dsc$w_length = cp1 - lnm;
 944     lnmdsc.dsc$a_pointer = uplnm;
 945     uplnm[lnmdsc.dsc$w_length] = '\0';
 946     secure = flags & PERL__TRNENV_SECURE;
 947     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 948     if (!tabvec || !*tabvec) tabvec = env_tables;
 949
 950     for (curtab = 0; tabvec[curtab]; curtab++) {
 951       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 952         if (!ivenv && !secure) {
 953           char *eq, *end;
 954           int i;
 955           if (!environ) {
 956             ivenv = 1;
 957             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 958             continue;
 959           }
 960           retsts = SS$_NOLOGNAM;
 961           for (i = 0; environ[i]; i++) {
 962             if ((eq = strchr(environ[i],'=')) &&
 963                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 964                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 965               eq++;
 966               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 967               if (!eqvlen) continue;
 968               retsts = SS$_NORMAL;
 969               break;
 970             }
 971           }
 972           if (retsts != SS$_NOLOGNAM) break;
 973         }
 974       }
 975       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 976                !str$case_blind_compare(&tmpdsc,&clisym)) {
 977         if (!ivsym && !secure) {
 978           unsigned short int deflen = LNM$C_NAMLENGTH;
 979           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 980           /* dynamic dsc to accomodate possible long value */
 981           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 982           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 983           if (retsts & 1) {
 984             if (eqvlen > MAX_DCL_SYMBOL) {
 985               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 986               eqvlen = MAX_DCL_SYMBOL;
 987               /* Special hack--we might be called before the interpreter's */
 988               /* fully initialized, in which case either thr or PL_curcop */
 989               /* might be bogus. We have to check, since ckWARN needs them */
 990               /* both to be valid if running threaded */
 991                 if (ckWARN(WARN_MISC)) {
 992                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 993                 }
 994             }
 995             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 996           }
 997           _ckvmssts(lib$sfree1_dd(&eqvdsc));
 998           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 999           if (retsts == LIB$_NOSUCHSYM) continue;
1000           break;
1001         }
1002       }
1003       else if (!ivlnm) {
1004         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
1005           midx = my_maxidx(lnm);
1006           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1007             lnmlst[1].bufadr = cp2;
1008             eqvlen = 0;
1009             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1010             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1011             if (retsts == SS$_NOLOGNAM) break;
1012             /* PPFs have a prefix */
1013             if (
1014 #if INTSIZE == 4
1015                  *((int *)uplnm) == *((int *)"SYS$")                    &&
1016 #endif
1017                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
1018                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
1019                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
1020                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
1021                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
1022               memmove(eqv,eqv+4,eqvlen-4);
1023               eqvlen -= 4;
1024             }
1025             cp2 += eqvlen;
1026             *cp2 = '\0';
1027           }
1028           if ((retsts == SS$_IVLOGNAM) ||
1029               (retsts == SS$_NOLOGNAM)) { continue; }
1030         }
1031         else {
1032           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1033           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1034           if (retsts == SS$_NOLOGNAM) continue;
1035           eqv[eqvlen] = '\0';
1036         }
1037         eqvlen = strlen(eqv);
1038         break;
1039       }
1040     }
1041     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1042     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1043              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
1044              retsts == SS$_NOLOGNAM) {
1045       set_errno(EINVAL);  set_vaxc_errno(retsts);
1046     }
1047     else _ckvmssts(retsts);
1048     return 0;
1049 }  /* end of vmstrnenv */
1050 /*}}}*/
1051
1052 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1053 /* Define as a function so we can access statics. */
1054 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1055 {
1056   return vmstrnenv(lnm,eqv,idx,fildev,
1057 #ifdef SECURE_INTERNAL_GETENV
1058                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
1059 #else
1060                    0
1061 #endif
1062                                                                               );
1063 }
1064 /*}}}*/
1065
1066 /* my_getenv
1067  * Note: Uses Perl temp to store result so char * can be returned to
1068  * caller; this pointer will be invalidated at next Perl statement
1069  * transition.
1070  * We define this as a function rather than a macro in terms of my_getenv_len()
1071  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1072  * allocate SVs).
1073  */
1074 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1075 char *
1076 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1077 {
1078     const char *cp1;
1079     static char *__my_getenv_eqv = NULL;
1080     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1081     unsigned long int idx = 0;
1082     int trnsuccess, success, secure, saverr, savvmserr;
1083     int midx, flags;
1084     SV *tmpsv;
1085
1086     midx = my_maxidx(lnm) + 1;
1087
1088     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1089       /* Set up a temporary buffer for the return value; Perl will
1090        * clean it up at the next statement transition */
1091       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1092       if (!tmpsv) return NULL;
1093       eqv = SvPVX(tmpsv);
1094     }
1095     else {
1096       /* Assume no interpreter ==> single thread */
1097       if (__my_getenv_eqv != NULL) {
1098         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1099       }
1100       else {
1101         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1102       }
1103       eqv = __my_getenv_eqv;
1104     }
1105
1106     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1107     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1108       int len;
1109       getcwd(eqv,LNM$C_NAMLENGTH);
1110
1111       len = strlen(eqv);
1112
1113       /* Get rid of "000000/ in rooted filespecs */
1114       if (len > 7) {
1115         char * zeros;
1116         zeros = strstr(eqv, "/000000/");
1117         if (zeros != NULL) {
1118           int mlen;
1119           mlen = len - (zeros - eqv) - 7;
1120           memmove(zeros, &zeros[7], mlen);
1121           len = len - 7;
1122           eqv[len] = '\0';
1123         }
1124       }
1125       return eqv;
1126     }
1127     else {
1128       /* Impose security constraints only if tainting */
1129       if (sys) {
1130         /* Impose security constraints only if tainting */
1131         secure = PL_curinterp ? PL_tainting : will_taint;
1132         saverr = errno;  savvmserr = vaxc$errno;
1133       }
1134       else {
1135         secure = 0;
1136       }
1137
1138       flags =
1139 #ifdef SECURE_INTERNAL_GETENV
1140               secure ? PERL__TRNENV_SECURE : 0
1141 #else
1142               0
1143 #endif
1144       ;
1145
1146       /* For the getenv interface we combine all the equivalence names
1147        * of a search list logical into one value to acquire a maximum
1148        * value length of 255*128 (assuming %ENV is using logicals).
1149        */
1150       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1151
1152       /* If the name contains a semicolon-delimited index, parse it
1153        * off and make sure we only retrieve the equivalence name for
1154        * that index.  */
1155       if ((cp2 = strchr(lnm,';')) != NULL) {
1156         strcpy(uplnm,lnm);
1157         uplnm[cp2-lnm] = '\0';
1158         idx = strtoul(cp2+1,NULL,0);
1159         lnm = uplnm;
1160         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1161       }
1162
1163       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1164
1165       /* Discard NOLOGNAM on internal calls since we're often looking
1166        * for an optional name, and this "error" often shows up as the
1167        * (bogus) exit status for a die() call later on.  */
1168       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1169       return success ? eqv : Nullch;
1170     }
1171
1172 }  /* end of my_getenv() */
1173 /*}}}*/
1174
1175
1176 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1177 char *
1178 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1179 {
1180     const char *cp1;
1181     char *buf, *cp2;
1182     unsigned long idx = 0;
1183     int midx, flags;
1184     static char *__my_getenv_len_eqv = NULL;
1185     int secure, saverr, savvmserr;
1186     SV *tmpsv;
1187
1188     midx = my_maxidx(lnm) + 1;
1189
1190     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1191       /* Set up a temporary buffer for the return value; Perl will
1192        * clean it up at the next statement transition */
1193       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1194       if (!tmpsv) return NULL;
1195       buf = SvPVX(tmpsv);
1196     }
1197     else {
1198       /* Assume no interpreter ==> single thread */
1199       if (__my_getenv_len_eqv != NULL) {
1200         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1201       }
1202       else {
1203         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1204       }
1205       buf = __my_getenv_len_eqv;
1206     }
1207
1208     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1209     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1210     char * zeros;
1211
1212       getcwd(buf,LNM$C_NAMLENGTH);
1213       *len = strlen(buf);
1214
1215       /* Get rid of "000000/ in rooted filespecs */
1216       if (*len > 7) {
1217       zeros = strstr(buf, "/000000/");
1218       if (zeros != NULL) {
1219         int mlen;
1220         mlen = *len - (zeros - buf) - 7;
1221         memmove(zeros, &zeros[7], mlen);
1222         *len = *len - 7;
1223         buf[*len] = '\0';
1224         }
1225       }
1226       return buf;
1227     }
1228     else {
1229       if (sys) {
1230         /* Impose security constraints only if tainting */
1231         secure = PL_curinterp ? PL_tainting : will_taint;
1232         saverr = errno;  savvmserr = vaxc$errno;
1233       }
1234       else {
1235         secure = 0;
1236       }
1237
1238       flags =
1239 #ifdef SECURE_INTERNAL_GETENV
1240               secure ? PERL__TRNENV_SECURE : 0
1241 #else
1242               0
1243 #endif
1244       ;
1245
1246       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1247
1248       if ((cp2 = strchr(lnm,';')) != NULL) {
1249         strcpy(buf,lnm);
1250         buf[cp2-lnm] = '\0';
1251         idx = strtoul(cp2+1,NULL,0);
1252         lnm = buf;
1253         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1254       }
1255
1256       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1257
1258       /* Get rid of "000000/ in rooted filespecs */
1259       if (*len > 7) {
1260       char * zeros;
1261         zeros = strstr(buf, "/000000/");
1262         if (zeros != NULL) {
1263           int mlen;
1264           mlen = *len - (zeros - buf) - 7;
1265           memmove(zeros, &zeros[7], mlen);
1266           *len = *len - 7;
1267           buf[*len] = '\0';
1268         }
1269       }
1270
1271       /* Discard NOLOGNAM on internal calls since we're often looking
1272        * for an optional name, and this "error" often shows up as the
1273        * (bogus) exit status for a die() call later on.  */
1274       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1275       return *len ? buf : Nullch;
1276     }
1277
1278 }  /* end of my_getenv_len() */
1279 /*}}}*/
1280
1281 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
1282
1283 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1284
1285 /*{{{ void prime_env_iter() */
1286 void
1287 prime_env_iter(void)
1288 /* Fill the %ENV associative array with all logical names we can
1289  * find, in preparation for iterating over it.
1290  */
1291 {
1292   static int primed = 0;
1293   HV *seenhv = NULL, *envhv;
1294   SV *sv = NULL;
1295   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
1296   unsigned short int chan;
1297 #ifndef CLI$M_TRUSTED
1298 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1299 #endif
1300   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1301   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1302   long int i;
1303   bool have_sym = FALSE, have_lnm = FALSE;
1304   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1305   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1306   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1307   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1308   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1309 #if defined(PERL_IMPLICIT_CONTEXT)
1310   pTHX;
1311 #endif
1312 #if defined(USE_ITHREADS)
1313   static perl_mutex primenv_mutex;
1314   MUTEX_INIT(&primenv_mutex);
1315 #endif
1316
1317 #if defined(PERL_IMPLICIT_CONTEXT)
1318     /* We jump through these hoops because we can be called at */
1319     /* platform-specific initialization time, which is before anything is */
1320     /* set up--we can't even do a plain dTHX since that relies on the */
1321     /* interpreter structure to be initialized */
1322     if (PL_curinterp) {
1323       aTHX = PERL_GET_INTERP;
1324     } else {
1325       aTHX = NULL;
1326     }
1327 #endif
1328
1329   if (primed || !PL_envgv) return;
1330   MUTEX_LOCK(&primenv_mutex);
1331   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1332   envhv = GvHVn(PL_envgv);
1333   /* Perform a dummy fetch as an lval to insure that the hash table is
1334    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1335   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1336
1337   for (i = 0; env_tables[i]; i++) {
1338      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1339          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1340      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1341   }
1342   if (have_sym || have_lnm) {
1343     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1344     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1345     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1346     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1347   }
1348
1349   for (i--; i >= 0; i--) {
1350     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1351       char *start;
1352       int j;
1353       for (j = 0; environ[j]; j++) {
1354         if (!(start = strchr(environ[j],'='))) {
1355           if (ckWARN(WARN_INTERNAL))
1356             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1357         }
1358         else {
1359           start++;
1360           sv = newSVpv(start,0);
1361           SvTAINTED_on(sv);
1362           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1363         }
1364       }
1365       continue;
1366     }
1367     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1368              !str$case_blind_compare(&tmpdsc,&clisym)) {
1369       strcpy(cmd,"Show Symbol/Global *");
1370       cmddsc.dsc$w_length = 20;
1371       if (env_tables[i]->dsc$w_length == 12 &&
1372           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1373           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1374       flags = defflags | CLI$M_NOLOGNAM;
1375     }
1376     else {
1377       strcpy(cmd,"Show Logical *");
1378       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1379         strcat(cmd," /Table=");
1380         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1381         cmddsc.dsc$w_length = strlen(cmd);
1382       }
1383       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1384       flags = defflags | CLI$M_NOCLISYM;
1385     }
1386
1387     /* Create a new subprocess to execute each command, to exclude the
1388      * remote possibility that someone could subvert a mbx or file used
1389      * to write multiple commands to a single subprocess.
1390      */
1391     do {
1392       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1393                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1394       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1395       defflags &= ~CLI$M_TRUSTED;
1396     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1397     _ckvmssts(retsts);
1398     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1399     if (seenhv) SvREFCNT_dec(seenhv);
1400     seenhv = newHV();
1401     while (1) {
1402       char *cp1, *cp2, *key;
1403       unsigned long int sts, iosb[2], retlen, keylen;
1404       register U32 hash;
1405
1406       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1407       if (sts & 1) sts = iosb[0] & 0xffff;
1408       if (sts == SS$_ENDOFFILE) {
1409         int wakect = 0;
1410         while (substs == 0) { sys$hiber(); wakect++;}
1411         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1412         _ckvmssts(substs);
1413         break;
1414       }
1415       _ckvmssts(sts);
1416       retlen = iosb[0] >> 16;
1417       if (!retlen) continue;  /* blank line */
1418       buf[retlen] = '\0';
1419       if (iosb[1] != subpid) {
1420         if (iosb[1]) {
1421           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1422         }
1423         continue;
1424       }
1425       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1426         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1427
1428       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1429       if (*cp1 == '(' || /* Logical name table name */
1430           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1431       if (*cp1 == '"') cp1++;
1432       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1433       key = cp1;  keylen = cp2 - cp1;
1434       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1435       while (*cp2 && *cp2 != '=') cp2++;
1436       while (*cp2 && *cp2 == '=') cp2++;
1437       while (*cp2 && *cp2 == ' ') cp2++;
1438       if (*cp2 == '"') {  /* String translation; may embed "" */
1439         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1440         cp2++;  cp1--; /* Skip "" surrounding translation */
1441       }
1442       else {  /* Numeric translation */
1443         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1444         cp1--;  /* stop on last non-space char */
1445       }
1446       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1447         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1448         continue;
1449       }
1450       PERL_HASH(hash,key,keylen);
1451
1452       if (cp1 == cp2 && *cp2 == '.') {
1453         /* A single dot usually means an unprintable character, such as a null
1454          * to indicate a zero-length value.  Get the actual value to make sure.
1455          */
1456         char lnm[LNM$C_NAMLENGTH+1];
1457         char eqv[MAX_DCL_SYMBOL+1];
1458         int trnlen;
1459         strncpy(lnm, key, keylen);
1460         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1461         sv = newSVpvn(eqv, strlen(eqv));
1462       }
1463       else {
1464         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1465       }
1466
1467       SvTAINTED_on(sv);
1468       hv_store(envhv,key,keylen,sv,hash);
1469       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1470     }
1471     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1472       /* get the PPFs for this process, not the subprocess */
1473       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1474       char eqv[LNM$C_NAMLENGTH+1];
1475       int trnlen, i;
1476       for (i = 0; ppfs[i]; i++) {
1477         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1478         sv = newSVpv(eqv,trnlen);
1479         SvTAINTED_on(sv);
1480         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1481       }
1482     }
1483   }
1484   primed = 1;
1485   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1486   if (buf) Safefree(buf);
1487   if (seenhv) SvREFCNT_dec(seenhv);
1488   MUTEX_UNLOCK(&primenv_mutex);
1489   return;
1490
1491 }  /* end of prime_env_iter */
1492 /*}}}*/
1493
1494
1495 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1496 /* Define or delete an element in the same "environment" as
1497  * vmstrnenv().  If an element is to be deleted, it's removed from
1498  * the first place it's found.  If it's to be set, it's set in the
1499  * place designated by the first element of the table vector.
1500  * Like setenv() returns 0 for success, non-zero on error.
1501  */
1502 int
1503 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1504 {
1505     const char *cp1;
1506     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1507     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1508     int nseg = 0, j;
1509     unsigned long int retsts, usermode = PSL$C_USER;
1510     struct itmlst_3 *ile, *ilist;
1511     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1512                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1513                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1514     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1515     $DESCRIPTOR(local,"_LOCAL");
1516
1517     if (!lnm) {
1518         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1519         return SS$_IVLOGNAM;
1520     }
1521
1522     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1523       *cp2 = _toupper(*cp1);
1524       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1525         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1526         return SS$_IVLOGNAM;
1527       }
1528     }
1529     lnmdsc.dsc$w_length = cp1 - lnm;
1530     if (!tabvec || !*tabvec) tabvec = env_tables;
1531
1532     if (!eqv) {  /* we're deleting n element */
1533       for (curtab = 0; tabvec[curtab]; curtab++) {
1534         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1535         int i;
1536           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1537             if ((cp1 = strchr(environ[i],'=')) &&
1538                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1539                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1540 #ifdef HAS_SETENV
1541               return setenv(lnm,"",1) ? vaxc$errno : 0;
1542             }
1543           }
1544           ivenv = 1; retsts = SS$_NOLOGNAM;
1545 #else
1546               if (ckWARN(WARN_INTERNAL))
1547                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1548               ivenv = 1; retsts = SS$_NOSUCHPGM;
1549               break;
1550             }
1551           }
1552 #endif
1553         }
1554         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1555                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1556           unsigned int symtype;
1557           if (tabvec[curtab]->dsc$w_length == 12 &&
1558               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1559               !str$case_blind_compare(&tmpdsc,&local))
1560             symtype = LIB$K_CLI_LOCAL_SYM;
1561           else symtype = LIB$K_CLI_GLOBAL_SYM;
1562           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1563           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1564           if (retsts == LIB$_NOSUCHSYM) continue;
1565           break;
1566         }
1567         else if (!ivlnm) {
1568           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1569           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1570           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1571           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1572           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1573         }
1574       }
1575     }
1576     else {  /* we're defining a value */
1577       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1578 #ifdef HAS_SETENV
1579         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1580 #else
1581         if (ckWARN(WARN_INTERNAL))
1582           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1583         retsts = SS$_NOSUCHPGM;
1584 #endif
1585       }
1586       else {
1587         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1588         eqvdsc.dsc$w_length  = strlen(eqv);
1589         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1590             !str$case_blind_compare(&tmpdsc,&clisym)) {
1591           unsigned int symtype;
1592           if (tabvec[0]->dsc$w_length == 12 &&
1593               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1594                !str$case_blind_compare(&tmpdsc,&local))
1595             symtype = LIB$K_CLI_LOCAL_SYM;
1596           else symtype = LIB$K_CLI_GLOBAL_SYM;
1597           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1598         }
1599         else {
1600           if (!*eqv) eqvdsc.dsc$w_length = 1;
1601           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1602
1603             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1604             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1605               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1606                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1607               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1608               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1609             }
1610
1611             Newx(ilist,nseg+1,struct itmlst_3);
1612             ile = ilist;
1613             if (!ile) {
1614               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1615               return SS$_INSFMEM;
1616             }
1617             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1618
1619             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1620               ile->itmcode = LNM$_STRING;
1621               ile->bufadr = c;
1622               if ((j+1) == nseg) {
1623                 ile->buflen = strlen(c);
1624                 /* in case we are truncating one that's too long */
1625                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1626               }
1627               else {
1628                 ile->buflen = LNM$C_NAMLENGTH;
1629               }
1630             }
1631
1632             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1633             Safefree (ilist);
1634           }
1635           else {
1636             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1637           }
1638         }
1639       }
1640     }
1641     if (!(retsts & 1)) {
1642       switch (retsts) {
1643         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1644         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1645           set_errno(EVMSERR); break;
1646         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1647         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1648           set_errno(EINVAL); break;
1649         case SS$_NOPRIV:
1650           set_errno(EACCES); break;
1651         default:
1652           _ckvmssts(retsts);
1653           set_errno(EVMSERR);
1654        }
1655        set_vaxc_errno(retsts);
1656        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1657     }
1658     else {
1659       /* We reset error values on success because Perl does an hv_fetch()
1660        * before each hv_store(), and if the thing we're setting didn't
1661        * previously exist, we've got a leftover error message.  (Of course,
1662        * this fails in the face of
1663        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1664        * in that the error reported in $! isn't spurious,
1665        * but it's right more often than not.)
1666        */
1667       set_errno(0); set_vaxc_errno(retsts);
1668       return 0;
1669     }
1670
1671 }  /* end of vmssetenv() */
1672 /*}}}*/
1673
1674 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1675 /* This has to be a function since there's a prototype for it in proto.h */
1676 void
1677 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1678 {
1679     if (lnm && *lnm) {
1680       int len = strlen(lnm);
1681       if  (len == 7) {
1682         char uplnm[8];
1683         int i;
1684         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1685         if (!strcmp(uplnm,"DEFAULT")) {
1686           if (eqv && *eqv) my_chdir(eqv);
1687           return;
1688         }
1689     }
1690 #ifndef RTL_USES_UTC
1691     if (len == 6 || len == 2) {
1692       char uplnm[7];
1693       int i;
1694       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1695       uplnm[len] = '\0';
1696       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1697       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1698     }
1699 #endif
1700   }
1701   (void) vmssetenv(lnm,eqv,NULL);
1702 }
1703 /*}}}*/
1704
1705 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1706 /*  vmssetuserlnm
1707  *  sets a user-mode logical in the process logical name table
1708  *  used for redirection of sys$error
1709  */
1710 void
1711 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1712 {
1713     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1714     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1715     unsigned long int iss, attr = LNM$M_CONFINE;
1716     unsigned char acmode = PSL$C_USER;
1717     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1718                                  {0, 0, 0, 0}};
1719     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1720     d_name.dsc$w_length = strlen(name);
1721
1722     lnmlst[0].buflen = strlen(eqv);
1723     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1724
1725     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1726     if (!(iss&1)) lib$signal(iss);
1727 }
1728 /*}}}*/
1729
1730
1731 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1732 /* my_crypt - VMS password hashing
1733  * my_crypt() provides an interface compatible with the Unix crypt()
1734  * C library function, and uses sys$hash_password() to perform VMS
1735  * password hashing.  The quadword hashed password value is returned
1736  * as a NUL-terminated 8 character string.  my_crypt() does not change
1737  * the case of its string arguments; in order to match the behavior
1738  * of LOGINOUT et al., alphabetic characters in both arguments must
1739  *  be upcased by the caller.
1740  *
1741  * - fix me to call ACM services when available
1742  */
1743 char *
1744 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1745 {
1746 #   ifndef UAI$C_PREFERRED_ALGORITHM
1747 #     define UAI$C_PREFERRED_ALGORITHM 127
1748 #   endif
1749     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1750     unsigned short int salt = 0;
1751     unsigned long int sts;
1752     struct const_dsc {
1753         unsigned short int dsc$w_length;
1754         unsigned char      dsc$b_type;
1755         unsigned char      dsc$b_class;
1756         const char *       dsc$a_pointer;
1757     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1758        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1759     struct itmlst_3 uailst[3] = {
1760         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1761         { sizeof salt, UAI$_SALT,    &salt, 0},
1762         { 0,           0,            NULL,  NULL}};
1763     static char hash[9];
1764
1765     usrdsc.dsc$w_length = strlen(usrname);
1766     usrdsc.dsc$a_pointer = usrname;
1767     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1768       switch (sts) {
1769         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1770           set_errno(EACCES);
1771           break;
1772         case RMS$_RNF:
1773           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1774           break;
1775         default:
1776           set_errno(EVMSERR);
1777       }
1778       set_vaxc_errno(sts);
1779       if (sts != RMS$_RNF) return NULL;
1780     }
1781
1782     txtdsc.dsc$w_length = strlen(textpasswd);
1783     txtdsc.dsc$a_pointer = textpasswd;
1784     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1785       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1786     }
1787
1788     return (char *) hash;
1789
1790 }  /* end of my_crypt() */
1791 /*}}}*/
1792
1793
1794 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1795 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1796 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1797
1798 /* fixup barenames that are directories for internal use.
1799  * There have been problems with the consistent handling of UNIX
1800  * style directory names when routines are presented with a name that
1801  * has no directory delimitors at all.  So this routine will eventually
1802  * fix the issue.
1803  */
1804 static char * fixup_bare_dirnames(const char * name)
1805 {
1806   if (decc_disable_to_vms_logname_translation) {
1807 /* fix me */
1808   }
1809   return NULL;
1810 }
1811
1812 /* 8.3, remove() is now broken on symbolic links */
1813 static int rms_erase(const char * vmsname);
1814
1815
1816 /* mp_do_kill_file
1817  * A little hack to get around a bug in some implemenation of remove()
1818  * that do not know how to delete a directory
1819  *
1820  * Delete any file to which user has control access, regardless of whether
1821  * delete access is explicitly allowed.
1822  * Limitations: User must have write access to parent directory.
1823  *              Does not block signals or ASTs; if interrupted in midstream
1824  *              may leave file with an altered ACL.
1825  * HANDLE WITH CARE!
1826  */
1827 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1828 static int
1829 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1830 {
1831     char *vmsname;
1832     char *rslt;
1833     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1834     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1835     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1836     struct myacedef {
1837       unsigned char myace$b_length;
1838       unsigned char myace$b_type;
1839       unsigned short int myace$w_flags;
1840       unsigned long int myace$l_access;
1841       unsigned long int myace$l_ident;
1842     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1843                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1844       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1845      struct itmlst_3
1846        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1847                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1848        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1849        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1850        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1851        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1852
1853     /* Expand the input spec using RMS, since the CRTL remove() and
1854      * system services won't do this by themselves, so we may miss
1855      * a file "hiding" behind a logical name or search list. */
1856     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1857     if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1858
1859     rslt = do_rmsexpand(name,
1860                         vmsname,
1861                         0,
1862                         NULL,
1863                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
1864                         NULL,
1865                         NULL);
1866     if (rslt == NULL) {
1867         PerlMem_free(vmsname);
1868         return -1;
1869       }
1870
1871     /* Erase the file */
1872     rmsts = rms_erase(vmsname);
1873
1874     /* Did it succeed */
1875     if ($VMS_STATUS_SUCCESS(rmsts)) {
1876         PerlMem_free(vmsname);
1877         return 0;
1878       }
1879
1880     /* If not, can changing protections help? */
1881     if (rmsts != RMS$_PRV) {
1882       set_vaxc_errno(rmsts);
1883       PerlMem_free(vmsname);
1884       return -1;
1885     }
1886
1887     /* No, so we get our own UIC to use as a rights identifier,
1888      * and the insert an ACE at the head of the ACL which allows us
1889      * to delete the file.
1890      */
1891     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1892     fildsc.dsc$w_length = strlen(vmsname);
1893     fildsc.dsc$a_pointer = vmsname;
1894     cxt = 0;
1895     newace.myace$l_ident = oldace.myace$l_ident;
1896     rmsts = -1;
1897     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1898       switch (aclsts) {
1899         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1900           set_errno(ENOENT); break;
1901         case RMS$_DIR:
1902           set_errno(ENOTDIR); break;
1903         case RMS$_DEV:
1904           set_errno(ENODEV); break;
1905         case RMS$_SYN: case SS$_INVFILFOROP:
1906           set_errno(EINVAL); break;
1907         case RMS$_PRV:
1908           set_errno(EACCES); break;
1909         default:
1910           _ckvmssts(aclsts);
1911       }
1912       set_vaxc_errno(aclsts);
1913       PerlMem_free(vmsname);
1914       return -1;
1915     }
1916     /* Grab any existing ACEs with this identifier in case we fail */
1917     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1918     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1919                     || fndsts == SS$_NOMOREACE ) {
1920       /* Add the new ACE . . . */
1921       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1922         goto yourroom;
1923
1924       rmsts = rms_erase(vmsname);
1925       if ($VMS_STATUS_SUCCESS(rmsts)) {
1926         rmsts = 0;
1927         }
1928         else {
1929         rmsts = -1;
1930         /* We blew it - dir with files in it, no write priv for
1931          * parent directory, etc.  Put things back the way they were. */
1932         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1933           goto yourroom;
1934         if (fndsts & 1) {
1935           addlst[0].bufadr = &oldace;
1936           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1937             goto yourroom;
1938         }
1939       }
1940     }
1941
1942     yourroom:
1943     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1944     /* We just deleted it, so of course it's not there.  Some versions of
1945      * VMS seem to return success on the unlock operation anyhow (after all
1946      * the unlock is successful), but others don't.
1947      */
1948     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1949     if (aclsts & 1) aclsts = fndsts;
1950     if (!(aclsts & 1)) {
1951       set_errno(EVMSERR);
1952       set_vaxc_errno(aclsts);
1953     }
1954
1955     PerlMem_free(vmsname);
1956     return rmsts;
1957
1958 }  /* end of kill_file() */
1959 /*}}}*/
1960
1961
1962 /*{{{int do_rmdir(char *name)*/
1963 int
1964 Perl_do_rmdir(pTHX_ const char *name)
1965 {
1966     char * dirfile;
1967     int retval;
1968     Stat_t st;
1969
1970     dirfile = PerlMem_malloc(VMS_MAXRSS + 1);
1971     if (dirfile == NULL)
1972         _ckvmssts(SS$_INSFMEM);
1973
1974     /* Force to a directory specification */
1975     if (do_fileify_dirspec(name, dirfile, 0, NULL) == NULL) {
1976         PerlMem_free(dirfile);
1977         return -1;
1978     }
1979     if (Perl_flex_lstat(aTHX_ dirfile, &st) || !S_ISDIR(st.st_mode)) {
1980         errno = ENOTDIR;
1981         retval = -1;
1982     }
1983     else
1984         retval = mp_do_kill_file(aTHX_ dirfile, 1);
1985
1986     PerlMem_free(dirfile);
1987     return retval;
1988
1989 }  /* end of do_rmdir */
1990 /*}}}*/
1991
1992 /* kill_file
1993  * Delete any file to which user has control access, regardless of whether
1994  * delete access is explicitly allowed.
1995  * Limitations: User must have write access to parent directory.
1996  *              Does not block signals or ASTs; if interrupted in midstream
1997  *              may leave file with an altered ACL.
1998  * HANDLE WITH CARE!
1999  */
2000 /*{{{int kill_file(char *name)*/
2001 int
2002 Perl_kill_file(pTHX_ const char *name)
2003 {
2004     char rspec[NAM$C_MAXRSS+1];
2005     char *tspec;
2006     Stat_t st;
2007     int rmsts;
2008
2009    /* Remove() is allowed to delete directories, according to the X/Open
2010     * specifications.
2011     * This may need special handling to work with the ACL hacks.
2012      */
2013    if ((flex_lstat(name, &st) == 0) && S_ISDIR(st.st_mode)) {
2014         rmsts = Perl_do_rmdir(aTHX_ name);
2015         return rmsts;
2016     }
2017
2018    rmsts = mp_do_kill_file(aTHX_ name, 0);
2019
2020     return rmsts;
2021
2022 }  /* end of kill_file() */
2023 /*}}}*/
2024
2025
2026 /*{{{int my_mkdir(char *,Mode_t)*/
2027 int
2028 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2029 {
2030   STRLEN dirlen = strlen(dir);
2031
2032   /* zero length string sometimes gives ACCVIO */
2033   if (dirlen == 0) return -1;
2034
2035   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2036    * null file name/type.  However, it's commonplace under Unix,
2037    * so we'll allow it for a gain in portability.
2038    */
2039   if (dir[dirlen-1] == '/') {
2040     char *newdir = savepvn(dir,dirlen-1);
2041     int ret = mkdir(newdir,mode);
2042     Safefree(newdir);
2043     return ret;
2044   }
2045   else return mkdir(dir,mode);
2046 }  /* end of my_mkdir */
2047 /*}}}*/
2048
2049 /*{{{int my_chdir(char *)*/
2050 int
2051 Perl_my_chdir(pTHX_ const char *dir)
2052 {
2053   STRLEN dirlen = strlen(dir);
2054
2055   /* zero length string sometimes gives ACCVIO */
2056   if (dirlen == 0) return -1;
2057   const char *dir1;
2058
2059   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2060    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2061    * so that existing scripts do not need to be changed.
2062    */
2063   dir1 = dir;
2064   while ((dirlen > 0) && (*dir1 == ' ')) {
2065     dir1++;
2066     dirlen--;
2067   }
2068
2069   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2070    * that implies
2071    * null file name/type.  However, it's commonplace under Unix,
2072    * so we'll allow it for a gain in portability.
2073    *
2074    * - Preview- '/' will be valid soon on VMS
2075    */
2076   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2077     char *newdir = savepvn(dir1,dirlen-1);
2078     int ret = chdir(newdir);
2079     Safefree(newdir);
2080     return ret;
2081   }
2082   else return chdir(dir1);
2083 }  /* end of my_chdir */
2084 /*}}}*/
2085
2086
2087 /*{{{int my_chmod(char *, mode_t)*/
2088 int
2089 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2090 {
2091   STRLEN speclen = strlen(file_spec);
2092
2093   /* zero length string sometimes gives ACCVIO */
2094   if (speclen == 0) return -1;
2095
2096   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2097    * that implies null file name/type.  However, it's commonplace under Unix,
2098    * so we'll allow it for a gain in portability.
2099    *
2100    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2101    * in VMS file.dir notation.
2102    */
2103   if ((speclen > 1) && (file_spec[speclen-1] == '/')) {
2104     char *vms_src, *vms_dir, *rslt;
2105     int ret = -1;
2106     errno = EIO;
2107
2108     /* First convert this to a VMS format specification */
2109     vms_src = PerlMem_malloc(VMS_MAXRSS);
2110     if (vms_src == NULL)
2111         _ckvmssts(SS$_INSFMEM);
2112
2113     rslt = do_tovmsspec(file_spec, vms_src, 0, NULL);
2114     if (rslt == NULL) {
2115         /* If we fail, then not a file specification */
2116         PerlMem_free(vms_src);
2117         errno = EIO;
2118         return -1;
2119     }
2120
2121     /* Now make it a directory spec so chmod is happy */
2122     vms_dir = PerlMem_malloc(VMS_MAXRSS + 1);
2123     if (vms_dir == NULL)
2124         _ckvmssts(SS$_INSFMEM);
2125     rslt = do_fileify_dirspec(vms_src, vms_dir, 0, NULL);
2126     PerlMem_free(vms_src);
2127
2128     /* Now do it */
2129     if (rslt != NULL) {
2130         ret = chmod(vms_dir, mode);
2131     } else {
2132         errno = EIO;
2133     }
2134     PerlMem_free(vms_dir);
2135     return ret;
2136   }
2137   else return chmod(file_spec, mode);
2138 }  /* end of my_chmod */
2139 /*}}}*/
2140
2141
2142 /*{{{FILE *my_tmpfile()*/
2143 FILE *
2144 my_tmpfile(void)
2145 {
2146   FILE *fp;
2147   char *cp;
2148
2149   if ((fp = tmpfile())) return fp;
2150
2151   cp = PerlMem_malloc(L_tmpnam+24);
2152   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2153
2154   if (decc_filename_unix_only == 0)
2155     strcpy(cp,"Sys$Scratch:");
2156   else
2157     strcpy(cp,"/tmp/");
2158   tmpnam(cp+strlen(cp));
2159   strcat(cp,".Perltmp");
2160   fp = fopen(cp,"w+","fop=dlt");
2161   PerlMem_free(cp);
2162   return fp;
2163 }
2164 /*}}}*/
2165
2166
2167 #ifndef HOMEGROWN_POSIX_SIGNALS
2168 /*
2169  * The C RTL's sigaction fails to check for invalid signal numbers so we
2170  * help it out a bit.  The docs are correct, but the actual routine doesn't
2171  * do what the docs say it will.
2172  */
2173 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2174 int
2175 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2176                    struct sigaction* oact)
2177 {
2178   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2179         SETERRNO(EINVAL, SS$_INVARG);
2180         return -1;
2181   }
2182   return sigaction(sig, act, oact);
2183 }
2184 /*}}}*/
2185 #endif
2186
2187 #ifdef KILL_BY_SIGPRC
2188 #include <errnodef.h>
2189
2190 /* We implement our own kill() using the undocumented system service
2191    sys$sigprc for one of two reasons:
2192
2193    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2194    target process to do a sys$exit, which usually can't be handled
2195    gracefully...certainly not by Perl and the %SIG{} mechanism.
2196
2197    2.) If the kill() in the CRTL can't be called from a signal
2198    handler without disappearing into the ether, i.e., the signal
2199    it purportedly sends is never trapped. Still true as of VMS 7.3.
2200
2201    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2202    in the target process rather than calling sys$exit.
2203
2204    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2205    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2206    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2207    with condition codes C$_SIG0+nsig*8, catching the exception on the
2208    target process and resignaling with appropriate arguments.
2209
2210    But we don't have that VMS 7.0+ exception handler, so if you
2211    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2212
2213    Also note that SIGTERM is listed in the docs as being "unimplemented",
2214    yet always seems to be signaled with a VMS condition code of 4 (and
2215    correctly handled for that code).  So we hardwire it in.
2216
2217    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2218    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2219    than signalling with an unrecognized (and unhandled by CRTL) code.
2220 */
2221
2222 #define _MY_SIG_MAX 28
2223
2224 static unsigned int
2225 Perl_sig_to_vmscondition_int(int sig)
2226 {
2227     static unsigned int sig_code[_MY_SIG_MAX+1] =
2228     {
2229         0,                  /*  0 ZERO     */
2230         SS$_HANGUP,         /*  1 SIGHUP   */
2231         SS$_CONTROLC,       /*  2 SIGINT   */
2232         SS$_CONTROLY,       /*  3 SIGQUIT  */
2233         SS$_RADRMOD,        /*  4 SIGILL   */
2234         SS$_BREAK,          /*  5 SIGTRAP  */
2235         SS$_OPCCUS,         /*  6 SIGABRT  */
2236         SS$_COMPAT,         /*  7 SIGEMT   */
2237 #ifdef __VAX
2238         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2239 #else
2240         SS$_HPARITH,        /*  8 SIGFPE AXP */
2241 #endif
2242         SS$_ABORT,          /*  9 SIGKILL  */
2243         SS$_ACCVIO,         /* 10 SIGBUS   */
2244         SS$_ACCVIO,         /* 11 SIGSEGV  */
2245         SS$_BADPARAM,       /* 12 SIGSYS   */
2246         SS$_NOMBX,          /* 13 SIGPIPE  */
2247         SS$_ASTFLT,         /* 14 SIGALRM  */
2248         4,                  /* 15 SIGTERM  */
2249         0,                  /* 16 SIGUSR1  */
2250         0,                  /* 17 SIGUSR2  */
2251         0,                  /* 18 */
2252         0,                  /* 19 */
2253         0,                  /* 20 SIGCHLD  */
2254         0,                  /* 21 SIGCONT  */
2255         0,                  /* 22 SIGSTOP  */
2256         0,                  /* 23 SIGTSTP  */
2257         0,                  /* 24 SIGTTIN  */
2258         0,                  /* 25 SIGTTOU  */
2259         0,                  /* 26 */
2260         0,                  /* 27 */
2261         0                   /* 28 SIGWINCH  */
2262     };
2263
2264 #if __VMS_VER >= 60200000
2265     static int initted = 0;
2266     if (!initted) {
2267         initted = 1;
2268         sig_code[16] = C$_SIGUSR1;
2269         sig_code[17] = C$_SIGUSR2;
2270 #if __CRTL_VER >= 70000000
2271         sig_code[20] = C$_SIGCHLD;
2272 #endif
2273 #if __CRTL_VER >= 70300000
2274         sig_code[28] = C$_SIGWINCH;
2275 #endif
2276     }
2277 #endif
2278
2279     if (sig < _SIG_MIN) return 0;
2280     if (sig > _MY_SIG_MAX) return 0;
2281     return sig_code[sig];
2282 }
2283
2284 unsigned int
2285 Perl_sig_to_vmscondition(int sig)
2286 {
2287 #ifdef SS$_DEBUG
2288     if (vms_debug_on_exception != 0)
2289         lib$signal(SS$_DEBUG);
2290 #endif
2291     return Perl_sig_to_vmscondition_int(sig);
2292 }
2293
2294
2295 int
2296 Perl_my_kill(int pid, int sig)
2297 {
2298     dTHX;
2299     int iss;
2300     unsigned int code;
2301     int sys$sigprc(unsigned int *pidadr,
2302                      struct dsc$descriptor_s *prcname,
2303                      unsigned int code);
2304
2305      /* sig 0 means validate the PID */
2306     /*------------------------------*/
2307     if (sig == 0) {
2308         const unsigned long int jpicode = JPI$_PID;
2309         pid_t ret_pid;
2310         int status;
2311         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2312         if ($VMS_STATUS_SUCCESS(status))
2313            return 0;
2314         switch (status) {
2315         case SS$_NOSUCHNODE:
2316         case SS$_UNREACHABLE:
2317         case SS$_NONEXPR:
2318            errno = ESRCH;
2319            break;
2320         case SS$_NOPRIV:
2321            errno = EPERM;
2322            break;
2323         default:
2324            errno = EVMSERR;
2325         }
2326         vaxc$errno=status;
2327         return -1;
2328     }
2329
2330     code = Perl_sig_to_vmscondition_int(sig);
2331
2332     if (!code) {
2333         SETERRNO(EINVAL, SS$_BADPARAM);
2334         return -1;
2335     }
2336
2337     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2338      * signals are to be sent to multiple processes.
2339      *  pid = 0 - all processes in group except ones that the system exempts
2340      *  pid = -1 - all processes except ones that the system exempts
2341      *  pid = -n - all processes in group (abs(n)) except ...
2342      * For now, just report as not supported.
2343      */
2344
2345     if (pid <= 0) {
2346         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2347         return -1;
2348     }
2349
2350     iss = sys$sigprc((unsigned int *)&pid,0,code);
2351     if (iss&1) return 0;
2352
2353     switch (iss) {
2354       case SS$_NOPRIV:
2355         set_errno(EPERM);  break;
2356       case SS$_NONEXPR:
2357       case SS$_NOSUCHNODE:
2358       case SS$_UNREACHABLE:
2359         set_errno(ESRCH);  break;
2360       case SS$_INSFMEM:
2361         set_errno(ENOMEM); break;
2362       default:
2363         _ckvmssts(iss);
2364         set_errno(EVMSERR);
2365     }
2366     set_vaxc_errno(iss);
2367
2368     return -1;
2369 }
2370 #endif
2371
2372 /* Routine to convert a VMS status code to a UNIX status code.
2373 ** More tricky than it appears because of conflicting conventions with
2374 ** existing code.
2375 **
2376 ** VMS status codes are a bit mask, with the least significant bit set for
2377 ** success.
2378 **
2379 ** Special UNIX status of EVMSERR indicates that no translation is currently
2380 ** available, and programs should check the VMS status code.
2381 **
2382 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2383 ** decoding.
2384 */
2385
2386 #ifndef C_FACILITY_NO
2387 #define C_FACILITY_NO 0x350000
2388 #endif
2389 #ifndef DCL_IVVERB
2390 #define DCL_IVVERB 0x38090
2391 #endif
2392
2393 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2394 {
2395 int facility;
2396 int fac_sp;
2397 int msg_no;
2398 int msg_status;
2399 int unix_status;
2400
2401   /* Assume the best or the worst */
2402   if (vms_status & STS$M_SUCCESS)
2403     unix_status = 0;
2404   else
2405     unix_status = EVMSERR;
2406
2407   msg_status = vms_status & ~STS$M_CONTROL;
2408
2409   facility = vms_status & STS$M_FAC_NO;
2410   fac_sp = vms_status & STS$M_FAC_SP;
2411   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2412
2413   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2414     switch(msg_no) {
2415     case SS$_NORMAL:
2416         unix_status = 0;
2417         break;
2418     case SS$_ACCVIO:
2419         unix_status = EFAULT;
2420         break;
2421     case SS$_DEVOFFLINE:
2422         unix_status = EBUSY;
2423         break;
2424     case SS$_CLEARED:
2425         unix_status = ENOTCONN;
2426         break;
2427     case SS$_IVCHAN:
2428     case SS$_IVLOGNAM:
2429     case SS$_BADPARAM:
2430     case SS$_IVLOGTAB:
2431     case SS$_NOLOGNAM:
2432     case SS$_NOLOGTAB:
2433     case SS$_INVFILFOROP:
2434     case SS$_INVARG:
2435     case SS$_NOSUCHID:
2436     case SS$_IVIDENT:
2437         unix_status = EINVAL;
2438         break;
2439     case SS$_UNSUPPORTED:
2440         unix_status = ENOTSUP;
2441         break;
2442     case SS$_FILACCERR:
2443     case SS$_NOGRPPRV:
2444     case SS$_NOSYSPRV:
2445         unix_status = EACCES;
2446         break;
2447     case SS$_DEVICEFULL:
2448         unix_status = ENOSPC;
2449         break;
2450     case SS$_NOSUCHDEV:
2451         unix_status = ENODEV;
2452         break;
2453     case SS$_NOSUCHFILE:
2454     case SS$_NOSUCHOBJECT:
2455         unix_status = ENOENT;
2456         break;
2457     case SS$_ABORT:                                 /* Fatal case */
2458     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2459     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2460         unix_status = EINTR;
2461         break;
2462     case SS$_BUFFEROVF:
2463         unix_status = E2BIG;
2464         break;
2465     case SS$_INSFMEM:
2466         unix_status = ENOMEM;
2467         break;
2468     case SS$_NOPRIV:
2469         unix_status = EPERM;
2470         break;
2471     case SS$_NOSUCHNODE:
2472     case SS$_UNREACHABLE:
2473         unix_status = ESRCH;
2474         break;
2475     case SS$_NONEXPR:
2476         unix_status = ECHILD;
2477         break;
2478     default:
2479         if ((facility == 0) && (msg_no < 8)) {
2480           /* These are not real VMS status codes so assume that they are
2481           ** already UNIX status codes
2482           */
2483           unix_status = msg_no;
2484           break;
2485         }
2486     }
2487   }
2488   else {
2489     /* Translate a POSIX exit code to a UNIX exit code */
2490     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2491         unix_status = (msg_no & 0x07F8) >> 3;
2492     }
2493     else {
2494
2495          /* Documented traditional behavior for handling VMS child exits */
2496         /*--------------------------------------------------------------*/
2497         if (child_flag != 0) {
2498
2499              /* Success / Informational return 0 */
2500             /*----------------------------------*/
2501             if (msg_no & STS$K_SUCCESS)
2502                 return 0;
2503
2504              /* Warning returns 1 */
2505             /*-------------------*/
2506             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2507                 return 1;
2508
2509              /* Everything else pass through the severity bits */
2510             /*------------------------------------------------*/
2511             return (msg_no & STS$M_SEVERITY);
2512         }
2513
2514          /* Normal VMS status to ERRNO mapping attempt */
2515         /*--------------------------------------------*/
2516         switch(msg_status) {
2517         /* case RMS$_EOF: */ /* End of File */
2518         case RMS$_FNF:  /* File Not Found */
2519         case RMS$_DNF:  /* Dir Not Found */
2520                 unix_status = ENOENT;
2521                 break;
2522         case RMS$_RNF:  /* Record Not Found */
2523                 unix_status = ESRCH;
2524                 break;
2525         case RMS$_DIR:
2526                 unix_status = ENOTDIR;
2527                 break;
2528         case RMS$_DEV:
2529                 unix_status = ENODEV;
2530                 break;
2531         case RMS$_IFI:
2532         case RMS$_FAC:
2533         case RMS$_ISI:
2534                 unix_status = EBADF;
2535                 break;
2536         case RMS$_FEX:
2537                 unix_status = EEXIST;
2538                 break;
2539         case RMS$_SYN:
2540         case RMS$_FNM:
2541         case LIB$_INVSTRDES:
2542         case LIB$_INVARG:
2543         case LIB$_NOSUCHSYM:
2544         case LIB$_INVSYMNAM:
2545         case DCL_IVVERB:
2546                 unix_status = EINVAL;
2547                 break;
2548         case CLI$_BUFOVF:
2549         case RMS$_RTB:
2550         case CLI$_TKNOVF:
2551         case CLI$_RSLOVF:
2552                 unix_status = E2BIG;
2553                 break;
2554         case RMS$_PRV:  /* No privilege */
2555         case RMS$_ACC:  /* ACP file access failed */
2556         case RMS$_WLK:  /* Device write locked */
2557                 unix_status = EACCES;
2558                 break;
2559         /* case RMS$_NMF: */  /* No more files */
2560         }
2561     }
2562   }
2563
2564   return unix_status;
2565 }
2566
2567 /* Try to guess at what VMS error status should go with a UNIX errno
2568  * value.  This is hard to do as there could be many possible VMS
2569  * error statuses that caused the errno value to be set.
2570  */
2571
2572 int Perl_unix_status_to_vms(int unix_status)
2573 {
2574 int test_unix_status;
2575
2576      /* Trivial cases first */
2577     /*---------------------*/
2578     if (unix_status == EVMSERR)
2579         return vaxc$errno;
2580
2581      /* Is vaxc$errno sane? */
2582     /*---------------------*/
2583     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2584     if (test_unix_status == unix_status)
2585         return vaxc$errno;
2586
2587      /* If way out of range, must be VMS code already */
2588     /*-----------------------------------------------*/
2589     if (unix_status > EVMSERR)
2590         return unix_status;
2591
2592      /* If out of range, punt */
2593     /*-----------------------*/
2594     if (unix_status > __ERRNO_MAX)
2595         return SS$_ABORT;
2596
2597
2598      /* Ok, now we have to do it the hard way. */
2599     /*----------------------------------------*/
2600     switch(unix_status) {
2601     case 0:     return SS$_NORMAL;
2602     case EPERM: return SS$_NOPRIV;
2603     case ENOENT: return SS$_NOSUCHOBJECT;
2604     case ESRCH: return SS$_UNREACHABLE;
2605     case EINTR: return SS$_ABORT;
2606     /* case EIO: */
2607     /* case ENXIO:  */
2608     case E2BIG: return SS$_BUFFEROVF;
2609     /* case ENOEXEC */
2610     case EBADF: return RMS$_IFI;
2611     case ECHILD: return SS$_NONEXPR;
2612     /* case EAGAIN */
2613     case ENOMEM: return SS$_INSFMEM;
2614     case EACCES: return SS$_FILACCERR;
2615     case EFAULT: return SS$_ACCVIO;
2616     /* case ENOTBLK */
2617     case EBUSY: return SS$_DEVOFFLINE;
2618     case EEXIST: return RMS$_FEX;
2619     /* case EXDEV */
2620     case ENODEV: return SS$_NOSUCHDEV;
2621     case ENOTDIR: return RMS$_DIR;
2622     /* case EISDIR */
2623     case EINVAL: return SS$_INVARG;
2624     /* case ENFILE */
2625     /* case EMFILE */
2626     /* case ENOTTY */
2627     /* case ETXTBSY */
2628     /* case EFBIG */
2629     case ENOSPC: return SS$_DEVICEFULL;
2630     case ESPIPE: return LIB$_INVARG;
2631     /* case EROFS: */
2632     /* case EMLINK: */
2633     /* case EPIPE: */
2634     /* case EDOM */
2635     case ERANGE: return LIB$_INVARG;
2636     /* case EWOULDBLOCK */
2637     /* case EINPROGRESS */
2638     /* case EALREADY */
2639     /* case ENOTSOCK */
2640     /* case EDESTADDRREQ */
2641     /* case EMSGSIZE */
2642     /* case EPROTOTYPE */
2643     /* case ENOPROTOOPT */
2644     /* case EPROTONOSUPPORT */
2645     /* case ESOCKTNOSUPPORT */
2646     /* case EOPNOTSUPP */
2647     /* case EPFNOSUPPORT */
2648     /* case EAFNOSUPPORT */
2649     /* case EADDRINUSE */
2650     /* case EADDRNOTAVAIL */
2651     /* case ENETDOWN */
2652     /* case ENETUNREACH */
2653     /* case ENETRESET */
2654     /* case ECONNABORTED */
2655     /* case ECONNRESET */
2656     /* case ENOBUFS */
2657     /* case EISCONN */
2658     case ENOTCONN: return SS$_CLEARED;
2659     /* case ESHUTDOWN */
2660     /* case ETOOMANYREFS */
2661     /* case ETIMEDOUT */
2662     /* case ECONNREFUSED */
2663     /* case ELOOP */
2664     /* case ENAMETOOLONG */
2665     /* case EHOSTDOWN */
2666     /* case EHOSTUNREACH */
2667     /* case ENOTEMPTY */
2668     /* case EPROCLIM */
2669     /* case EUSERS  */
2670     /* case EDQUOT  */
2671     /* case ENOMSG  */
2672     /* case EIDRM */
2673     /* case EALIGN */
2674     /* case ESTALE */
2675     /* case EREMOTE */
2676     /* case ENOLCK */
2677     /* case ENOSYS */
2678     /* case EFTYPE */
2679     /* case ECANCELED */
2680     /* case EFAIL */
2681     /* case EINPROG */
2682     case ENOTSUP:
2683         return SS$_UNSUPPORTED;
2684     /* case EDEADLK */
2685     /* case ENWAIT */
2686     /* case EILSEQ */
2687     /* case EBADCAT */
2688     /* case EBADMSG */
2689     /* case EABANDONED */
2690     default:
2691         return SS$_ABORT; /* punt */
2692     }
2693
2694   return SS$_ABORT; /* Should not get here */
2695 }
2696
2697
2698 /* default piping mailbox size */
2699 #define PERL_BUFSIZ        512
2700
2701
2702 static void
2703 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2704 {
2705   unsigned long int mbxbufsiz;
2706   static unsigned long int syssize = 0;
2707   unsigned long int dviitm = DVI$_DEVNAM;
2708   char csize[LNM$C_NAMLENGTH+1];
2709   int sts;
2710
2711   if (!syssize) {
2712     unsigned long syiitm = SYI$_MAXBUF;
2713     /*
2714      * Get the SYSGEN parameter MAXBUF
2715      *
2716      * If the logical 'PERL_MBX_SIZE' is defined
2717      * use the value of the logical instead of PERL_BUFSIZ, but
2718      * keep the size between 128 and MAXBUF.
2719      *
2720      */
2721     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2722   }
2723
2724   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2725       mbxbufsiz = atoi(csize);
2726   } else {
2727       mbxbufsiz = PERL_BUFSIZ;
2728   }
2729   if (mbxbufsiz < 128) mbxbufsiz = 128;
2730   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2731
2732   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2733
2734   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2735   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2736
2737 }  /* end of create_mbx() */
2738
2739
2740 /*{{{  my_popen and my_pclose*/
2741
2742 typedef struct _iosb           IOSB;
2743 typedef struct _iosb*         pIOSB;
2744 typedef struct _pipe           Pipe;
2745 typedef struct _pipe*         pPipe;
2746 typedef struct pipe_details    Info;
2747 typedef struct pipe_details*  pInfo;
2748 typedef struct _srqp            RQE;
2749 typedef struct _srqp*          pRQE;
2750 typedef struct _tochildbuf      CBuf;
2751 typedef struct _tochildbuf*    pCBuf;
2752
2753 struct _iosb {
2754     unsigned short status;
2755     unsigned short count;
2756     unsigned long  dvispec;
2757 };
2758
2759 #pragma member_alignment save
2760 #pragma nomember_alignment quadword
2761 struct _srqp {          /* VMS self-relative queue entry */
2762     unsigned long qptr[2];
2763 };
2764 #pragma member_alignment restore
2765 static RQE  RQE_ZERO = {0,0};
2766
2767 struct _tochildbuf {
2768     RQE             q;
2769     int             eof;
2770     unsigned short  size;
2771     char            *buf;
2772 };
2773
2774 struct _pipe {
2775     RQE            free;
2776     RQE            wait;
2777     int            fd_out;
2778     unsigned short chan_in;
2779     unsigned short chan_out;
2780     char          *buf;
2781     unsigned int   bufsize;
2782     IOSB           iosb;
2783     IOSB           iosb2;
2784     int           *pipe_done;
2785     int            retry;
2786     int            type;
2787     int            shut_on_empty;
2788     int            need_wake;
2789     pPipe         *home;
2790     pInfo          info;
2791     pCBuf          curr;
2792     pCBuf          curr2;
2793 #if defined(PERL_IMPLICIT_CONTEXT)
2794     void            *thx;           /* Either a thread or an interpreter */
2795                                     /* pointer, depending on how we're built */
2796 #endif
2797 };
2798
2799
2800 struct pipe_details
2801 {
2802     pInfo           next;
2803     PerlIO *fp;  /* file pointer to pipe mailbox */
2804     int useFILE; /* using stdio, not perlio */
2805     int pid;   /* PID of subprocess */
2806     int mode;  /* == 'r' if pipe open for reading */
2807     int done;  /* subprocess has completed */
2808     int waiting; /* waiting for completion/closure */
2809     int             closing;        /* my_pclose is closing this pipe */
2810     unsigned long   completion;     /* termination status of subprocess */
2811     pPipe           in;             /* pipe in to sub */
2812     pPipe           out;            /* pipe out of sub */
2813     pPipe           err;            /* pipe of sub's sys$error */
2814     int             in_done;        /* true when in pipe finished */
2815     int             out_done;
2816     int             err_done;
2817     unsigned short  xchan;          /* channel to debug xterm */
2818     unsigned short  xchan_valid;    /* channel is assigned */
2819 };
2820
2821 struct exit_control_block
2822 {
2823     struct exit_control_block *flink;
2824     unsigned long int   (*exit_routine)();
2825     unsigned long int arg_count;
2826     unsigned long int *status_address;
2827     unsigned long int exit_status;
2828 };
2829
2830 typedef struct _closed_pipes    Xpipe;
2831 typedef struct _closed_pipes*  pXpipe;
2832
2833 struct _closed_pipes {
2834     int             pid;            /* PID of subprocess */
2835     unsigned long   completion;     /* termination status of subprocess */
2836 };
2837 #define NKEEPCLOSED 50
2838 static Xpipe closed_list[NKEEPCLOSED];
2839 static int   closed_index = 0;
2840 static int   closed_num = 0;
2841
2842 #define RETRY_DELAY     "0 ::0.20"
2843 #define MAX_RETRY              50
2844
2845 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2846 static unsigned long mypid;
2847 static unsigned long delaytime[2];
2848
2849 static pInfo open_pipes = NULL;
2850 static $DESCRIPTOR(nl_desc, "NL:");
2851
2852 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2853
2854
2855
2856 static unsigned long int
2857 pipe_exit_routine(pTHX)
2858 {
2859     pInfo info;
2860     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2861     int sts, did_stuff, need_eof, j;
2862
2863    /*
2864     * Flush any pending i/o, but since we are in process run-down, be
2865     * careful about referencing PerlIO structures that may already have
2866     * been deallocated.  We may not even have an interpreter anymore.
2867     */
2868     info = open_pipes;
2869     while (info) {
2870         if (info->fp) {
2871            if (!info->useFILE
2872 #if defined(USE_ITHREADS)
2873              && my_perl
2874 #endif
2875              && PL_perlio_fd_refcnt)
2876                PerlIO_flush(info->fp);
2877            else
2878                fflush((FILE *)info->fp);
2879         }
2880         info = info->next;
2881     }
2882
2883     /*
2884      next we try sending an EOF...ignore if doesn't work, make sure we
2885      don't hang
2886     */
2887     did_stuff = 0;
2888     info = open_pipes;
2889
2890     while (info) {
2891       int need_eof;
2892       _ckvmssts_noperl(sys$setast(0));
2893       if (info->in && !info->in->shut_on_empty) {
2894         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2895                           0, 0, 0, 0, 0, 0));
2896         info->waiting = 1;
2897         did_stuff = 1;
2898       }
2899       _ckvmssts_noperl(sys$setast(1));
2900       info = info->next;
2901     }
2902
2903     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2904
2905     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2906         int nwait = 0;
2907
2908         info = open_pipes;
2909         while (info) {
2910           _ckvmssts_noperl(sys$setast(0));
2911           if (info->waiting && info->done)
2912                 info->waiting = 0;
2913           nwait += info->waiting;
2914           _ckvmssts_noperl(sys$setast(1));
2915           info = info->next;
2916         }
2917         if (!nwait) break;
2918         sleep(1);
2919     }
2920
2921     did_stuff = 0;
2922     info = open_pipes;
2923     while (info) {
2924       _ckvmssts_noperl(sys$setast(0));
2925       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2926         sts = sys$forcex(&info->pid,0,&abort);
2927         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2928         did_stuff = 1;
2929       }
2930       _ckvmssts_noperl(sys$setast(1));
2931       info = info->next;
2932     }
2933
2934     /* again, wait for effect */
2935
2936     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2937         int nwait = 0;
2938
2939         info = open_pipes;
2940         while (info) {
2941           _ckvmssts_noperl(sys$setast(0));
2942           if (info->waiting && info->done)
2943                 info->waiting = 0;
2944           nwait += info->waiting;
2945           _ckvmssts_noperl(sys$setast(1));
2946           info = info->next;
2947         }
2948         if (!nwait) break;
2949         sleep(1);
2950     }
2951
2952     info = open_pipes;
2953     while (info) {
2954       _ckvmssts_noperl(sys$setast(0));
2955       if (!info->done) {  /* We tried to be nice . . . */
2956         sts = sys$delprc(&info->pid,0);
2957         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2958         info->done = 1;  /* sys$delprc is as done as we're going to get. */
2959       }
2960       _ckvmssts_noperl(sys$setast(1));
2961       info = info->next;
2962     }
2963
2964     while(open_pipes) {
2965       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2966       else if (!(sts & 1)) retsts = sts;
2967     }
2968     return retsts;
2969 }
2970
2971 static struct exit_control_block pipe_exitblock =
2972        {(struct exit_control_block *) 0,
2973         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2974
2975 static void pipe_mbxtofd_ast(pPipe p);
2976 static void pipe_tochild1_ast(pPipe p);
2977 static void pipe_tochild2_ast(pPipe p);
2978
2979 static void
2980 popen_completion_ast(pInfo info)
2981 {
2982   pInfo i = open_pipes;
2983   int iss;
2984   int sts;
2985   pXpipe x;
2986
2987   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2988   closed_list[closed_index].pid = info->pid;
2989   closed_list[closed_index].completion = info->completion;
2990   closed_index++;
2991   if (closed_index == NKEEPCLOSED)
2992     closed_index = 0;
2993   closed_num++;
2994
2995   while (i) {
2996     if (i == info) break;
2997     i = i->next;
2998   }
2999   if (!i) return;       /* unlinked, probably freed too */
3000
3001   info->done = TRUE;
3002
3003 /*
3004     Writing to subprocess ...
3005             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3006
3007             chan_out may be waiting for "done" flag, or hung waiting
3008             for i/o completion to child...cancel the i/o.  This will
3009             put it into "snarf mode" (done but no EOF yet) that discards
3010             input.
3011
3012     Output from subprocess (stdout, stderr) needs to be flushed and
3013     shut down.   We try sending an EOF, but if the mbx is full the pipe
3014     routine should still catch the "shut_on_empty" flag, telling it to
3015     use immediate-style reads so that "mbx empty" -> EOF.
3016
3017
3018 */
3019   if (info->in && !info->in_done) {               /* only for mode=w */
3020         if (info->in->shut_on_empty && info->in->need_wake) {
3021             info->in->need_wake = FALSE;
3022             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3023         } else {
3024             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3025         }
3026   }
3027
3028   if (info->out && !info->out_done) {             /* were we also piping output? */
3029       info->out->shut_on_empty = TRUE;
3030       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3031       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3032       _ckvmssts_noperl(iss);
3033   }
3034
3035   if (info->err && !info->err_done) {        /* we were piping stderr */
3036         info->err->shut_on_empty = TRUE;
3037         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3038         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3039         _ckvmssts_noperl(iss);
3040   }
3041   _ckvmssts_noperl(sys$setef(pipe_ef));
3042
3043 }
3044
3045 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3046 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3047
3048 /*
3049     we actually differ from vmstrnenv since we use this to
3050     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3051     are pointing to the same thing
3052 */
3053
3054 static unsigned short
3055 popen_translate(pTHX_ char *logical, char *result)
3056 {
3057     int iss;
3058     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3059     $DESCRIPTOR(d_log,"");
3060     struct _il3 {
3061         unsigned short length;
3062         unsigned short code;
3063         char *         buffer_addr;
3064         unsigned short *retlenaddr;
3065     } itmlst[2];
3066     unsigned short l, ifi;
3067
3068     d_log.dsc$a_pointer = logical;
3069     d_log.dsc$w_length  = strlen(logical);
3070
3071     itmlst[0].code = LNM$_STRING;
3072     itmlst[0].length = 255;
3073     itmlst[0].buffer_addr = result;
3074     itmlst[0].retlenaddr = &l;
3075
3076     itmlst[1].code = 0;
3077     itmlst[1].length = 0;
3078     itmlst[1].buffer_addr = 0;
3079     itmlst[1].retlenaddr = 0;
3080
3081     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3082     if (iss == SS$_NOLOGNAM) {
3083         iss = SS$_NORMAL;
3084         l = 0;
3085     }
3086     if (!(iss&1)) lib$signal(iss);
3087     result[l] = '\0';
3088 /*
3089     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
3090     strip it off and return the ifi, if any
3091 */
3092     ifi  = 0;
3093     if (result[0] == 0x1b && result[1] == 0x00) {
3094         memmove(&ifi,result+2,2);
3095         strcpy(result,result+4);
3096     }
3097     return ifi;     /* this is the RMS internal file id */
3098 }
3099
3100 static void pipe_infromchild_ast(pPipe p);
3101
3102 /*
3103     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3104     inside an AST routine without worrying about reentrancy and which Perl
3105     memory allocator is being used.
3106
3107     We read data and queue up the buffers, then spit them out one at a
3108     time to the output mailbox when the output mailbox is ready for one.
3109
3110 */
3111 #define INITIAL_TOCHILDQUEUE  2
3112
3113 static pPipe
3114 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3115 {
3116     pPipe p;
3117     pCBuf b;
3118     char mbx1[64], mbx2[64];
3119     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3120                                       DSC$K_CLASS_S, mbx1},
3121                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3122                                       DSC$K_CLASS_S, mbx2};
3123     unsigned int dviitm = DVI$_DEVBUFSIZ;
3124     int j, n;
3125
3126     n = sizeof(Pipe);
3127     _ckvmssts(lib$get_vm(&n, &p));
3128
3129     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3130     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3131     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3132
3133     p->buf           = 0;
3134     p->shut_on_empty = FALSE;
3135     p->need_wake     = FALSE;
3136     p->type          = 0;
3137     p->retry         = 0;
3138     p->iosb.status   = SS$_NORMAL;
3139     p->iosb2.status  = SS$_NORMAL;
3140     p->free          = RQE_ZERO;
3141     p->wait          = RQE_ZERO;
3142     p->curr          = 0;
3143     p->curr2         = 0;
3144     p->info          = 0;
3145 #ifdef PERL_IMPLICIT_CONTEXT
3146     p->thx           = aTHX;
3147 #endif
3148
3149     n = sizeof(CBuf) + p->bufsize;
3150
3151     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3152         _ckvmssts(lib$get_vm(&n, &b));
3153         b->buf = (char *) b + sizeof(CBuf);
3154         _ckvmssts(lib$insqhi(b, &p->free));
3155     }
3156
3157     pipe_tochild2_ast(p);
3158     pipe_tochild1_ast(p);
3159     strcpy(wmbx, mbx1);
3160     strcpy(rmbx, mbx2);
3161     return p;
3162 }
3163
3164 /*  reads the MBX Perl is writing, and queues */
3165
3166 static void
3167 pipe_tochild1_ast(pPipe p)
3168 {
3169     pCBuf b = p->curr;
3170     int iss = p->iosb.status;
3171     int eof = (iss == SS$_ENDOFFILE);
3172     int sts;
3173 #ifdef PERL_IMPLICIT_CONTEXT
3174     pTHX = p->thx;
3175 #endif
3176
3177     if (p->retry) {
3178         if (eof) {
3179             p->shut_on_empty = TRUE;
3180             b->eof     = TRUE;
3181             _ckvmssts(sys$dassgn(p->chan_in));
3182         } else  {
3183             _ckvmssts(iss);
3184         }
3185
3186         b->eof  = eof;
3187         b->size = p->iosb.count;
3188         _ckvmssts(sts = lib$insqhi(b, &p->wait));
3189         if (p->need_wake) {
3190             p->need_wake = FALSE;
3191             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3192         }
3193     } else {
3194         p->retry = 1;   /* initial call */
3195     }
3196
3197     if (eof) {                  /* flush the free queue, return when done */
3198         int n = sizeof(CBuf) + p->bufsize;
3199         while (1) {
3200             iss = lib$remqti(&p->free, &b);
3201             if (iss == LIB$_QUEWASEMP) return;
3202             _ckvmssts(iss);
3203             _ckvmssts(lib$free_vm(&n, &b));
3204         }
3205     }
3206
3207     iss = lib$remqti(&p->free, &b);
3208     if (iss == LIB$_QUEWASEMP) {
3209         int n = sizeof(CBuf) + p->bufsize;
3210         _ckvmssts(lib$get_vm(&n, &b));
3211         b->buf = (char *) b + sizeof(CBuf);
3212     } else {
3213        _ckvmssts(iss);
3214     }
3215
3216     p->curr = b;
3217     iss = sys$qio(0,p->chan_in,
3218              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3219              &p->iosb,
3220              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3221     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3222     _ckvmssts(iss);
3223 }
3224
3225
3226 /* writes queued buffers to output, waits for each to complete before
3227    doing the next */
3228
3229 static void
3230 pipe_tochild2_ast(pPipe p)
3231 {
3232     pCBuf b = p->curr2;
3233     int iss = p->iosb2.status;
3234     int n = sizeof(CBuf) + p->bufsize;
3235     int done = (p->info && p->info->done) ||
3236               iss == SS$_CANCEL || iss == SS$_ABORT;
3237 #if defined(PERL_IMPLICIT_CONTEXT)
3238     pTHX = p->thx;
3239 #endif
3240
3241     do {
3242         if (p->type) {         /* type=1 has old buffer, dispose */
3243             if (p->shut_on_empty) {
3244                 _ckvmssts(lib$free_vm(&n, &b));
3245             } else {
3246                 _ckvmssts(lib$insqhi(b, &p->free));
3247             }
3248             p->type = 0;
3249         }
3250
3251         iss = lib$remqti(&p->wait, &b);
3252         if (iss == LIB$_QUEWASEMP) {
3253             if (p->shut_on_empty) {
3254                 if (done) {
3255                     _ckvmssts(sys$dassgn(p->chan_out));
3256                     *p->pipe_done = TRUE;
3257                     _ckvmssts(sys$setef(pipe_ef));
3258                 } else {
3259                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3260                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3261                 }
3262                 return;
3263             }
3264             p->need_wake = TRUE;
3265             return;
3266         }
3267         _ckvmssts(iss);
3268         p->type = 1;
3269     } while (done);
3270
3271
3272     p->curr2 = b;
3273     if (b->eof) {
3274         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3275             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3276     } else {
3277         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3278             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3279     }
3280
3281     return;
3282
3283 }
3284
3285
3286 static pPipe
3287 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3288 {
3289     pPipe p;
3290     char mbx1[64], mbx2[64];
3291     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3292                                       DSC$K_CLASS_S, mbx1},
3293                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3294                                       DSC$K_CLASS_S, mbx2};
3295     unsigned int dviitm = DVI$_DEVBUFSIZ;
3296
3297     int n = sizeof(Pipe);
3298     _ckvmssts(lib$get_vm(&n, &p));
3299     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3300     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3301
3302     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3303     n = p->bufsize * sizeof(char);
3304     _ckvmssts(lib$get_vm(&n, &p->buf));
3305     p->shut_on_empty = FALSE;
3306     p->info   = 0;
3307     p->type   = 0;
3308     p->iosb.status = SS$_NORMAL;
3309 #if defined(PERL_IMPLICIT_CONTEXT)
3310     p->thx = aTHX;
3311 #endif
3312     pipe_infromchild_ast(p);
3313
3314     strcpy(wmbx, mbx1);
3315     strcpy(rmbx, mbx2);
3316     return p;
3317 }
3318
3319 static void
3320 pipe_infromchild_ast(pPipe p)
3321 {
3322     int iss = p->iosb.status;
3323     int eof = (iss == SS$_ENDOFFILE);
3324     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3325     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3326 #if defined(PERL_IMPLICIT_CONTEXT)
3327     pTHX = p->thx;
3328 #endif
3329
3330     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3331         _ckvmssts(sys$dassgn(p->chan_out));
3332         p->chan_out = 0;
3333     }
3334
3335     /* read completed:
3336             input shutdown if EOF from self (done or shut_on_empty)
3337             output shutdown if closing flag set (my_pclose)
3338             send data/eof from child or eof from self
3339             otherwise, re-read (snarf of data from child)
3340     */
3341
3342     if (p->type == 1) {
3343         p->type = 0;
3344         if (myeof && p->chan_in) {                  /* input shutdown */
3345             _ckvmssts(sys$dassgn(p->chan_in));
3346             p->chan_in = 0;
3347         }
3348
3349         if (p->chan_out) {
3350             if (myeof || kideof) {      /* pass EOF to parent */
3351                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3352                               pipe_infromchild_ast, p,
3353                               0, 0, 0, 0, 0, 0));
3354                 return;
3355             } else if (eof) {       /* eat EOF --- fall through to read*/
3356
3357             } else {                /* transmit data */
3358                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3359                               pipe_infromchild_ast,p,
3360                               p->buf, p->iosb.count, 0, 0, 0, 0));
3361                 return;
3362             }
3363         }
3364     }
3365
3366     /*  everything shut? flag as done */
3367
3368     if (!p->chan_in && !p->chan_out) {
3369         *p->pipe_done = TRUE;
3370         _ckvmssts(sys$setef(pipe_ef));
3371         return;
3372     }
3373
3374     /* write completed (or read, if snarfing from child)
3375             if still have input active,
3376                queue read...immediate mode if shut_on_empty so we get EOF if empty
3377             otherwise,
3378                check if Perl reading, generate EOFs as needed
3379     */
3380
3381     if (p->type == 0) {
3382         p->type = 1;
3383         if (p->chan_in) {
3384             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3385                           pipe_infromchild_ast,p,
3386                           p->buf, p->bufsize, 0, 0, 0, 0);
3387             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3388             _ckvmssts(iss);
3389         } else {           /* send EOFs for extra reads */
3390             p->iosb.status = SS$_ENDOFFILE;
3391             p->iosb.dvispec = 0;
3392             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3393                       0, 0, 0,
3394                       pipe_infromchild_ast, p, 0, 0, 0, 0));
3395         }
3396     }
3397 }
3398
3399 static pPipe
3400 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3401 {
3402     pPipe p;
3403     char mbx[64];
3404     unsigned long dviitm = DVI$_DEVBUFSIZ;
3405     struct stat s;
3406     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3407                                       DSC$K_CLASS_S, mbx};
3408     int n = sizeof(Pipe);
3409
3410     /* things like terminals and mbx's don't need this filter */
3411     if (fd && fstat(fd,&s) == 0) {
3412         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3413         char device[65];
3414         unsigned short dev_len;
3415         struct dsc$descriptor_s d_dev;
3416         char * cptr;
3417         struct item_list_3 items[3];
3418         int status;
3419         unsigned short dvi_iosb[4];
3420
3421         cptr = getname(fd, out, 1);
3422         if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3423         d_dev.dsc$a_pointer = out;
3424         d_dev.dsc$w_length = strlen(out);
3425         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3426         d_dev.dsc$b_class = DSC$K_CLASS_S;
3427
3428         items[0].len = 4;
3429         items[0].code = DVI$_DEVCHAR;
3430         items[0].bufadr = &devchar;
3431         items[0].retadr = NULL;
3432         items[1].len = 64;
3433         items[1].code = DVI$_FULLDEVNAM;
3434         items[1].bufadr = device;
3435         items[1].retadr = &dev_len;
3436         items[2].len = 0;
3437         items[2].code = 0;
3438
3439         status = sys$getdviw
3440                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3441         _ckvmssts(status);
3442         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3443             device[dev_len] = 0;
3444
3445             if (!(devchar & DEV$M_DIR)) {
3446                 strcpy(out, device);
3447                 return 0;
3448             }
3449         }
3450     }
3451
3452     _ckvmssts(lib$get_vm(&n, &p));
3453     p->fd_out = dup(fd);
3454     create_mbx(aTHX_ &p->chan_in, &d_mbx);
3455     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3456     n = (p->bufsize+1) * sizeof(char);
3457     _ckvmssts(lib$get_vm(&n, &p->buf));
3458     p->shut_on_empty = FALSE;
3459     p->retry = 0;
3460     p->info  = 0;
3461     strcpy(out, mbx);
3462
3463     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3464                   pipe_mbxtofd_ast, p,
3465                   p->buf, p->bufsize, 0, 0, 0, 0));
3466
3467     return p;
3468 }
3469
3470 static void
3471 pipe_mbxtofd_ast(pPipe p)
3472 {
3473     int iss = p->iosb.status;
3474     int done = p->info->done;
3475     int iss2;
3476     int eof = (iss == SS$_ENDOFFILE);
3477     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3478     int err = !(iss&1) && !eof;
3479 #if defined(PERL_IMPLICIT_CONTEXT)
3480     pTHX = p->thx;
3481 #endif
3482
3483     if (done && myeof) {               /* end piping */
3484         close(p->fd_out);
3485         sys$dassgn(p->chan_in);
3486         *p->pipe_done = TRUE;
3487         _ckvmssts(sys$setef(pipe_ef));
3488         return;
3489     }
3490
3491     if (!err && !eof) {             /* good data to send to file */
3492         p->buf[p->iosb.count] = '\n';
3493         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3494         if (iss2 < 0) {
3495             p->retry++;
3496             if (p->retry < MAX_RETRY) {
3497                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3498                 return;
3499             }
3500         }
3501         p->retry = 0;
3502     } else if (err) {
3503         _ckvmssts(iss);
3504     }
3505
3506
3507     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3508           pipe_mbxtofd_ast, p,
3509           p->buf, p->bufsize, 0, 0, 0, 0);
3510     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3511     _ckvmssts(iss);
3512 }
3513
3514
3515 typedef struct _pipeloc     PLOC;
3516 typedef struct _pipeloc*   pPLOC;
3517
3518 struct _pipeloc {
3519     pPLOC   next;
3520     char    dir[NAM$C_MAXRSS+1];
3521 };
3522 static pPLOC  head_PLOC = 0;
3523
3524 void
3525 free_pipelocs(pTHX_ void *head)
3526 {
3527     pPLOC p, pnext;
3528     pPLOC *pHead = (pPLOC *)head;
3529
3530     p = *pHead;
3531     while (p) {
3532         pnext = p->next;
3533         PerlMem_free(p);
3534         p = pnext;
3535     }
3536     *pHead = 0;
3537 }
3538
3539 static void
3540 store_pipelocs(pTHX)
3541 {
3542     int    i;
3543     pPLOC  p;
3544     AV    *av = 0;
3545     SV    *dirsv;
3546     GV    *gv;
3547     char  *dir, *x;
3548     char  *unixdir;
3549     char  temp[NAM$C_MAXRSS+1];
3550     STRLEN n_a;
3551
3552     if (head_PLOC)
3553         free_pipelocs(aTHX_ &head_PLOC);
3554
3555 /*  the . directory from @INC comes last */
3556
3557     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3558     if (p == NULL) _ckvmssts(SS$_INSFMEM);
3559     p->next = head_PLOC;
3560     head_PLOC = p;
3561     strcpy(p->dir,"./");
3562
3563 /*  get the directory from $^X */
3564
3565     unixdir = PerlMem_malloc(VMS_MAXRSS);
3566     if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3567
3568 #ifdef PERL_IMPLICIT_CONTEXT
3569     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3570 #else
3571     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3572 #endif
3573         strcpy(temp, PL_origargv[0]);
3574         x = strrchr(temp,']');
3575         if (x == NULL) {
3576         x = strrchr(temp,'>');
3577           if (x == NULL) {
3578             /* It could be a UNIX path */
3579             x = strrchr(temp,'/');
3580           }
3581         }
3582         if (x)
3583           x[1] = '\0';
3584         else {
3585           /* Got a bare name, so use default directory */
3586           temp[0] = '.';
3587           temp[1] = '\0';
3588         }
3589
3590         if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
3591             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3592             if (p == NULL) _ckvmssts(SS$_INSFMEM);
3593             p->next = head_PLOC;
3594             head_PLOC = p;
3595             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3596             p->dir[NAM$C_MAXRSS] = '\0';
3597         }
3598     }
3599
3600 /*  reverse order of @INC entries, skip "." since entered above */
3601
3602 #ifdef PERL_IMPLICIT_CONTEXT
3603     if (aTHX)
3604 #endif
3605     if (PL_incgv) av = GvAVn(PL_incgv);
3606
3607     for (i = 0; av && i <= AvFILL(av); i++) {
3608         dirsv = *av_fetch(av,i,TRUE);
3609
3610         if (SvROK(dirsv)) continue;
3611         dir = SvPVx(dirsv,n_a);
3612         if (strcmp(dir,".") == 0) continue;
3613         if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
3614             continue;
3615
3616         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3617         p->next = head_PLOC;
3618         head_PLOC = p;
3619         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3620         p->dir[NAM$C_MAXRSS] = '\0';
3621     }
3622
3623 /* most likely spot (ARCHLIB) put first in the list */
3624
3625 #ifdef ARCHLIB_EXP
3626     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
3627         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3628         if (p == NULL) _ckvmssts(SS$_INSFMEM);
3629         p->next = head_PLOC;
3630         head_PLOC = p;
3631         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3632         p->dir[NAM$C_MAXRSS] = '\0';
3633     }
3634 #endif
3635     PerlMem_free(unixdir);
3636 }
3637
3638 static I32
3639 Perl_cando_by_name_int
3640    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3641 #if !defined(PERL_IMPLICIT_CONTEXT)
3642 #define cando_by_name_int               Perl_cando_by_name_int
3643 #else
3644 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3645 #endif
3646
3647 static char *
3648 find_vmspipe(pTHX)
3649 {
3650     static int   vmspipe_file_status = 0;
3651     static char  vmspipe_file[NAM$C_MAXRSS+1];
3652
3653     /* already found? Check and use ... need read+execute permission */
3654
3655     if (vmspipe_file_status == 1) {
3656         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3657          && cando_by_name_int
3658            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3659             return vmspipe_file;
3660         }
3661         vmspipe_file_status = 0;
3662     }
3663
3664     /* scan through stored @INC, $^X */
3665
3666     if (vmspipe_file_status == 0) {
3667         char file[NAM$C_MAXRSS+1];
3668         pPLOC  p = head_PLOC;
3669
3670         while (p) {
3671             char * exp_res;
3672             int dirlen;
3673             strcpy(file, p->dir);
3674             dirlen = strlen(file);
3675             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3676             file[NAM$C_MAXRSS] = '\0';
3677             p = p->next;
3678
3679             exp_res = do_rmsexpand
3680                 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3681             if (!exp_res) continue;
3682
3683             if (cando_by_name_int
3684                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3685              && cando_by_name_int
3686                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3687                 vmspipe_file_status = 1;
3688                 return vmspipe_file;
3689             }
3690         }
3691         vmspipe_file_status = -1;   /* failed, use tempfiles */
3692     }
3693
3694     return 0;
3695 }
3696
3697 static FILE *
3698 vmspipe_tempfile(pTHX)
3699 {
3700     char file[NAM$C_MAXRSS+1];
3701     FILE *fp;
3702     static int index = 0;
3703     Stat_t s0, s1;
3704     int cmp_result;
3705
3706     /* create a tempfile */
3707
3708     /* we can't go from   W, shr=get to  R, shr=get without
3709        an intermediate vulnerable state, so don't bother trying...
3710
3711        and lib$spawn doesn't shr=put, so have to close the write
3712
3713        So... match up the creation date/time and the FID to
3714        make sure we're dealing with the same file
3715
3716     */
3717
3718     index++;
3719     if (!decc_filename_unix_only) {
3720       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3721       fp = fopen(file,"w");
3722       if (!fp) {
3723         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3724         fp = fopen(file,"w");
3725         if (!fp) {
3726             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3727             fp = fopen(file,"w");
3728         }
3729       }
3730      }
3731      else {
3732       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3733       fp = fopen(file,"w");
3734       if (!fp) {
3735         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3736         fp = fopen(file,"w");
3737         if (!fp) {
3738           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3739           fp = fopen(file,"w");
3740         }
3741       }
3742     }
3743     if (!fp) return 0;  /* we're hosed */
3744
3745     fprintf(fp,"$! 'f$verify(0)'\n");
3746     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3747     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3748     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3749     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3750     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3751     fprintf(fp,"$ perl_del    = \"delete\"\n");
3752     fprintf(fp,"$ pif         = \"if\"\n");
3753     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3754     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3755     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3756     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3757     fprintf(fp,"$!  --- build command line to get max possible length\n");
3758     fprintf(fp,"$c=perl_popen_cmd0\n");
3759     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3760     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3761     fprintf(fp,"$x=perl_popen_cmd3\n");
3762     fprintf(fp,"$c=c+x\n");
3763     fprintf(fp,"$ perl_on\n");
3764     fprintf(fp,"$ 'c'\n");
3765     fprintf(fp,"$ perl_status = $STATUS\n");
3766     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3767     fprintf(fp,"$ perl_exit 'perl_status'\n");
3768     fsync(fileno(fp));
3769
3770     fgetname(fp, file, 1);
3771     fstat(fileno(fp), (struct stat *)&s0);
3772     fclose(fp);
3773
3774     if (decc_filename_unix_only)
3775         do_tounixspec(file, file, 0, NULL);
3776     fp = fopen(file,"r","shr=get");
3777     if (!fp) return 0;
3778     fstat(fileno(fp), (struct stat *)&s1);
3779
3780     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3781     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3782         fclose(fp);
3783         return 0;
3784     }
3785
3786     return fp;
3787 }
3788
3789
3790 static int vms_is_syscommand_xterm(void)
3791 {
3792     const static struct dsc$descriptor_s syscommand_dsc =
3793       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3794
3795     const static struct dsc$descriptor_s decwdisplay_dsc =
3796       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3797
3798     struct item_list_3 items[2];
3799     unsigned short dvi_iosb[4];
3800     unsigned long devchar;
3801     unsigned long devclass;
3802     int status;
3803
3804     /* Very simple check to guess if sys$command is a decterm? */
3805     /* First see if the DECW$DISPLAY: device exists */
3806     items[0].len = 4;
3807     items[0].code = DVI$_DEVCHAR;
3808     items[0].bufadr = &devchar;
3809     items[0].retadr = NULL;
3810     items[1].len = 0;
3811     items[1].code = 0;
3812
3813     status = sys$getdviw
3814         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3815
3816     if ($VMS_STATUS_SUCCESS(status)) {
3817         status = dvi_iosb[0];
3818     }
3819
3820     if (!$VMS_STATUS_SUCCESS(status)) {
3821         SETERRNO(EVMSERR, status);
3822         return -1;
3823     }
3824
3825     /* If it does, then for now assume that we are on a workstation */
3826     /* Now verify that SYS$COMMAND is a terminal */
3827     /* for creating the debugger DECTerm */
3828
3829     items[0].len = 4;
3830     items[0].code = DVI$_DEVCLASS;
3831     items[0].bufadr = &devclass;
3832     items[0].retadr = NULL;
3833     items[1].len = 0;
3834     items[1].code = 0;
3835
3836     status = sys$getdviw
3837         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3838
3839     if ($VMS_STATUS_SUCCESS(status)) {
3840         status = dvi_iosb[0];
3841     }
3842
3843     if (!$VMS_STATUS_SUCCESS(status)) {
3844         SETERRNO(EVMSERR, status);
3845         return -1;
3846     }
3847     else {
3848         if (devclass == DC$_TERM) {
3849             return 0;
3850         }
3851     }
3852     return -1;
3853 }
3854
3855 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3856 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3857 {
3858     int status;
3859     int ret_stat;
3860     char * ret_char;
3861     char device_name[65];
3862     unsigned short device_name_len;
3863     struct dsc$descriptor_s customization_dsc;
3864     struct dsc$descriptor_s device_name_dsc;
3865     const char * cptr;
3866     char * tptr;
3867     char customization[200];
3868     char title[40];
3869     pInfo info = NULL;
3870     char mbx1[64];
3871     unsigned short p_chan;
3872     int n;
3873     unsigned short iosb[4];
3874     struct item_list_3 items[2];
3875     const char * cust_str =
3876         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3877     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3878                                           DSC$K_CLASS_S, mbx1};
3879
3880      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3881     /*---------------------------------------*/
3882     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
3883
3884
3885     /* Make sure that this is from the Perl debugger */
3886     ret_char = strstr(cmd," xterm ");
3887     if (ret_char == NULL)
3888         return NULL;
3889     cptr = ret_char + 7;
3890     ret_char = strstr(cmd,"tty");
3891     if (ret_char == NULL)
3892         return NULL;
3893     ret_char = strstr(cmd,"sleep");
3894     if (ret_char == NULL)
3895         return NULL;
3896
3897     if (decw_term_port == 0) {
3898         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3899         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3900         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3901
3902        status = lib$find_image_symbol
3903                                (&filename1_dsc,
3904                                 &decw_term_port_dsc,
3905                                 (void *)&decw_term_port,
3906                                 NULL,
3907                                 0);
3908
3909         /* Try again with the other image name */
3910         if (!$VMS_STATUS_SUCCESS(status)) {
3911
3912            status = lib$find_image_symbol
3913                                (&filename2_dsc,
3914                                 &decw_term_port_dsc,
3915                                 (void *)&decw_term_port,
3916                                 NULL,
3917                                 0);
3918
3919         }
3920
3921     }
3922
3923
3924     /* No decw$term_port, give it up */
3925     if (!$VMS_STATUS_SUCCESS(status))
3926         return NULL;
3927
3928     /* Are we on a workstation? */
3929     /* to do: capture the rows / columns and pass their properties */
3930     ret_stat = vms_is_syscommand_xterm();
3931     if (ret_stat < 0)
3932         return NULL;
3933
3934     /* Make the title: */
3935     ret_char = strstr(cptr,"-title");
3936     if (ret_char != NULL) {
3937         while ((*cptr != 0) && (*cptr != '\"')) {
3938             cptr++;
3939         }
3940         if (*cptr == '\"')
3941             cptr++;
3942         n = 0;
3943         while ((*cptr != 0) && (*cptr != '\"')) {
3944             title[n] = *cptr;
3945             n++;
3946             if (n == 39) {
3947                 title[39] == 0;
3948                 break;
3949             }
3950             cptr++;
3951         }
3952         title[n] = 0;
3953     }
3954     else {
3955             /* Default title */
3956             strcpy(title,"Perl Debug DECTerm");
3957     }
3958     sprintf(customization, cust_str, title);
3959
3960     customization_dsc.dsc$a_pointer = customization;
3961     customization_dsc.dsc$w_length = strlen(customization);
3962     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3963     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3964
3965     device_name_dsc.dsc$a_pointer = device_name;
3966     device_name_dsc.dsc$w_length = sizeof device_name -1;
3967     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3968     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3969
3970     device_name_len = 0;
3971
3972     /* Try to create the window */
3973      status = (*decw_term_port)
3974        (NULL,
3975         NULL,
3976         &customization_dsc,
3977         &device_name_dsc,
3978         &device_name_len,
3979         NULL,
3980         NULL,
3981         NULL);
3982     if (!$VMS_STATUS_SUCCESS(status)) {
3983         SETERRNO(EVMSERR, status);
3984         return NULL;
3985     }
3986
3987     device_name[device_name_len] = '\0';
3988
3989     /* Need to set this up to look like a pipe for cleanup */
3990     n = sizeof(Info);
3991     status = lib$get_vm(&n, &info);
3992     if (!$VMS_STATUS_SUCCESS(status)) {
3993         SETERRNO(ENOMEM, status);
3994         return NULL;
3995     }
3996
3997     info->mode = *mode;
3998     info->done = FALSE;
3999     info->completion = 0;
4000     info->closing    = FALSE;
4001     info->in         = 0;
4002     info->out        = 0;
4003     info->err        = 0;
4004     info->fp         = Nullfp;
4005     info->useFILE    = 0;
4006     info->waiting    = 0;
4007     info->in_done    = TRUE;
4008     info->out_done   = TRUE;
4009     info->err_done   = TRUE;
4010
4011     /* Assign a channel on this so that it will persist, and not login */
4012     /* We stash this channel in the info structure for reference. */
4013     /* The created xterm self destructs when the last channel is removed */
4014     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4015     /* So leave this assigned. */
4016     device_name_dsc.dsc$w_length = device_name_len;
4017     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4018     if (!$VMS_STATUS_SUCCESS(status)) {
4019         SETERRNO(EVMSERR, status);
4020         return NULL;
4021     }
4022     info->xchan_valid = 1;
4023
4024     /* Now create a mailbox to be read by the application */
4025
4026     create_mbx(aTHX_ &p_chan, &d_mbx1);
4027
4028     /* write the name of the created terminal to the mailbox */
4029     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4030             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4031
4032     if (!$VMS_STATUS_SUCCESS(status)) {
4033         SETERRNO(EVMSERR, status);
4034         return NULL;
4035     }
4036
4037     info->fp  = PerlIO_open(mbx1, mode);
4038
4039     /* Done with this channel */
4040     sys$dassgn(p_chan);
4041
4042     /* If any errors, then clean up */
4043     if (!info->fp) {
4044         n = sizeof(Info);
4045         _ckvmssts(lib$free_vm(&n, &info));
4046         return NULL;
4047         }
4048
4049     /* All done */
4050     return info->fp;
4051 }
4052
4053 static PerlIO *
4054 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4055 {
4056     static int handler_set_up = FALSE;
4057     unsigned long int sts, flags = CLI$M_NOWAIT;
4058     /* The use of a GLOBAL table (as was done previously) rendered
4059      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4060      * environment.  Hence we've switched to LOCAL symbol table.
4061      */
4062     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4063     int j, wait = 0, n;
4064     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4065     char *in, *out, *err, mbx[512];
4066     FILE *tpipe = 0;
4067     char tfilebuf[NAM$C_MAXRSS+1];
4068     pInfo info = NULL;
4069     char cmd_sym_name[20];
4070     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4071                                       DSC$K_CLASS_S, symbol};
4072     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4073                                       DSC$K_CLASS_S, 0};
4074     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4075                                       DSC$K_CLASS_S, cmd_sym_name};
4076     struct dsc$descriptor_s *vmscmd;
4077     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4078     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4079     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4080
4081     /* Check here for Xterm create request.  This means looking for
4082      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4083      *  is possible to create an xterm.
4084      */
4085     if (*in_mode == 'r') {
4086         PerlIO * xterm_fd;
4087
4088         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4089         if (xterm_fd != Nullfp)
4090             return xterm_fd;
4091     }
4092
4093     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4094
4095     /* once-per-program initialization...
4096        note that the SETAST calls and the dual test of pipe_ef
4097        makes sure that only the FIRST thread through here does
4098        the initialization...all other threads wait until it's
4099        done.
4100
4101        Yeah, uglier than a pthread call, it's got all the stuff inline
4102        rather than in a separate routine.
4103     */
4104
4105     if (!pipe_ef) {
4106         _ckvmssts(sys$setast(0));
4107         if (!pipe_ef) {
4108             unsigned long int pidcode = JPI$_PID;
4109             $DESCRIPTOR(d_delay, RETRY_DELAY);
4110             _ckvmssts(lib$get_ef(&pipe_ef));
4111             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4112             _ckvmssts(sys$bintim(&d_delay, delaytime));
4113         }
4114         if (!handler_set_up) {
4115           _ckvmssts(sys$dclexh(&pipe_exitblock));
4116           handler_set_up = TRUE;
4117         }
4118         _ckvmssts(sys$setast(1));
4119     }
4120
4121     /* see if we can find a VMSPIPE.COM */
4122
4123     tfilebuf[0] = '@';
4124     vmspipe = find_vmspipe(aTHX);
4125     if (vmspipe) {
4126         strcpy(tfilebuf+1,vmspipe);
4127     } else {        /* uh, oh...we're in tempfile hell */
4128         tpipe = vmspipe_tempfile(aTHX);
4129         if (!tpipe) {       /* a fish popular in Boston */
4130             if (ckWARN(WARN_PIPE)) {
4131                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4132             }
4133         return Nullfp;
4134         }
4135         fgetname(tpipe,tfilebuf+1,1);
4136     }
4137     vmspipedsc.dsc$a_pointer = tfilebuf;
4138     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4139
4140     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4141     if (!(sts & 1)) {
4142       switch (sts) {
4143         case RMS$_FNF:  case RMS$_DNF:
4144           set_errno(ENOENT); break;
4145         case RMS$_DIR:
4146           set_errno(ENOTDIR); break;
4147         case RMS$_DEV:
4148           set_errno(ENODEV); break;
4149         case RMS$_PRV:
4150           set_errno(EACCES); break;
4151         case RMS$_SYN:
4152           set_errno(EINVAL); break;
4153         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4154           set_errno(E2BIG); break;
4155         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4156           _ckvmssts(sts); /* fall through */
4157         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4158           set_errno(EVMSERR);
4159       }
4160       set_vaxc_errno(sts);
4161       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4162         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4163       }
4164       *psts = sts;
4165       return Nullfp;
4166     }
4167     n = sizeof(Info);
4168     _ckvmssts(lib$get_vm(&n, &info));
4169
4170     strcpy(mode,in_mode);
4171     info->mode = *mode;
4172     info->done = FALSE;
4173     info->completion = 0;
4174     info->closing    = FALSE;
4175     info->in         = 0;
4176     info->out        = 0;
4177     info->err        = 0;
4178     info->fp         = Nullfp;
4179     info->useFILE    = 0;
4180     info->waiting    = 0;
4181     info->in_done    = TRUE;
4182     info->out_done   = TRUE;
4183     info->err_done   = TRUE;
4184     info->xchan      = 0;
4185     info->xchan_valid = 0;
4186
4187     in = PerlMem_malloc(VMS_MAXRSS);
4188     if (in == NULL) _ckvmssts(SS$_INSFMEM);
4189     out = PerlMem_malloc(VMS_MAXRSS);
4190     if (out == NULL) _ckvmssts(SS$_INSFMEM);
4191     err = PerlMem_malloc(VMS_MAXRSS);
4192     if (err == NULL) _ckvmssts(SS$_INSFMEM);
4193
4194     in[0] = out[0] = err[0] = '\0';
4195
4196     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4197         info->useFILE = 1;
4198         strcpy(p,p+1);
4199     }
4200     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4201         wait = 1;
4202         strcpy(p,p+1);
4203     }
4204
4205     if (*mode == 'r') {             /* piping from subroutine */
4206
4207         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4208         if (info->out) {
4209             info->out->pipe_done = &info->out_done;
4210             info->out_done = FALSE;
4211             info->out->info = info;
4212         }
4213         if (!info->useFILE) {
4214             info->fp  = PerlIO_open(mbx, mode);
4215         } else {
4216             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4217             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4218         }
4219
4220         if (!info->fp && info->out) {
4221             sys$cancel(info->out->chan_out);
4222
4223             while (!info->out_done) {
4224                 int done;
4225                 _ckvmssts(sys$setast(0));
4226                 done = info->out_done;
4227                 if (!done) _ckvmssts(sys$clref(pipe_ef));
4228                 _ckvmssts(sys$setast(1));
4229                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4230             }
4231
4232             if (info->out->buf) {
4233                 n = info->out->bufsize * sizeof(char);
4234                 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4235             }
4236             n = sizeof(Pipe);
4237             _ckvmssts(lib$free_vm(&n, &info->out));
4238             n = sizeof(Info);
4239             _ckvmssts(lib$free_vm(&n, &info));
4240             *psts = RMS$_FNF;
4241             return Nullfp;
4242         }
4243
4244         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4245         if (info->err) {
4246             info->err->pipe_done = &info->err_done;
4247             info->err_done = FALSE;
4248             info->err->info = info;
4249         }
4250
4251     } else if (*mode == 'w') {      /* piping to subroutine */
4252
4253         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4254         if (info->out) {
4255             info->out->pipe_done = &info->out_done;
4256             info->out_done = FALSE;
4257             info->out->info = info;
4258         }
4259
4260         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4261         if (info->err) {
4262             info->err->pipe_done = &info->err_done;
4263             info->err_done = FALSE;
4264             info->err->info = info;
4265         }
4266
4267         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4268         if (!info->useFILE) {
4269             info->fp  = PerlIO_open(mbx, mode);
4270         } else {
4271             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4272             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4273         }
4274
4275         if (info->in) {
4276             info->in->pipe_done = &info->in_done;
4277             info->in_done = FALSE;
4278             info->in->info = info;
4279         }
4280
4281         /* error cleanup */
4282         if (!info->fp && info->in) {
4283             info->done = TRUE;
4284             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4285                               0, 0, 0, 0, 0, 0, 0, 0));
4286
4287             while (!info->in_done) {
4288                 int done;
4289                 _ckvmssts(sys$setast(0));
4290                 done = info->in_done;
4291                 if (!done) _ckvmssts(sys$clref(pipe_ef));
4292                 _ckvmssts(sys$setast(1));
4293                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4294             }
4295
4296             if (info->in->buf) {
4297                 n = info->in->bufsize * sizeof(char);
4298                 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4299             }
4300             n = sizeof(Pipe);
4301             _ckvmssts(lib$free_vm(&n, &info->in));
4302             n = sizeof(Info);
4303             _ckvmssts(lib$free_vm(&n, &info));
4304             *psts = RMS$_FNF;
4305             return Nullfp;
4306         }
4307
4308
4309     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4310         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4311         if (info->out) {
4312             info->out->pipe_done = &info->out_done;
4313             info->out_done = FALSE;
4314             info->out->info = info;
4315         }
4316
4317         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4318         if (info->err) {
4319             info->err->pipe_done = &info->err_done;
4320             info->err_done = FALSE;
4321             info->err->info = info;
4322         }
4323     }
4324
4325     symbol[MAX_DCL_SYMBOL] = '\0';
4326
4327     strncpy(symbol, in, MAX_DCL_SYMBOL);
4328     d_symbol.dsc$w_length = strlen(symbol);
4329     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4330
4331     strncpy(symbol, err, MAX_DCL_SYMBOL);
4332     d_symbol.dsc$w_length = strlen(symbol);
4333     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4334
4335     strncpy(symbol, out, MAX_DCL_SYMBOL);
4336     d_symbol.dsc$w_length = strlen(symbol);
4337     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4338
4339     /* Done with the names for the pipes */
4340     PerlMem_free(err);
4341     PerlMem_free(out);
4342     PerlMem_free(in);
4343
4344     p = vmscmd->dsc$a_pointer;
4345     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4346     if (*p == '$') p++;                         /* remove leading $ */
4347     while (*p == ' ' || *p == '\t') p++;
4348
4349     for (j = 0; j < 4; j++) {
4350         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4351         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4352
4353     strncpy(symbol, p, MAX_DCL_SYMBOL);
4354     d_symbol.dsc$w_length = strlen(symbol);
4355     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4356
4357         if (strlen(p) > MAX_DCL_SYMBOL) {
4358             p += MAX_DCL_SYMBOL;
4359         } else {
4360             p += strlen(p);
4361         }
4362     }
4363     _ckvmssts(sys$setast(0));
4364     info->next=open_pipes;  /* prepend to list */
4365     open_pipes=info;
4366     _ckvmssts(sys$setast(1));
4367     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4368      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4369      * have SYS$COMMAND if we need it.
4370      */
4371     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4372                       0, &info->pid, &info->completion,
4373                       0, popen_completion_ast,info,0,0,0));
4374
4375     /* if we were using a tempfile, close it now */
4376
4377     if (tpipe) fclose(tpipe);
4378
4379     /* once the subprocess is spawned, it has copied the symbols and
4380        we can get rid of ours */
4381
4382     for (j = 0; j < 4; j++) {
4383         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4384         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4385     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4386     }
4387     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
4388     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4389     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4390     vms_execfree(vmscmd);
4391
4392 #ifdef PERL_IMPLICIT_CONTEXT
4393     if (aTHX)
4394 #endif
4395     PL_forkprocess = info->pid;
4396
4397     if (wait) {
4398          int done = 0;
4399          while (!done) {
4400              _ckvmssts(sys$setast(0));
4401              done = info->done;
4402              if (!done) _ckvmssts(sys$clref(pipe_ef));
4403              _ckvmssts(sys$setast(1));
4404              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4405          }
4406         *psts = info->completion;
4407 /* Caller thinks it is open and tries to close it. */
4408 /* This causes some problems, as it changes the error status */
4409 /*        my_pclose(info->fp); */
4410     } else {
4411         *psts = info->pid;
4412     }
4413     return info->fp;
4414 }  /* end of safe_popen */
4415
4416
4417 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4418 PerlIO *
4419 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4420 {
4421     int sts;
4422     TAINT_ENV();
4423     TAINT_PROPER("popen");
4424     PERL_FLUSHALL_FOR_CHILD;
4425     return safe_popen(aTHX_ cmd,mode,&sts);
4426 }
4427
4428 /*}}}*/
4429
4430 /*{{{  I32 my_pclose(PerlIO *fp)*/
4431 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4432 {
4433     pInfo info, last = NULL;
4434     unsigned long int retsts;
4435     int done, iss, n;
4436     int status;
4437
4438     for (info = open_pipes; info != NULL; last = info, info = info->next)
4439         if (info->fp == fp) break;
4440
4441     if (info == NULL) {  /* no such pipe open */
4442       set_errno(ECHILD); /* quoth POSIX */
4443       set_vaxc_errno(SS$_NONEXPR);
4444       return -1;
4445     }
4446
4447     /* If we were writing to a subprocess, insure that someone reading from
4448      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4449      * produce an EOF record in the mailbox.
4450      *
4451      *  well, at least sometimes it *does*, so we have to watch out for
4452      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4453      */
4454      if (info->fp) {
4455         if (!info->useFILE
4456 #if defined(USE_ITHREADS)
4457           && my_perl
4458 #endif
4459           && PL_perlio_fd_refcnt)
4460             PerlIO_flush(info->fp);
4461         else
4462             fflush((FILE *)info->fp);
4463     }
4464
4465     _ckvmssts(sys$setast(0));
4466      info->closing = TRUE;
4467      done = info->done && info->in_done && info->out_done && info->err_done;
4468      /* hanging on write to Perl's input? cancel it */
4469      if (info->mode == 'r' && info->out && !info->out_done) {
4470         if (info->out->chan_out) {
4471             _ckvmssts(sys$cancel(info->out->chan_out));
4472             if (!info->out->chan_in) {   /* EOF generation, need AST */
4473                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4474             }
4475         }
4476      }
4477      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4478          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4479                            0, 0, 0, 0, 0, 0));
4480     _ckvmssts(sys$setast(1));
4481     if (info->fp) {
4482      if (!info->useFILE
4483 #if defined(USE_ITHREADS)
4484          && my_perl
4485 #endif
4486          && PL_perlio_fd_refcnt)
4487         PerlIO_close(info->fp);
4488      else
4489         fclose((FILE *)info->fp);
4490     }
4491      /*
4492         we have to wait until subprocess completes, but ALSO wait until all
4493         the i/o completes...otherwise we'll be freeing the "info" structure
4494         that the i/o ASTs could still be using...
4495      */
4496
4497      while (!done) {
4498          _ckvmssts(sys$setast(0));
4499          done = info->done && info->in_done && info->out_done && info->err_done;
4500          if (!done) _ckvmssts(sys$clref(pipe_ef));
4501          _ckvmssts(sys$setast(1));
4502          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4503      }
4504      retsts = info->completion;
4505
4506     /* remove from list of open pipes */
4507     _ckvmssts(sys$setast(0));
4508     if (last) last->next = info->next;
4509     else open_pipes = info->next;
4510     _ckvmssts(sys$setast(1));
4511
4512     /* free buffers and structures */
4513
4514     if (info->in) {
4515         if (info->in->buf) {
4516             n = info->in->bufsize * sizeof(char);
4517             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4518         }
4519         n = sizeof(Pipe);
4520         _ckvmssts(lib$free_vm(&n, &info->in));
4521     }
4522     if (info->out) {
4523         if (info->out->buf) {
4524             n = info->out->bufsize * sizeof(char);
4525             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4526         }
4527         n = sizeof(Pipe);
4528         _ckvmssts(lib$free_vm(&n, &info->out));
4529     }
4530     if (info->err) {
4531         if (info->err->buf) {
4532             n = info->err->bufsize * sizeof(char);
4533             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4534         }
4535         n = sizeof(Pipe);
4536         _ckvmssts(lib$free_vm(&n, &info->err));
4537     }
4538     n = sizeof(Info);
4539     _ckvmssts(lib$free_vm(&n, &info));
4540
4541     return retsts;
4542
4543 }  /* end of my_pclose() */
4544
4545 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4546   /* Roll our own prototype because we want this regardless of whether
4547    * _VMS_WAIT is defined.
4548    */
4549   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4550 #endif
4551 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4552    created with popen(); otherwise partially emulate waitpid() unless
4553    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4554    Also check processes not considered by the CRTL waitpid().
4555  */
4556 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4557 Pid_t
4558 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4559 {
4560     pInfo info;
4561     int done;
4562     int sts;
4563     int j;
4564
4565     if (statusp) *statusp = 0;
4566
4567     for (info = open_pipes; info != NULL; info = info->next)
4568         if (info->pid == pid) break;
4569
4570     if (info != NULL) {  /* we know about this child */
4571       while (!info->done) {
4572           _ckvmssts(sys$setast(0));
4573           done = info->done;
4574           if (!done) _ckvmssts(sys$clref(pipe_ef));
4575           _ckvmssts(sys$setast(1));
4576           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4577       }
4578
4579       if (statusp) *statusp = info->completion;
4580       return pid;
4581     }
4582
4583     /* child that already terminated? */
4584
4585     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4586         if (closed_list[j].pid == pid) {
4587             if (statusp) *statusp = closed_list[j].completion;
4588             return pid;
4589         }
4590     }
4591
4592     /* fall through if this child is not one of our own pipe children */
4593
4594 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4595
4596       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4597        * in 7.2 did we get a version that fills in the VMS completion
4598        * status as Perl has always tried to do.
4599        */
4600
4601       sts = __vms_waitpid( pid, statusp, flags );
4602
4603       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4604          return sts;
4605
4606       /* If the real waitpid tells us the child does not exist, we
4607        * fall through here to implement waiting for a child that
4608        * was created by some means other than exec() (say, spawned
4609        * from DCL) or to wait for a process that is not a subprocess
4610        * of the current process.
4611        */
4612
4613 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4614
4615     {
4616       $DESCRIPTOR(intdsc,"0 00:00:01");
4617       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4618       unsigned long int pidcode = JPI$_PID, mypid;
4619       unsigned long int interval[2];
4620       unsigned int jpi_iosb[2];
4621       struct itmlst_3 jpilist[2] = {
4622           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4623           {                      0,         0,                 0, 0}
4624       };
4625
4626       if (pid <= 0) {
4627         /* Sorry folks, we don't presently implement rooting around for
4628            the first child we can find, and we definitely don't want to
4629            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4630          */
4631         set_errno(ENOTSUP);
4632         return -1;
4633       }
4634
4635       /* Get the owner of the child so I can warn if it's not mine. If the
4636        * process doesn't exist or I don't have the privs to look at it,
4637        * I can go home early.
4638        */
4639       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4640       if (sts & 1) sts = jpi_iosb[0];
4641       if (!(sts & 1)) {
4642         switch (sts) {
4643             case SS$_NONEXPR:
4644                 set_errno(ECHILD);
4645                 break;
4646             case SS$_NOPRIV:
4647                 set_errno(EACCES);
4648                 break;
4649             default:
4650                 _ckvmssts(sts);
4651         }
4652         set_vaxc_errno(sts);
4653         return -1;
4654       }
4655
4656       if (ckWARN(WARN_EXEC)) {
4657         /* remind folks they are asking for non-standard waitpid behavior */
4658         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4659         if (ownerpid != mypid)
4660           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4661                       "waitpid: process %x is not a child of process %x",
4662                       pid,mypid);
4663       }
4664
4665       /* simply check on it once a second until it's not there anymore. */
4666
4667       _ckvmssts(sys$bintim(&intdsc,interval));
4668       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4669             _ckvmssts(sys$schdwk(0,0,interval,0));
4670             _ckvmssts(sys$hiber());
4671       }
4672       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4673
4674       _ckvmssts(sts);
4675       return pid;
4676     }
4677 }  /* end of waitpid() */
4678 /*}}}*/
4679 /*}}}*/
4680 /*}}}*/
4681
4682 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4683 char *
4684 my_gconvert(double val, int ndig, int trail, char *buf)
4685 {
4686   static char __gcvtbuf[DBL_DIG+1];
4687   char *loc;
4688
4689   loc = buf ? buf : __gcvtbuf;
4690
4691 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4692   if (val < 1) {
4693     sprintf(loc,"%.*g",ndig,val);
4694     return loc;
4695   }
4696 #endif
4697
4698   if (val) {
4699     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4700     return gcvt(val,ndig,loc);
4701   }
4702   else {
4703     loc[0] = '0'; loc[1] = '\0';
4704     return loc;
4705   }
4706
4707 }
4708 /*}}}*/
4709
4710 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4711 static int rms_free_search_context(struct FAB * fab)
4712 {
4713 struct NAM * nam;
4714
4715     nam = fab->fab$l_nam;
4716     nam->nam$b_nop |= NAM$M_SYNCHK;
4717     nam->nam$l_rlf = NULL;
4718     fab->fab$b_dns = 0;
4719     return sys$parse(fab, NULL, NULL);
4720 }
4721
4722 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4723 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4724 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4725 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4726 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4727 #define rms_nam_esll(nam) nam.nam$b_esl
4728 #define rms_nam_esl(nam) nam.nam$b_esl
4729 #define rms_nam_name(nam) nam.nam$l_name
4730 #define rms_nam_namel(nam) nam.nam$l_name
4731 #define rms_nam_type(nam) nam.nam$l_type
4732 #define rms_nam_typel(nam) nam.nam$l_type
4733 #define rms_nam_ver(nam) nam.nam$l_ver
4734 #define rms_nam_verl(nam) nam.nam$l_ver
4735 #define rms_nam_rsll(nam) nam.nam$b_rsl
4736 #define rms_nam_rsl(nam) nam.nam$b_rsl
4737 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4738 #define rms_set_fna(fab, nam, name, size) \
4739         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4740 #define rms_get_fna(fab, nam) fab.fab$l_fna
4741 #define rms_set_dna(fab, nam, name, size) \
4742         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4743 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4744 #define rms_set_esa(fab, nam, name, size) \
4745         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4746 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4747         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4748 #define rms_set_rsa(nam, name, size) \
4749         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4750 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4751         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4752 #define rms_nam_name_type_l_size(nam) \
4753         (nam.nam$b_name + nam.nam$b_type)
4754 #else
4755 static int rms_free_search_context(struct FAB * fab)
4756 {
4757 struct NAML * nam;
4758
4759     nam = fab->fab$l_naml;
4760     nam->naml$b_nop |= NAM$M_SYNCHK;
4761     nam->naml$l_rlf = NULL;
4762     nam->naml$l_long_defname_size = 0;
4763
4764     fab->fab$b_dns = 0;
4765     return sys$parse(fab, NULL, NULL);
4766 }
4767
4768 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4769 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4770 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4771 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4772 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4773 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4774 #define rms_nam_esl(nam) nam.naml$b_esl
4775 #define rms_nam_name(nam) nam.naml$l_name
4776 #define rms_nam_namel(nam) nam.naml$l_long_name
4777 #define rms_nam_type(nam) nam.naml$l_type
4778 #define rms_nam_typel(nam) nam.naml$l_long_type
4779 #define rms_nam_ver(nam) nam.naml$l_ver
4780 #define rms_nam_verl(nam) nam.naml$l_long_ver
4781 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4782 #define rms_nam_rsl(nam) nam.naml$b_rsl
4783 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4784 #define rms_set_fna(fab, nam, name, size) \
4785         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4786         nam.naml$l_long_filename_size = size; \
4787         nam.naml$l_long_filename = name;}
4788 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4789 #define rms_set_dna(fab, nam, name, size) \
4790         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4791         nam.naml$l_long_defname_size = size; \
4792         nam.naml$l_long_defname = name; }
4793 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4794 #define rms_set_esa(fab, nam, name, size) \
4795         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4796         nam.naml$l_long_expand_alloc = size; \
4797         nam.naml$l_long_expand = name; }
4798 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4799         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4800         nam.naml$l_long_expand = l_name; \
4801         nam.naml$l_long_expand_alloc = l_size; }
4802 #define rms_set_rsa(nam, name, size) \
4803         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4804         nam.naml$l_long_result = name; \
4805         nam.naml$l_long_result_alloc = size; }
4806 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4807         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4808         nam.naml$l_long_result = l_name; \
4809         nam.naml$l_long_result_alloc = l_size; }
4810 #define rms_nam_name_type_l_size(nam) \
4811         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4812 #endif
4813
4814
4815 /* rms_erase
4816  * The CRTL for 8.3 and later can create symbolic links in any mode,
4817  * however in 8.3 the unlink/remove/delete routines will only properly handle
4818  * them if one of the PCP modes is active.
4819  */
4820 static int rms_erase(const char * vmsname)
4821 {
4822   int status;
4823   struct FAB myfab = cc$rms_fab;
4824   rms_setup_nam(mynam);
4825
4826   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4827   rms_bind_fab_nam(myfab, mynam);
4828
4829   /* Are we removing all versions? */
4830   if (vms_unlink_all_versions == 1) {
4831     const char * defspec = ";*";
4832     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4833   }
4834
4835 #ifdef NAML$M_OPEN_SPECIAL
4836   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4837 #endif
4838
4839   status = sys$erase(&myfab, 0, 0);
4840
4841   return status;
4842 }
4843
4844
4845 static int
4846 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4847                     const struct dsc$descriptor_s * vms_dst_dsc,
4848                     unsigned long flags)
4849 {
4850     /*  VMS and UNIX handle file permissions differently and the
4851      * the same ACL trick may be needed for renaming files,
4852      * especially if they are directories.
4853      */
4854
4855    /* todo: get kill_file and rename to share common code */
4856    /* I can not find online documentation for $change_acl
4857     * it appears to be replaced by $set_security some time ago */
4858
4859 const unsigned int access_mode = 0;
4860 $DESCRIPTOR(obj_file_dsc,"FILE");
4861 char *vmsname;
4862 char *rslt;
4863 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
4864 int aclsts, fndsts, rnsts = -1;
4865 unsigned int ctx = 0;
4866 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4867 struct dsc$descriptor_s * clean_dsc;
4868
4869 struct myacedef {
4870     unsigned char myace$b_length;
4871     unsigned char myace$b_type;
4872     unsigned short int myace$w_flags;
4873     unsigned long int myace$l_access;
4874     unsigned long int myace$l_ident;
4875 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
4876              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
4877              0},
4878              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
4879
4880 struct item_list_3
4881         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
4882                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
4883                       {0,0,0,0}},
4884         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
4885         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
4886                      {0,0,0,0}};
4887
4888
4889     /* Expand the input spec using RMS, since we do not want to put
4890      * ACLs on the target of a symbolic link */
4891     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
4892     if (vmsname == NULL)
4893         return SS$_INSFMEM;
4894
4895     rslt = do_rmsexpand(vms_src_dsc->dsc$a_pointer,
4896                         vmsname,
4897                         0,
4898                         NULL,
4899                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
4900                         NULL,
4901                         NULL);
4902     if (rslt == NULL) {
4903         PerlMem_free(vmsname);
4904         return SS$_INSFMEM;
4905     }
4906
4907     /* So we get our own UIC to use as a rights identifier,
4908      * and the insert an ACE at the head of the ACL which allows us
4909      * to delete the file.
4910      */
4911     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
4912
4913     fildsc.dsc$w_length = strlen(vmsname);
4914     fildsc.dsc$a_pointer = vmsname;
4915     ctx = 0;
4916     newace.myace$l_ident = oldace.myace$l_ident;
4917     rnsts = SS$_ABORT;
4918
4919     /* Grab any existing ACEs with this identifier in case we fail */
4920     clean_dsc = &fildsc;
4921     aclsts = fndsts = sys$get_security(&obj_file_dsc,
4922                                &fildsc,
4923                                NULL,
4924                                OSS$M_WLOCK,
4925                                findlst,
4926                                &ctx,
4927                                &access_mode);
4928
4929     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
4930         /* Add the new ACE . . . */
4931
4932         /* if the sys$get_security succeeded, then ctx is valid, and the
4933          * object/file descriptors will be ignored.  But otherwise they
4934          * are needed
4935          */
4936         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
4937                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
4938         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4939             set_errno(EVMSERR);
4940             set_vaxc_errno(aclsts);
4941             PerlMem_free(vmsname);
4942             return aclsts;
4943         }
4944
4945         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
4946                                 NULL, NULL,
4947                                 &flags,
4948                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
4949
4950         if ($VMS_STATUS_SUCCESS(rnsts)) {
4951             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
4952         }
4953
4954         /* Put things back the way they were. */
4955         ctx = 0;
4956         aclsts = sys$get_security(&obj_file_dsc,
4957                                   clean_dsc,
4958                                   NULL,
4959                                   OSS$M_WLOCK,
4960                                   findlst,
4961                                   &ctx,
4962                                   &access_mode);
4963
4964         if ($VMS_STATUS_SUCCESS(aclsts)) {
4965         int sec_flags;
4966
4967             sec_flags = 0;
4968             if (!$VMS_STATUS_SUCCESS(fndsts))
4969                 sec_flags = OSS$M_RELCTX;
4970
4971             /* Get rid of the new ACE */
4972             aclsts = sys$set_security(NULL, NULL, NULL,
4973                                   sec_flags, dellst, &ctx, &access_mode);
4974
4975             /* If there was an old ACE, put it back */
4976             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
4977                 addlst[0].bufadr = &oldace;
4978                 aclsts = sys$set_security(NULL, NULL, NULL,
4979                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
4980                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4981                     set_errno(EVMSERR);
4982                     set_vaxc_errno(aclsts);
4983                     rnsts = aclsts;
4984                 }
4985             } else {
4986             int aclsts2;
4987
4988                 /* Try to clear the lock on the ACL list */
4989                 aclsts2 = sys$set_security(NULL, NULL, NULL,
4990                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
4991
4992                 /* Rename errors are most important */
4993                 if (!$VMS_STATUS_SUCCESS(rnsts))
4994                     aclsts = rnsts;
4995                 set_errno(EVMSERR);
4996                 set_vaxc_errno(aclsts);
4997                 rnsts = aclsts;
4998             }
4999         }
5000         else {
5001             if (aclsts != SS$_ACLEMPTY)
5002                 rnsts = aclsts;
5003         }
5004     }
5005     else
5006         rnsts = fndsts;
5007
5008     PerlMem_free(vmsname);
5009     return rnsts;
5010 }
5011
5012
5013 /*{{{int rename(const char *, const char * */
5014 /* Not exactly what X/Open says to do, but doing it absolutely right
5015  * and efficiently would require a lot more work.  This should be close
5016  * enough to pass all but the most strict X/Open compliance test.
5017  */
5018 int
5019 Perl_rename(pTHX_ const char *src, const char * dst)
5020 {
5021 int retval;
5022 int pre_delete = 0;
5023 int src_sts;
5024 int dst_sts;
5025 Stat_t src_st;
5026 Stat_t dst_st;
5027
5028     /* Validate the source file */
5029     src_sts = flex_lstat(src, &src_st);
5030     if (src_sts != 0) {
5031
5032         /* No source file or other problem */
5033         return src_sts;
5034     }
5035
5036     dst_sts = flex_lstat(dst, &dst_st);
5037     if (dst_sts == 0) {
5038
5039         if (dst_st.st_dev != src_st.st_dev) {
5040             /* Must be on the same device */
5041             errno = EXDEV;
5042             return -1;
5043         }
5044
5045         /* VMS_INO_T_COMPARE is true if the inodes are different
5046          * to match the output of memcmp
5047          */
5048
5049         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5050             /* That was easy, the files are the same! */
5051             return 0;
5052         }
5053
5054         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5055             /* If source is a directory, so must be dest */
5056                 errno = EISDIR;
5057                 return -1;
5058         }
5059
5060     }
5061
5062
5063     if ((dst_sts == 0) &&
5064         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5065
5066         /* We have issues here if vms_unlink_all_versions is set
5067          * If the destination exists, and is not a directory, then
5068          * we must delete in advance.
5069          *
5070          * If the src is a directory, then we must always pre-delete
5071          * the destination.
5072          *
5073          * If we successfully delete the dst in advance, and the rename fails
5074          * X/Open requires that errno be EIO.
5075          *
5076          */
5077
5078         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5079             int d_sts;
5080             d_sts = mp_do_kill_file(aTHX_ dst, S_ISDIR(dst_st.st_mode));
5081             if (d_sts != 0)
5082                 return d_sts;
5083
5084             /* We killed the destination, so only errno now is EIO */
5085             pre_delete = 1;
5086         }
5087     }
5088
5089     /* Originally the idea was to call the CRTL rename() and only
5090      * try the lib$rename_file if it failed.
5091      * It turns out that there are too many variants in what the
5092      * the CRTL rename might do, so only use lib$rename_file
5093      */
5094     retval = -1;
5095
5096     {
5097         /* Is the source and dest both in VMS format */
5098         /* if the source is a directory, then need to fileify */
5099         /*  and dest must be a directory or non-existant. */
5100
5101         char * vms_src;
5102         char * vms_dst;
5103         int sts;
5104         char * ret_str;
5105         unsigned long flags;
5106         struct dsc$descriptor_s old_file_dsc;
5107         struct dsc$descriptor_s new_file_dsc;
5108
5109         /* We need to modify the src and dst depending
5110          * on if one or more of them are directories.
5111          */
5112
5113         vms_src = PerlMem_malloc(VMS_MAXRSS);
5114         if (vms_src == NULL)
5115             _ckvmssts(SS$_INSFMEM);
5116
5117         /* Source is always a VMS format file */
5118         ret_str = do_tovmsspec(src, vms_src, 0, NULL);
5119         if (ret_str == NULL) {
5120             PerlMem_free(vms_src);
5121             errno = EIO;
5122             return -1;
5123         }
5124
5125         vms_dst = PerlMem_malloc(VMS_MAXRSS);
5126         if (vms_dst == NULL)
5127             _ckvmssts(SS$_INSFMEM);
5128
5129         if (S_ISDIR(src_st.st_mode)) {
5130         char * ret_str;
5131         char * vms_dir_file;
5132
5133             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5134             if (vms_dir_file == NULL)
5135                 _ckvmssts(SS$_INSFMEM);
5136
5137             /* The source must be a file specification */
5138             ret_str = do_fileify_dirspec(vms_src, vms_dir_file, 0, NULL);
5139             if (ret_str == NULL) {
5140                 PerlMem_free(vms_src);
5141                 PerlMem_free(vms_dst);
5142                 PerlMem_free(vms_dir_file);
5143                 errno = EIO;
5144                 return -1;
5145             }
5146             PerlMem_free(vms_src);
5147             vms_src = vms_dir_file;
5148
5149             /* If the dest is a directory, we must remove it
5150             if (dst_sts == 0) {
5151                 int d_sts;
5152                 d_sts = mp_do_kill_file(aTHX_ dst, 1);
5153                 if (d_sts != 0) {
5154                     PerlMem_free(vms_src);
5155                     PerlMem_free(vms_dst);
5156                     errno = EIO;
5157                     return sts;
5158                 }
5159
5160                 pre_delete = 1;
5161             }
5162
5163            /* The dest must be a VMS file specification */
5164            ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
5165            if (ret_str == NULL) {
5166                 PerlMem_free(vms_src);
5167                 PerlMem_free(vms_dst);
5168                 errno = EIO;
5169                 return -1;
5170            }
5171
5172             /* The source must be a file specification */
5173             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5174             if (vms_dir_file == NULL)
5175                 _ckvmssts(SS$_INSFMEM);
5176
5177             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5178             if (ret_str == NULL) {
5179                 PerlMem_free(vms_src);
5180                 PerlMem_free(vms_dst);
5181                 PerlMem_free(vms_dir_file);
5182                 errno = EIO;
5183                 return -1;
5184             }
5185             PerlMem_free(vms_dst);
5186             vms_dst = vms_dir_file;
5187
5188         } else {
5189             /* File to file or file to new dir */
5190
5191             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5192                 /* VMS pathify a dir target */
5193                 ret_str = do_tovmspath(dst, vms_dst, 0, NULL);
5194                 if (ret_str == NULL) {
5195                     PerlMem_free(vms_src);
5196                     PerlMem_free(vms_dst);
5197                     errno = EIO;
5198                     return -1;
5199                 }
5200             } else {
5201
5202                 /* fileify a target VMS file specification */
5203                 ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
5204                 if (ret_str == NULL) {
5205                     PerlMem_free(vms_src);
5206                     PerlMem_free(vms_dst);
5207                     errno = EIO;
5208                     return -1;
5209                 }
5210             }
5211         }
5212
5213         old_file_dsc.dsc$a_pointer = vms_src;
5214         old_file_dsc.dsc$w_length = strlen(vms_src);
5215         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5216         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5217
5218         new_file_dsc.dsc$a_pointer = vms_dst;
5219         new_file_dsc.dsc$w_length = strlen(vms_dst);
5220         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5221         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5222
5223         flags = 0;
5224 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5225         flags |= 2; /* LIB$M_FIL_LONG_NAMES */
5226 #endif
5227
5228         sts = lib$rename_file(&old_file_dsc,
5229                               &new_file_dsc,
5230                               NULL, NULL,
5231                               &flags,
5232                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5233         if (!$VMS_STATUS_SUCCESS(sts)) {
5234
5235            /* We could have failed because VMS style permissions do not
5236             * permit renames that UNIX will allow.  Just like the hack
5237             * in for kill_file.
5238             */
5239            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5240         }
5241
5242         PerlMem_free(vms_src);
5243         PerlMem_free(vms_dst);
5244         if (!$VMS_STATUS_SUCCESS(sts)) {
5245             errno = EIO;
5246             return -1;
5247         }
5248         retval = 0;
5249     }
5250
5251     if (vms_unlink_all_versions) {
5252         /* Now get rid of any previous versions of the source file that
5253          * might still exist
5254          */
5255         int save_errno;
5256         save_errno = errno;
5257         src_sts = mp_do_kill_file(aTHX_ src, S_ISDIR(src_st.st_mode));
5258         errno = save_errno;
5259     }
5260
5261     /* We deleted the destination, so must force the error to be EIO */
5262     if ((retval != 0) && (pre_delete != 0))
5263         errno = EIO;
5264
5265     return retval;
5266 }
5267 /*}}}*/
5268
5269
5270 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5271 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5272  * to expand file specification.  Allows for a single default file
5273  * specification and a simple mask of options.  If outbuf is non-NULL,
5274  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5275  * the resultant file specification is placed.  If outbuf is NULL, the
5276  * resultant file specification is placed into a static buffer.
5277  * The third argument, if non-NULL, is taken to be a default file
5278  * specification string.  The fourth argument is unused at present.
5279  * rmesexpand() returns the address of the resultant string if
5280  * successful, and NULL on error.
5281  *
5282  * New functionality for previously unused opts value:
5283  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5284  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5285  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5286  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5287  */
5288 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5289
5290 static char *
5291 mp_do_rmsexpand
5292    (pTHX_ const char *filespec,
5293     char *outbuf,
5294     int ts,
5295     const char *defspec,
5296     unsigned opts,
5297     int * fs_utf8,
5298     int * dfs_utf8)
5299 {
5300   static char __rmsexpand_retbuf[VMS_MAXRSS];
5301   char * vmsfspec, *tmpfspec;
5302   char * esa, *cp, *out = NULL;
5303   char * tbuf;
5304   char * esal = NULL;
5305   char * outbufl;
5306   struct FAB myfab = cc$rms_fab;
5307   rms_setup_nam(mynam);
5308   STRLEN speclen;
5309   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5310   int sts;
5311
5312   /* temp hack until UTF8 is actually implemented */
5313   if (fs_utf8 != NULL)
5314     *fs_utf8 = 0;
5315
5316   if (!filespec || !*filespec) {
5317     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5318     return NULL;
5319   }
5320   if (!outbuf) {
5321     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
5322     else    outbuf = __rmsexpand_retbuf;
5323   }
5324
5325   vmsfspec = NULL;
5326   tmpfspec = NULL;
5327   outbufl = NULL;
5328
5329   isunix = 0;
5330   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5331     isunix = is_unix_filespec(filespec);
5332     if (isunix) {
5333       vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5334       if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
5335       if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
5336         PerlMem_free(vmsfspec);
5337         if (out)
5338            Safefree(out);
5339         return NULL;
5340       }
5341       filespec = vmsfspec;
5342
5343       /* Unless we are forcing to VMS format, a UNIX input means
5344        * UNIX output, and that requires long names to be used
5345        */
5346       if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5347         opts |= PERL_RMSEXPAND_M_LONG;
5348       else {
5349         isunix = 0;
5350       }
5351     }
5352   }
5353
5354   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
5355   rms_bind_fab_nam(myfab, mynam);
5356
5357   if (defspec && *defspec) {
5358     int t_isunix;
5359     t_isunix = is_unix_filespec(defspec);
5360     if (t_isunix) {
5361       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5362       if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5363       if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
5364         PerlMem_free(tmpfspec);
5365         if (vmsfspec != NULL)
5366             PerlMem_free(vmsfspec);
5367         if (out)
5368            Safefree(out);
5369         return NULL;
5370       }
5371       defspec = tmpfspec;
5372     }
5373     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
5374   }
5375
5376   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5377   if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5378 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5379   esal = PerlMem_malloc(VMS_MAXRSS);
5380   if (esal == NULL) _ckvmssts(SS$_INSFMEM);
5381 #endif
5382   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5383
5384   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5385     rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
5386   }
5387   else {
5388 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5389     outbufl = PerlMem_malloc(VMS_MAXRSS);
5390     if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
5391     rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5392 #else
5393     rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
5394 #endif
5395   }
5396
5397 #ifdef NAM$M_NO_SHORT_UPCASE
5398   if (decc_efs_case_preserve)
5399     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5400 #endif
5401
5402    /* We may not want to follow symbolic links */
5403 #ifdef NAML$M_OPEN_SPECIAL
5404   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5405     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5406 #endif
5407
5408   /* First attempt to parse as an existing file */
5409   retsts = sys$parse(&myfab,0,0);
5410   if (!(retsts & STS$K_SUCCESS)) {
5411
5412     /* Could not find the file, try as syntax only if error is not fatal */
5413     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5414     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
5415       retsts = sys$parse(&myfab,0,0);
5416       if (retsts & STS$K_SUCCESS) goto expanded;
5417     }
5418
5419      /* Still could not parse the file specification */
5420     /*----------------------------------------------*/
5421     sts = rms_free_search_context(&myfab); /* Free search context */
5422     if (out) Safefree(out);
5423     if (tmpfspec != NULL)
5424         PerlMem_free(tmpfspec);
5425     if (vmsfspec != NULL)
5426         PerlMem_free(vmsfspec);
5427     if (outbufl != NULL)
5428         PerlMem_free(outbufl);
5429     PerlMem_free(esa);
5430     if (esal != NULL)
5431         PerlMem_free(esal);
5432     set_vaxc_errno(retsts);
5433     if      (retsts == RMS$_PRV) set_errno(EACCES);
5434     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5435     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5436     else                         set_errno(EVMSERR);
5437     return NULL;
5438   }
5439   retsts = sys$search(&myfab,0,0);
5440   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5441     sts = rms_free_search_context(&myfab); /* Free search context */
5442     if (out) Safefree(out);
5443     if (tmpfspec != NULL)
5444         PerlMem_free(tmpfspec);
5445     if (vmsfspec != NULL)
5446         PerlMem_free(vmsfspec);
5447     if (outbufl != NULL)
5448         PerlMem_free(outbufl);
5449     PerlMem_free(esa);
5450     if (esal != NULL)
5451         PerlMem_free(esal);
5452     set_vaxc_errno(retsts);
5453     if      (retsts == RMS$_PRV) set_errno(EACCES);
5454     else                         set_errno(EVMSERR);
5455     return NULL;
5456   }
5457
5458   /* If the input filespec contained any lowercase characters,
5459    * downcase the result for compatibility with Unix-minded code. */
5460   expanded:
5461   if (!decc_efs_case_preserve) {
5462     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5463       if (islower(*tbuf)) { haslower = 1; break; }
5464   }
5465
5466    /* Is a long or a short name expected */
5467   /*------------------------------------*/
5468   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5469     if (rms_nam_rsll(mynam)) {
5470         tbuf = outbuf;
5471         speclen = rms_nam_rsll(mynam);
5472     }
5473     else {
5474         tbuf = esal; /* Not esa */
5475         speclen = rms_nam_esll(mynam);
5476     }
5477   }
5478   else {
5479     if (rms_nam_rsl(mynam)) {
5480         tbuf = outbuf;
5481         speclen = rms_nam_rsl(mynam);
5482     }
5483     else {
5484         tbuf = esa; /* Not esal */
5485         speclen = rms_nam_esl(mynam);
5486     }
5487   }
5488   tbuf[speclen] = '\0';
5489
5490   /* Trim off null fields added by $PARSE
5491    * If type > 1 char, must have been specified in original or default spec
5492    * (not true for version; $SEARCH may have added version of existing file).
5493    */
5494   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5495   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5496     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5497              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5498   }
5499   else {
5500     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5501              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5502   }
5503   if (trimver || trimtype) {
5504     if (defspec && *defspec) {
5505       char *defesal = NULL;
5506       defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5507       if (defesal != NULL) {
5508         struct FAB deffab = cc$rms_fab;
5509         rms_setup_nam(defnam);
5510
5511         rms_bind_fab_nam(deffab, defnam);
5512
5513         /* Cast ok */
5514         rms_set_fna
5515             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5516
5517         rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
5518
5519         rms_clear_nam_nop(defnam);
5520         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5521 #ifdef NAM$M_NO_SHORT_UPCASE
5522         if (decc_efs_case_preserve)
5523           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5524 #endif
5525 #ifdef NAML$M_OPEN_SPECIAL
5526         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5527           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5528 #endif
5529         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5530           if (trimver) {
5531              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5532           }
5533           if (trimtype) {
5534             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5535           }
5536         }
5537         PerlMem_free(defesal);
5538       }
5539     }
5540     if (trimver) {
5541       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5542         if (*(rms_nam_verl(mynam)) != '\"')
5543           speclen = rms_nam_verl(mynam) - tbuf;
5544       }
5545       else {
5546         if (*(rms_nam_ver(mynam)) != '\"')
5547           speclen = rms_nam_ver(mynam) - tbuf;
5548       }
5549     }
5550     if (trimtype) {
5551       /* If we didn't already trim version, copy down */
5552       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5553         if (speclen > rms_nam_verl(mynam) - tbuf)
5554           memmove
5555            (rms_nam_typel(mynam),
5556             rms_nam_verl(mynam),
5557             speclen - (rms_nam_verl(mynam) - tbuf));
5558           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5559       }
5560       else {
5561         if (speclen > rms_nam_ver(mynam) - tbuf)
5562           memmove
5563            (rms_nam_type(mynam),
5564             rms_nam_ver(mynam),
5565             speclen - (rms_nam_ver(mynam) - tbuf));
5566           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5567       }
5568     }
5569   }
5570
5571    /* Done with these copies of the input files */
5572   /*-------------------------------------------*/
5573   if (vmsfspec != NULL)
5574         PerlMem_free(vmsfspec);
5575   if (tmpfspec != NULL)
5576         PerlMem_free(tmpfspec);
5577
5578   /* If we just had a directory spec on input, $PARSE "helpfully"
5579    * adds an empty name and type for us */
5580   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5581     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5582         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5583         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5584       speclen = rms_nam_namel(mynam) - tbuf;
5585   }
5586   else {
5587     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5588         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5589         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5590       speclen = rms_nam_name(mynam) - tbuf;
5591   }
5592
5593   /* Posix format specifications must have matching quotes */
5594   if (speclen < (VMS_MAXRSS - 1)) {
5595     if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
5596       if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
5597         tbuf[speclen] = '\"';
5598         speclen++;
5599       }
5600     }
5601   }
5602   tbuf[speclen] = '\0';
5603   if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
5604
5605   /* Have we been working with an expanded, but not resultant, spec? */
5606   /* Also, convert back to Unix syntax if necessary. */
5607
5608   if (!rms_nam_rsll(mynam)) {
5609     if (isunix) {
5610       if (do_tounixspec(tbuf, outbuf ,0 , fs_utf8) == NULL) {
5611         if (out) Safefree(out);
5612         if (esal != NULL)
5613             PerlMem_free(esal);
5614         PerlMem_free(esa);
5615         if (outbufl != NULL)
5616             PerlMem_free(outbufl);
5617         return NULL;
5618       }
5619     }
5620     else strcpy(outbuf, tbuf);
5621   }
5622   else if (isunix) {
5623     tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5624     if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5625     if (do_tounixspec(outbuf,tmpfspec,0,fs_utf8) == NULL) {
5626         if (out) Safefree(out);
5627         PerlMem_free(esa);
5628         if (esal != NULL)
5629             PerlMem_free(esal);
5630         PerlMem_free(tmpfspec);
5631         if (outbufl != NULL)
5632             PerlMem_free(outbufl);
5633         return NULL;
5634     }
5635     strcpy(outbuf,tmpfspec);
5636     PerlMem_free(tmpfspec);
5637   }
5638
5639   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5640   sts = rms_free_search_context(&myfab); /* Free search context */
5641   PerlMem_free(esa);
5642   if (esal != NULL)
5643      PerlMem_free(esal);
5644   if (outbufl != NULL)
5645      PerlMem_free(outbufl);
5646   return outbuf;
5647 }
5648 /*}}}*/
5649 /* External entry points */
5650 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5651 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5652 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5653 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5654 char *Perl_rmsexpand_utf8
5655   (pTHX_ const char *spec, char *buf, const char *def,
5656    unsigned opt, int * fs_utf8, int * dfs_utf8)
5657 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5658 char *Perl_rmsexpand_utf8_ts
5659   (pTHX_ const char *spec, char *buf, const char *def,
5660    unsigned opt, int * fs_utf8, int * dfs_utf8)
5661 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5662
5663
5664 /*
5665 ** The following routines are provided to make life easier when
5666 ** converting among VMS-style and Unix-style directory specifications.
5667 ** All will take input specifications in either VMS or Unix syntax. On
5668 ** failure, all return NULL.  If successful, the routines listed below
5669 ** return a pointer to a buffer containing the appropriately
5670 ** reformatted spec (and, therefore, subsequent calls to that routine
5671 ** will clobber the result), while the routines of the same names with
5672 ** a _ts suffix appended will return a pointer to a mallocd string
5673 ** containing the appropriately reformatted spec.
5674 ** In all cases, only explicit syntax is altered; no check is made that
5675 ** the resulting string is valid or that the directory in question
5676 ** actually exists.
5677 **
5678 **   fileify_dirspec() - convert a directory spec into the name of the
5679 **     directory file (i.e. what you can stat() to see if it's a dir).
5680 **     The style (VMS or Unix) of the result is the same as the style
5681 **     of the parameter passed in.
5682 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5683 **     what you prepend to a filename to indicate what directory it's in).
5684 **     The style (VMS or Unix) of the result is the same as the style
5685 **     of the parameter passed in.
5686 **   tounixpath() - convert a directory spec into a Unix-style path.
5687 **   tovmspath() - convert a directory spec into a VMS-style path.
5688 **   tounixspec() - convert any file spec into a Unix-style file spec.
5689 **   tovmsspec() - convert any file spec into a VMS-style spec.
5690 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5691 **
5692 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5693 ** Permission is given to distribute this code as part of the Perl
5694 ** standard distribution under the terms of the GNU General Public
5695 ** License or the Perl Artistic License.  Copies of each may be
5696 ** found in the Perl standard distribution.
5697  */
5698
5699 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5700 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
5701 {
5702     static char __fileify_retbuf[VMS_MAXRSS];
5703     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5704     char *retspec, *cp1, *cp2, *lastdir;
5705     char *trndir, *vmsdir;
5706     unsigned short int trnlnm_iter_count;
5707     int sts;
5708     if (utf8_fl != NULL)
5709         *utf8_fl = 0;
5710
5711     if (!dir || !*dir) {
5712       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5713     }
5714     dirlen = strlen(dir);
5715     while (dirlen && dir[dirlen-1] == '/') --dirlen;
5716     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5717       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5718         dir = "/sys$disk";
5719         dirlen = 9;
5720       }
5721       else
5722         dirlen = 1;
5723     }
5724     if (dirlen > (VMS_MAXRSS - 1)) {
5725       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5726       return NULL;
5727     }
5728     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
5729     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5730     if (!strpbrk(dir+1,"/]>:")  &&
5731         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5732       strcpy(trndir,*dir == '/' ? dir + 1: dir);
5733       trnlnm_iter_count = 0;
5734       while (!strpbrk(trndir,"/]>:") && my_trnlnm(trndir,trndir,0)) {
5735         trnlnm_iter_count++;
5736         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5737       }
5738       dirlen = strlen(trndir);
5739     }
5740     else {
5741       strncpy(trndir,dir,dirlen);
5742       trndir[dirlen] = '\0';
5743     }
5744
5745     /* At this point we are done with *dir and use *trndir which is a
5746      * copy that can be modified.  *dir must not be modified.
5747      */
5748
5749     /* If we were handed a rooted logical name or spec, treat it like a
5750      * simple directory, so that
5751      *    $ Define myroot dev:[dir.]
5752      *    ... do_fileify_dirspec("myroot",buf,1) ...
5753      * does something useful.
5754      */
5755     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5756       trndir[--dirlen] = '\0';
5757       trndir[dirlen-1] = ']';
5758     }
5759     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5760       trndir[--dirlen] = '\0';
5761       trndir[dirlen-1] = '>';
5762     }
5763
5764     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5765       /* If we've got an explicit filename, we can just shuffle the string. */
5766       if (*(cp1+1)) hasfilename = 1;
5767       /* Similarly, we can just back up a level if we've got multiple levels
5768          of explicit directories in a VMS spec which ends with directories. */
5769       else {
5770         for (cp2 = cp1; cp2 > trndir; cp2--) {
5771           if (*cp2 == '.') {
5772             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5773 /* fix-me, can not scan EFS file specs backward like this */
5774               *cp2 = *cp1; *cp1 = '\0';
5775               hasfilename = 1;
5776               break;
5777             }
5778           }
5779           if (*cp2 == '[' || *cp2 == '<') break;
5780         }
5781       }
5782     }
5783
5784     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
5785     if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
5786     cp1 = strpbrk(trndir,"]:>");
5787     if (hasfilename || !cp1) { /* Unix-style path or filename */
5788       if (trndir[0] == '.') {
5789         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5790           PerlMem_free(trndir);
5791           PerlMem_free(vmsdir);
5792           return do_fileify_dirspec("[]",buf,ts,NULL);
5793         }
5794         else if (trndir[1] == '.' &&
5795                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5796           PerlMem_free(trndir);
5797           PerlMem_free(vmsdir);
5798           return do_fileify_dirspec("[-]",buf,ts,NULL);
5799         }
5800       }
5801       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
5802         dirlen -= 1;                 /* to last element */
5803         lastdir = strrchr(trndir,'/');
5804       }
5805       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
5806         /* If we have "/." or "/..", VMSify it and let the VMS code
5807          * below expand it, rather than repeating the code to handle
5808          * relative components of a filespec here */
5809         do {
5810           if (*(cp1+2) == '.') cp1++;
5811           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
5812             char * ret_chr;
5813             if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5814                 PerlMem_free(trndir);
5815                 PerlMem_free(vmsdir);
5816                 return NULL;
5817             }
5818             if (strchr(vmsdir,'/') != NULL) {
5819               /* If do_tovmsspec() returned it, it must have VMS syntax
5820                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
5821                * the time to check this here only so we avoid a recursion
5822                * loop; otherwise, gigo.
5823                */
5824               PerlMem_free(trndir);
5825               PerlMem_free(vmsdir);
5826               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
5827               return NULL;
5828             }
5829             if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5830                 PerlMem_free(trndir);
5831                 PerlMem_free(vmsdir);
5832                 return NULL;
5833             }
5834             ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5835             PerlMem_free(trndir);
5836             PerlMem_free(vmsdir);
5837             return ret_chr;
5838           }
5839           cp1++;
5840         } while ((cp1 = strstr(cp1,"/.")) != NULL);
5841         lastdir = strrchr(trndir,'/');
5842       }
5843       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5844         char * ret_chr;
5845         /* Ditto for specs that end in an MFD -- let the VMS code
5846          * figure out whether it's a real device or a rooted logical. */
5847
5848         /* This should not happen any more.  Allowing the fake /000000
5849          * in a UNIX pathname causes all sorts of problems when trying
5850          * to run in UNIX emulation.  So the VMS to UNIX conversions
5851          * now remove the fake /000000 directories.
5852          */
5853
5854         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5855         if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5856             PerlMem_free(trndir);
5857             PerlMem_free(vmsdir);
5858             return NULL;
5859         }
5860         if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5861             PerlMem_free(trndir);
5862             PerlMem_free(vmsdir);
5863             return NULL;
5864         }
5865         ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5866         PerlMem_free(trndir);
5867         PerlMem_free(vmsdir);
5868         return ret_chr;
5869       }
5870       else {
5871
5872         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5873              !(lastdir = cp1 = strrchr(trndir,']')) &&
5874              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5875         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
5876           int ver; char *cp3;
5877
5878           /* For EFS or ODS-5 look for the last dot */
5879           if (decc_efs_charset) {
5880               cp2 = strrchr(cp1,'.');
5881           }
5882           if (vms_process_case_tolerant) {
5883               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5884                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5885                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5886                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5887                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5888                             (ver || *cp3)))))) {
5889                   PerlMem_free(trndir);
5890                   PerlMem_free(vmsdir);
5891                   set_errno(ENOTDIR);
5892                   set_vaxc_errno(RMS$_DIR);
5893                   return NULL;
5894               }
5895           }
5896           else {
5897               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5898                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5899                   !*(cp2+3) || *(cp2+3) != 'R' ||
5900                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5901                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5902                             (ver || *cp3)))))) {
5903                  PerlMem_free(trndir);
5904                  PerlMem_free(vmsdir);
5905                  set_errno(ENOTDIR);
5906                  set_vaxc_errno(RMS$_DIR);
5907                  return NULL;
5908               }
5909           }
5910           dirlen = cp2 - trndir;
5911         }
5912       }
5913
5914       retlen = dirlen + 6;
5915       if (buf) retspec = buf;
5916       else if (ts) Newx(retspec,retlen+1,char);
5917       else retspec = __fileify_retbuf;
5918       memcpy(retspec,trndir,dirlen);
5919       retspec[dirlen] = '\0';
5920
5921       /* We've picked up everything up to the directory file name.
5922          Now just add the type and version, and we're set. */
5923       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5924         strcat(retspec,".dir;1");
5925       else
5926         strcat(retspec,".DIR;1");
5927       PerlMem_free(trndir);
5928       PerlMem_free(vmsdir);
5929       return retspec;
5930     }
5931     else {  /* VMS-style directory spec */
5932
5933       char *esa, term, *cp;
5934       unsigned long int sts, cmplen, haslower = 0;
5935       unsigned int nam_fnb;
5936       char * nam_type;
5937       struct FAB dirfab = cc$rms_fab;
5938       rms_setup_nam(savnam);
5939       rms_setup_nam(dirnam);
5940
5941       esa = PerlMem_malloc(VMS_MAXRSS + 1);
5942       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5943       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5944       rms_bind_fab_nam(dirfab, dirnam);
5945       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5946       rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
5947 #ifdef NAM$M_NO_SHORT_UPCASE
5948       if (decc_efs_case_preserve)
5949         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5950 #endif
5951
5952       for (cp = trndir; *cp; cp++)
5953         if (islower(*cp)) { haslower = 1; break; }
5954       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5955         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5956           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5957           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5958         }
5959         if (!sts) {
5960           PerlMem_free(esa);
5961           PerlMem_free(trndir);
5962           PerlMem_free(vmsdir);
5963           set_errno(EVMSERR);
5964           set_vaxc_errno(dirfab.fab$l_sts);
5965           return NULL;
5966         }
5967       }
5968       else {
5969         savnam = dirnam;
5970         /* Does the file really exist? */
5971         if (sys$search(&dirfab)& STS$K_SUCCESS) {
5972           /* Yes; fake the fnb bits so we'll check type below */
5973         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
5974         }
5975         else { /* No; just work with potential name */
5976           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
5977           else {
5978             int fab_sts;
5979             fab_sts = dirfab.fab$l_sts;
5980             sts = rms_free_search_context(&dirfab);
5981             PerlMem_free(esa);
5982             PerlMem_free(trndir);
5983             PerlMem_free(vmsdir);
5984             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
5985             return NULL;
5986           }
5987         }
5988       }
5989       esa[rms_nam_esll(dirnam)] = '\0';
5990       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
5991         cp1 = strchr(esa,']');
5992         if (!cp1) cp1 = strchr(esa,'>');
5993         if (cp1) {  /* Should always be true */
5994           rms_nam_esll(dirnam) -= cp1 - esa - 1;
5995           memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
5996         }
5997       }
5998       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5999         /* Yep; check version while we're at it, if it's there. */
6000         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6001         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6002           /* Something other than .DIR[;1].  Bzzt. */
6003           sts = rms_free_search_context(&dirfab);
6004           PerlMem_free(esa);
6005           PerlMem_free(trndir);
6006           PerlMem_free(vmsdir);
6007           set_errno(ENOTDIR);
6008           set_vaxc_errno(RMS$_DIR);
6009           return NULL;
6010         }
6011       }
6012
6013       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6014         /* They provided at least the name; we added the type, if necessary, */
6015         if (buf) retspec = buf;                            /* in sys$parse() */
6016         else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
6017         else retspec = __fileify_retbuf;
6018         strcpy(retspec,esa);
6019         sts = rms_free_search_context(&dirfab);
6020         PerlMem_free(trndir);
6021         PerlMem_free(esa);
6022         PerlMem_free(vmsdir);
6023         return retspec;
6024       }
6025       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6026         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6027         *cp1 = '\0';
6028         rms_nam_esll(dirnam) -= 9;
6029       }
6030       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
6031       if (cp1 == NULL) { /* should never happen */
6032         sts = rms_free_search_context(&dirfab);
6033         PerlMem_free(trndir);
6034         PerlMem_free(esa);
6035         PerlMem_free(vmsdir);
6036         return NULL;
6037       }
6038       term = *cp1;
6039       *cp1 = '\0';
6040       retlen = strlen(esa);
6041       cp1 = strrchr(esa,'.');
6042       /* ODS-5 directory specifications can have extra "." in them. */
6043       /* Fix-me, can not scan EFS file specifications backwards */
6044       while (cp1 != NULL) {
6045         if ((cp1-1 == esa) || (*(cp1-1) != '^'))
6046           break;
6047         else {
6048            cp1--;
6049            while ((cp1 > esa) && (*cp1 != '.'))
6050              cp1--;
6051         }
6052         if (cp1 == esa)
6053           cp1 = NULL;
6054       }
6055
6056       if ((cp1) != NULL) {
6057         /* There's more than one directory in the path.  Just roll back. */
6058         *cp1 = term;
6059         if (buf) retspec = buf;
6060         else if (ts) Newx(retspec,retlen+7,char);
6061         else retspec = __fileify_retbuf;
6062         strcpy(retspec,esa);
6063       }
6064       else {
6065         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6066           /* Go back and expand rooted logical name */
6067           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6068 #ifdef NAM$M_NO_SHORT_UPCASE
6069           if (decc_efs_case_preserve)
6070             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6071 #endif
6072           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6073             sts = rms_free_search_context(&dirfab);
6074             PerlMem_free(esa);
6075             PerlMem_free(trndir);
6076             PerlMem_free(vmsdir);
6077             set_errno(EVMSERR);
6078             set_vaxc_errno(dirfab.fab$l_sts);
6079             return NULL;
6080           }
6081           retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
6082           if (buf) retspec = buf;
6083           else if (ts) Newx(retspec,retlen+16,char);
6084           else retspec = __fileify_retbuf;
6085           cp1 = strstr(esa,"][");
6086           if (!cp1) cp1 = strstr(esa,"]<");
6087           dirlen = cp1 - esa;
6088           memcpy(retspec,esa,dirlen);
6089           if (!strncmp(cp1+2,"000000]",7)) {
6090             retspec[dirlen-1] = '\0';
6091             /* fix-me Not full ODS-5, just extra dots in directories for now */
6092             cp1 = retspec + dirlen - 1;
6093             while (cp1 > retspec)
6094             {
6095               if (*cp1 == '[')
6096                 break;
6097               if (*cp1 == '.') {
6098                 if (*(cp1-1) != '^')
6099                   break;
6100               }
6101               cp1--;
6102             }
6103             if (*cp1 == '.') *cp1 = ']';
6104             else {
6105               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6106               memmove(cp1+1,"000000]",7);
6107             }
6108           }
6109           else {
6110             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
6111             retspec[retlen] = '\0';
6112             /* Convert last '.' to ']' */
6113             cp1 = retspec+retlen-1;
6114             while (*cp != '[') {
6115               cp1--;
6116               if (*cp1 == '.') {
6117                 /* Do not trip on extra dots in ODS-5 directories */
6118                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
6119                 break;
6120               }
6121             }
6122             if (*cp1 == '.') *cp1 = ']';
6123             else {
6124               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6125               memmove(cp1+1,"000000]",7);
6126             }
6127           }
6128         }
6129         else {  /* This is a top-level dir.  Add the MFD to the path. */
6130           if (buf) retspec = buf;
6131           else if (ts) Newx(retspec,retlen+16,char);
6132           else retspec = __fileify_retbuf;
6133           cp1 = esa;
6134           cp2 = retspec;
6135           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6136           strcpy(cp2,":[000000]");
6137           cp1 += 2;
6138           strcpy(cp2+9,cp1);
6139         }
6140       }
6141       sts = rms_free_search_context(&dirfab);
6142       /* We've set up the string up through the filename.  Add the
6143          type and version, and we're done. */
6144       strcat(retspec,".DIR;1");
6145
6146       /* $PARSE may have upcased filespec, so convert output to lower
6147        * case if input contained any lowercase characters. */
6148       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
6149       PerlMem_free(trndir);
6150       PerlMem_free(esa);
6151       PerlMem_free(vmsdir);
6152       return retspec;
6153     }
6154 }  /* end of do_fileify_dirspec() */
6155 /*}}}*/
6156 /* External entry points */
6157 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6158 { return do_fileify_dirspec(dir,buf,0,NULL); }
6159 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6160 { return do_fileify_dirspec(dir,buf,1,NULL); }
6161 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6162 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6163 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6164 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6165
6166 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6167 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6168 {
6169     static char __pathify_retbuf[VMS_MAXRSS];
6170     unsigned long int retlen;
6171     char *retpath, *cp1, *cp2, *trndir;
6172     unsigned short int trnlnm_iter_count;
6173     STRLEN trnlen;
6174     int sts;
6175     if (utf8_fl != NULL)
6176         *utf8_fl = 0;
6177
6178     if (!dir || !*dir) {
6179       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6180     }
6181
6182     trndir = PerlMem_malloc(VMS_MAXRSS);
6183     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
6184     if (*dir) strcpy(trndir,dir);
6185     else getcwd(trndir,VMS_MAXRSS - 1);
6186
6187     trnlnm_iter_count = 0;
6188     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6189            && my_trnlnm(trndir,trndir,0)) {
6190       trnlnm_iter_count++;
6191       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6192       trnlen = strlen(trndir);
6193
6194       /* Trap simple rooted lnms, and return lnm:[000000] */
6195       if (!strcmp(trndir+trnlen-2,".]")) {
6196         if (buf) retpath = buf;
6197         else if (ts) Newx(retpath,strlen(dir)+10,char);
6198         else retpath = __pathify_retbuf;
6199         strcpy(retpath,dir);
6200         strcat(retpath,":[000000]");
6201         PerlMem_free(trndir);
6202         return retpath;
6203       }
6204     }
6205
6206     /* At this point we do not work with *dir, but the copy in
6207      * *trndir that is modifiable.
6208      */
6209
6210     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
6211       if (*trndir == '.' && (*(trndir+1) == '\0' ||
6212                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
6213         retlen = 2 + (*(trndir+1) != '\0');
6214       else {
6215         if ( !(cp1 = strrchr(trndir,'/')) &&
6216              !(cp1 = strrchr(trndir,']')) &&
6217              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
6218         if ((cp2 = strchr(cp1,'.')) != NULL &&
6219             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
6220              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
6221               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
6222               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
6223           int ver; char *cp3;
6224
6225           /* For EFS or ODS-5 look for the last dot */
6226           if (decc_efs_charset) {
6227             cp2 = strrchr(cp1,'.');
6228           }
6229           if (vms_process_case_tolerant) {
6230               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
6231                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
6232                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6233                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6234                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6235                             (ver || *cp3)))))) {
6236                 PerlMem_free(trndir);
6237                 set_errno(ENOTDIR);
6238                 set_vaxc_errno(RMS$_DIR);
6239                 return NULL;
6240               }
6241           }
6242           else {
6243               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
6244                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
6245                   !*(cp2+3) || *(cp2+3) != 'R' ||
6246                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6247                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6248                             (ver || *cp3)))))) {
6249                 PerlMem_free(trndir);
6250                 set_errno(ENOTDIR);
6251                 set_vaxc_errno(RMS$_DIR);
6252                 return NULL;
6253               }
6254           }
6255           retlen = cp2 - trndir + 1;
6256         }
6257         else {  /* No file type present.  Treat the filename as a directory. */
6258           retlen = strlen(trndir) + 1;
6259         }
6260       }
6261       if (buf) retpath = buf;
6262       else if (ts) Newx(retpath,retlen+1,char);
6263       else retpath = __pathify_retbuf;
6264       strncpy(retpath, trndir, retlen-1);
6265       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
6266         retpath[retlen-1] = '/';      /* with '/', add it. */
6267         retpath[retlen] = '\0';
6268       }
6269       else retpath[retlen-1] = '\0';
6270     }
6271     else {  /* VMS-style directory spec */
6272       char *esa, *cp;
6273       unsigned long int sts, cmplen, haslower;
6274       struct FAB dirfab = cc$rms_fab;
6275       int dirlen;
6276       rms_setup_nam(savnam);
6277       rms_setup_nam(dirnam);
6278
6279       /* If we've got an explicit filename, we can just shuffle the string. */
6280       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
6281              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
6282         if ((cp2 = strchr(cp1,'.')) != NULL) {
6283           int ver; char *cp3;
6284           if (vms_process_case_tolerant) {
6285               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
6286                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
6287                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6288                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6289                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6290                             (ver || *cp3)))))) {
6291                PerlMem_free(trndir);
6292                set_errno(ENOTDIR);
6293                set_vaxc_errno(RMS$_DIR);
6294                return NULL;
6295              }
6296           }
6297           else {
6298               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
6299                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
6300                   !*(cp2+3) || *(cp2+3) != 'R' ||
6301                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6302                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6303                             (ver || *cp3)))))) {
6304                PerlMem_free(trndir);
6305                set_errno(ENOTDIR);
6306                set_vaxc_errno(RMS$_DIR);
6307                return NULL;
6308              }
6309           }
6310         }
6311         else {  /* No file type, so just draw name into directory part */
6312           for (cp2 = cp1; *cp2; cp2++) ;
6313         }
6314         *cp2 = *cp1;
6315         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
6316         *cp1 = '.';
6317         /* We've now got a VMS 'path'; fall through */
6318       }
6319
6320       dirlen = strlen(trndir);
6321       if (trndir[dirlen-1] == ']' ||
6322           trndir[dirlen-1] == '>' ||
6323           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
6324         if (buf) retpath = buf;
6325         else if (ts) Newx(retpath,strlen(trndir)+1,char);
6326         else retpath = __pathify_retbuf;
6327         strcpy(retpath,trndir);
6328         PerlMem_free(trndir);
6329         return retpath;
6330       }
6331       rms_set_fna(dirfab, dirnam, trndir, dirlen);
6332       esa = PerlMem_malloc(VMS_MAXRSS);
6333       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
6334       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6335       rms_bind_fab_nam(dirfab, dirnam);
6336       rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
6337 #ifdef NAM$M_NO_SHORT_UPCASE
6338       if (decc_efs_case_preserve)
6339           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6340 #endif
6341
6342       for (cp = trndir; *cp; cp++)
6343         if (islower(*cp)) { haslower = 1; break; }
6344
6345       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
6346         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
6347           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6348           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
6349         }
6350         if (!sts) {
6351           PerlMem_free(trndir);
6352           PerlMem_free(esa);
6353           set_errno(EVMSERR);
6354           set_vaxc_errno(dirfab.fab$l_sts);
6355           return NULL;
6356         }
6357       }
6358       else {
6359         savnam = dirnam;
6360         /* Does the file really exist? */
6361         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
6362           if (dirfab.fab$l_sts != RMS$_FNF) {
6363             int sts1;
6364             sts1 = rms_free_search_context(&dirfab);
6365             PerlMem_free(trndir);
6366             PerlMem_free(esa);
6367             set_errno(EVMSERR);
6368             set_vaxc_errno(dirfab.fab$l_sts);
6369             return NULL;
6370           }
6371           dirnam = savnam; /* No; just work with potential name */
6372         }
6373       }
6374       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6375         /* Yep; check version while we're at it, if it's there. */
6376         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6377         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
6378           int sts2;
6379           /* Something other than .DIR[;1].  Bzzt. */
6380           sts2 = rms_free_search_context(&dirfab);
6381           PerlMem_free(trndir);
6382           PerlMem_free(esa);
6383           set_errno(ENOTDIR);
6384           set_vaxc_errno(RMS$_DIR);
6385           return NULL;
6386         }
6387       }
6388       /* OK, the type was fine.  Now pull any file name into the
6389          directory path. */
6390       if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
6391       else {
6392         cp1 = strrchr(esa,'>');
6393         *(rms_nam_typel(dirnam)) = '>';
6394       }
6395       *cp1 = '.';
6396       *(rms_nam_typel(dirnam) + 1) = '\0';
6397       retlen = (rms_nam_typel(dirnam)) - esa + 2;
6398       if (buf) retpath = buf;
6399       else if (ts) Newx(retpath,retlen,char);
6400       else retpath = __pathify_retbuf;
6401       strcpy(retpath,esa);
6402       PerlMem_free(esa);
6403       sts = rms_free_search_context(&dirfab);
6404       /* $PARSE may have upcased filespec, so convert output to lower
6405        * case if input contained any lowercase characters. */
6406       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
6407     }
6408
6409     PerlMem_free(trndir);
6410     return retpath;
6411 }  /* end of do_pathify_dirspec() */
6412 /*}}}*/
6413 /* External entry points */
6414 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6415 { return do_pathify_dirspec(dir,buf,0,NULL); }
6416 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6417 { return do_pathify_dirspec(dir,buf,1,NULL); }
6418 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6419 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6420 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6421 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
6422
6423 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
6424 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
6425 {
6426   static char __tounixspec_retbuf[VMS_MAXRSS];
6427   char *dirend, *rslt, *cp1, *cp3, *tmp;
6428   const char *cp2;
6429   int devlen, dirlen, retlen = VMS_MAXRSS;
6430   int expand = 1; /* guarantee room for leading and trailing slashes */
6431   unsigned short int trnlnm_iter_count;
6432   int cmp_rslt;
6433   if (utf8_fl != NULL)
6434     *utf8_fl = 0;
6435
6436   if (spec == NULL) return NULL;
6437   if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
6438   if (buf) rslt = buf;
6439   else if (ts) {
6440     Newx(rslt, VMS_MAXRSS, char);
6441   }
6442   else rslt = __tounixspec_retbuf;
6443
6444   /* New VMS specific format needs translation
6445    * glob passes filenames with trailing '\n' and expects this preserved.
6446    */
6447   if (decc_posix_compliant_pathnames) {
6448     if (strncmp(spec, "\"^UP^", 5) == 0) {
6449       char * uspec;
6450       char *tunix;
6451       int tunix_len;
6452       int nl_flag;
6453
6454       tunix = PerlMem_malloc(VMS_MAXRSS);
6455       if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
6456       strcpy(tunix, spec);
6457       tunix_len = strlen(tunix);
6458       nl_flag = 0;
6459       if (tunix[tunix_len - 1] == '\n') {
6460         tunix[tunix_len - 1] = '\"';
6461         tunix[tunix_len] = '\0';
6462         tunix_len--;
6463         nl_flag = 1;
6464       }
6465       uspec = decc$translate_vms(tunix);
6466       PerlMem_free(tunix);
6467       if ((int)uspec > 0) {
6468         strcpy(rslt,uspec);
6469         if (nl_flag) {
6470           strcat(rslt,"\n");
6471         }
6472         else {
6473           /* If we can not translate it, makemaker wants as-is */
6474           strcpy(rslt, spec);
6475         }
6476         return rslt;
6477       }
6478     }
6479   }
6480
6481   cmp_rslt = 0; /* Presume VMS */
6482   cp1 = strchr(spec, '/');
6483   if (cp1 == NULL)
6484     cmp_rslt = 0;
6485
6486     /* Look for EFS ^/ */
6487     if (decc_efs_charset) {
6488       while (cp1 != NULL) {
6489         cp2 = cp1 - 1;
6490         if (*cp2 != '^') {
6491           /* Found illegal VMS, assume UNIX */
6492           cmp_rslt = 1;
6493           break;
6494         }
6495       cp1++;
6496       cp1 = strchr(cp1, '/');
6497     }
6498   }
6499
6500   /* Look for "." and ".." */
6501   if (decc_filename_unix_report) {
6502     if (spec[0] == '.') {
6503       if ((spec[1] == '\0') || (spec[1] == '\n')) {
6504         cmp_rslt = 1;
6505       }
6506       else {
6507         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
6508           cmp_rslt = 1;
6509         }
6510       }
6511     }
6512   }
6513   /* This is already UNIX or at least nothing VMS understands */
6514   if (cmp_rslt) {
6515     strcpy(rslt,spec);
6516     return rslt;
6517   }
6518
6519   cp1 = rslt;
6520   cp2 = spec;
6521   dirend = strrchr(spec,']');
6522   if (dirend == NULL) dirend = strrchr(spec,'>');
6523   if (dirend == NULL) dirend = strchr(spec,':');
6524   if (dirend == NULL) {
6525     strcpy(rslt,spec);
6526     return rslt;
6527   }
6528
6529   /* Special case 1 - sys$posix_root = / */
6530 #if __CRTL_VER >= 70000000
6531   if (!decc_disable_posix_root) {
6532     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6533       *cp1 = '/';
6534       cp1++;
6535       cp2 = cp2 + 15;
6536       }
6537   }
6538 #endif
6539
6540   /* Special case 2 - Convert NLA0: to /dev/null */
6541 #if __CRTL_VER < 70000000
6542   cmp_rslt = strncmp(spec,"NLA0:", 5);
6543   if (cmp_rslt != 0)
6544      cmp_rslt = strncmp(spec,"nla0:", 5);
6545 #else
6546   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6547 #endif
6548   if (cmp_rslt == 0) {
6549     strcpy(rslt, "/dev/null");
6550     cp1 = cp1 + 9;
6551     cp2 = cp2 + 5;
6552     if (spec[6] != '\0') {
6553       cp1[9] == '/';
6554       cp1++;
6555       cp2++;
6556     }
6557   }
6558
6559    /* Also handle special case "SYS$SCRATCH:" */
6560 #if __CRTL_VER < 70000000
6561   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
6562   if (cmp_rslt != 0)
6563      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
6564 #else
6565   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6566 #endif
6567   tmp = PerlMem_malloc(VMS_MAXRSS);
6568   if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
6569   if (cmp_rslt == 0) {
6570   int islnm;
6571
6572     islnm = my_trnlnm(tmp, "TMP", 0);
6573     if (!islnm) {
6574       strcpy(rslt, "/tmp");
6575       cp1 = cp1 + 4;
6576       cp2 = cp2 + 12;
6577       if (spec[12] != '\0') {
6578         cp1[4] == '/';
6579         cp1++;
6580         cp2++;
6581       }
6582     }
6583   }
6584
6585   if (*cp2 != '[' && *cp2 != '<') {
6586     *(cp1++) = '/';
6587   }
6588   else {  /* the VMS spec begins with directories */
6589     cp2++;
6590     if (*cp2 == ']' || *cp2 == '>') {
6591       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
6592       PerlMem_free(tmp);
6593       return rslt;
6594     }
6595     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
6596       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
6597         if (ts) Safefree(rslt);
6598         PerlMem_free(tmp);
6599         return NULL;
6600       }
6601       trnlnm_iter_count = 0;
6602       do {
6603         cp3 = tmp;
6604         while (*cp3 != ':' && *cp3) cp3++;
6605         *(cp3++) = '\0';
6606         if (strchr(cp3,']') != NULL) break;
6607         trnlnm_iter_count++;
6608         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
6609       } while (vmstrnenv(tmp,tmp,0,fildev,0));
6610       if (ts && !buf &&
6611           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
6612         retlen = devlen + dirlen;
6613         Renew(rslt,retlen+1+2*expand,char);
6614         cp1 = rslt;
6615       }
6616       cp3 = tmp;
6617       *(cp1++) = '/';
6618       while (*cp3) {
6619         *(cp1++) = *(cp3++);
6620         if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
6621             PerlMem_free(tmp);
6622             return NULL; /* No room */
6623         }
6624       }
6625       *(cp1++) = '/';
6626     }
6627     if ((*cp2 == '^')) {
6628         /* EFS file escape, pass the next character as is */
6629         /* Fix me: HEX encoding for Unicode not implemented */
6630         cp2++;
6631     }
6632     else if ( *cp2 == '.') {
6633       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
6634         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6635         cp2 += 3;
6636       }
6637       else cp2++;
6638     }
6639   }
6640   PerlMem_free(tmp);
6641   for (; cp2 <= dirend; cp2++) {
6642     if ((*cp2 == '^')) {
6643         /* EFS file escape, pass the next character as is */
6644         /* Fix me: HEX encoding for Unicode not implemented */
6645         *(cp1++) = *(++cp2);
6646         /* An escaped dot stays as is -- don't convert to slash */
6647         if (*cp2 == '.') cp2++;
6648     }
6649     if (*cp2 == ':') {
6650       *(cp1++) = '/';
6651       if (*(cp2+1) == '[') cp2++;
6652     }
6653     else if (*cp2 == ']' || *cp2 == '>') {
6654       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6655     }
6656     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
6657       *(cp1++) = '/';
6658       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6659         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6660                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6661         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6662             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6663       }
6664       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6665         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6666         cp2 += 2;
6667       }
6668     }
6669     else if (*cp2 == '-') {
6670       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6671         while (*cp2 == '-') {
6672           cp2++;
6673           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6674         }
6675         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
6676           if (ts) Safefree(rslt);                        /* filespecs like */
6677           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
6678           return NULL;
6679         }
6680       }
6681       else *(cp1++) = *cp2;
6682     }
6683     else *(cp1++) = *cp2;
6684   }
6685   while (*cp2) {
6686     if ((*cp2 == '^') && (*(cp2+1) == '.')) cp2++;  /* '^.' --> '.' */
6687     *(cp1++) = *(cp2++);
6688   }
6689   *cp1 = '\0';
6690
6691   /* This still leaves /000000/ when working with a
6692    * VMS device root or concealed root.
6693    */
6694   {
6695   int ulen;
6696   char * zeros;
6697
6698       ulen = strlen(rslt);
6699
6700       /* Get rid of "000000/ in rooted filespecs */
6701       if (ulen > 7) {
6702         zeros = strstr(rslt, "/000000/");
6703         if (zeros != NULL) {
6704           int mlen;
6705           mlen = ulen - (zeros - rslt) - 7;
6706           memmove(zeros, &zeros[7], mlen);
6707           ulen = ulen - 7;
6708           rslt[ulen] = '\0';
6709         }
6710       }
6711   }
6712
6713   return rslt;
6714
6715 }  /* end of do_tounixspec() */
6716 /*}}}*/
6717 /* External entry points */
6718 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
6719   { return do_tounixspec(spec,buf,0, NULL); }
6720 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
6721   { return do_tounixspec(spec,buf,1, NULL); }
6722 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
6723   { return do_tounixspec(spec,buf,0, utf8_fl); }
6724 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
6725   { return do_tounixspec(spec,buf,1, utf8_fl); }
6726
6727 #if __CRTL_VER >= 70200000 && !defined(__VAX)
6728
6729 /*
6730  This procedure is used to identify if a path is based in either
6731  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
6732  it returns the OpenVMS format directory for it.
6733
6734  It is expecting specifications of only '/' or '/xxxx/'
6735
6736  If a posix root does not exist, or 'xxxx' is not a directory
6737  in the posix root, it returns a failure.
6738
6739  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
6740
6741  It is used only internally by posix_to_vmsspec_hardway().
6742  */
6743
6744 static int posix_root_to_vms
6745   (char *vmspath, int vmspath_len,
6746    const char *unixpath,
6747    const int * utf8_fl) {
6748 int sts;
6749 struct FAB myfab = cc$rms_fab;
6750 struct NAML mynam = cc$rms_naml;
6751 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6752  struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6753 char *esa;
6754 char *vms_delim;
6755 int dir_flag;
6756 int unixlen;
6757
6758     dir_flag = 0;
6759     unixlen = strlen(unixpath);
6760     if (unixlen == 0) {
6761       vmspath[0] = '\0';
6762       return RMS$_FNF;
6763     }
6764
6765 #if __CRTL_VER >= 80200000
6766   /* If not a posix spec already, convert it */
6767   if (decc_posix_compliant_pathnames) {
6768     if (strncmp(unixpath,"\"^UP^",5) != 0) {
6769       sprintf(vmspath,"\"^UP^%s\"",unixpath);
6770     }
6771     else {
6772       /* This is already a VMS specification, no conversion */
6773       unixlen--;
6774       strncpy(vmspath,unixpath, vmspath_len);
6775     }
6776   }
6777   else
6778 #endif
6779   {
6780   int path_len;
6781   int i,j;
6782
6783      /* Check to see if this is under the POSIX root */
6784      if (decc_disable_posix_root) {
6785         return RMS$_FNF;
6786      }
6787
6788      /* Skip leading / */
6789      if (unixpath[0] == '/') {
6790         unixpath++;
6791         unixlen--;
6792      }
6793
6794
6795      strcpy(vmspath,"SYS$POSIX_ROOT:");
6796
6797      /* If this is only the / , or blank, then... */
6798      if (unixpath[0] == '\0') {
6799         /* by definition, this is the answer */
6800         return SS$_NORMAL;
6801      }
6802
6803      /* Need to look up a directory */
6804      vmspath[15] = '[';
6805      vmspath[16] = '\0';
6806
6807      /* Copy and add '^' escape characters as needed */
6808      j = 16;
6809      i = 0;
6810      while (unixpath[i] != 0) {
6811      int k;
6812
6813         j += copy_expand_unix_filename_escape
6814             (&vmspath[j], &unixpath[i], &k, utf8_fl);
6815         i += k;
6816      }
6817
6818      path_len = strlen(vmspath);
6819      if (vmspath[path_len - 1] == '/')
6820         path_len--;
6821      vmspath[path_len] = ']';
6822      path_len++;
6823      vmspath[path_len] = '\0';
6824
6825   }
6826   vmspath[vmspath_len] = 0;
6827   if (unixpath[unixlen - 1] == '/')
6828   dir_flag = 1;
6829   esa = PerlMem_malloc(VMS_MAXRSS);
6830   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6831   myfab.fab$l_fna = vmspath;
6832   myfab.fab$b_fns = strlen(vmspath);
6833   myfab.fab$l_naml = &mynam;
6834   mynam.naml$l_esa = NULL;
6835   mynam.naml$b_ess = 0;
6836   mynam.naml$l_long_expand = esa;
6837   mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
6838   mynam.naml$l_rsa = NULL;
6839   mynam.naml$b_rss = 0;
6840   if (decc_efs_case_preserve)
6841     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6842 #ifdef NAML$M_OPEN_SPECIAL
6843   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6844 #endif
6845
6846   /* Set up the remaining naml fields */
6847   sts = sys$parse(&myfab);
6848
6849   /* It failed! Try again as a UNIX filespec */
6850   if (!(sts & 1)) {
6851     PerlMem_free(esa);
6852     return sts;
6853   }
6854
6855    /* get the Device ID and the FID */
6856    sts = sys$search(&myfab);
6857    /* on any failure, returned the POSIX ^UP^ filespec */
6858    if (!(sts & 1)) {
6859       PerlMem_free(esa);
6860       return sts;
6861    }
6862    specdsc.dsc$a_pointer = vmspath;
6863    specdsc.dsc$w_length = vmspath_len;
6864
6865    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6866    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6867    sts = lib$fid_to_name
6868       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6869
6870   /* on any failure, returned the POSIX ^UP^ filespec */
6871   if (!(sts & 1)) {
6872      /* This can happen if user does not have permission to read directories */
6873      if (strncmp(unixpath,"\"^UP^",5) != 0)
6874        sprintf(vmspath,"\"^UP^%s\"",unixpath);
6875      else
6876        strcpy(vmspath, unixpath);
6877   }
6878   else {
6879     vmspath[specdsc.dsc$w_length] = 0;
6880
6881     /* Are we expecting a directory? */
6882     if (dir_flag != 0) {
6883     int i;
6884     char *eptr;
6885
6886       eptr = NULL;
6887
6888       i = specdsc.dsc$w_length - 1;
6889       while (i > 0) {
6890       int zercnt;
6891         zercnt = 0;
6892         /* Version must be '1' */
6893         if (vmspath[i--] != '1')
6894           break;
6895         /* Version delimiter is one of ".;" */
6896         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6897           break;
6898         i--;
6899         if (vmspath[i--] != 'R')
6900           break;
6901         if (vmspath[i--] != 'I')
6902           break;
6903         if (vmspath[i--] != 'D')
6904           break;
6905         if (vmspath[i--] != '.')
6906           break;
6907         eptr = &vmspath[i+1];
6908         while (i > 0) {
6909           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
6910             if (vmspath[i-1] != '^') {
6911               if (zercnt != 6) {
6912                 *eptr = vmspath[i];
6913                 eptr[1] = '\0';
6914                 vmspath[i] = '.';
6915                 break;
6916               }
6917               else {
6918                 /* Get rid of 6 imaginary zero directory filename */
6919                 vmspath[i+1] = '\0';
6920               }
6921             }
6922           }
6923           if (vmspath[i] == '0')
6924             zercnt++;
6925           else
6926             zercnt = 10;
6927           i--;
6928         }
6929         break;
6930       }
6931     }
6932   }
6933   PerlMem_free(esa);
6934   return sts;
6935 }
6936
6937 /* /dev/mumble needs to be handled special.
6938    /dev/null becomes NLA0:, And there is the potential for other stuff
6939    like /dev/tty which may need to be mapped to something.
6940 */
6941
6942 static int
6943 slash_dev_special_to_vms
6944    (const char * unixptr,
6945     char * vmspath,
6946     int vmspath_len)
6947 {
6948 char * nextslash;
6949 int len;
6950 int cmp;
6951 int islnm;
6952
6953     unixptr += 4;
6954     nextslash = strchr(unixptr, '/');
6955     len = strlen(unixptr);
6956     if (nextslash != NULL)
6957         len = nextslash - unixptr;
6958     cmp = strncmp("null", unixptr, 5);
6959     if (cmp == 0) {
6960         if (vmspath_len >= 6) {
6961             strcpy(vmspath, "_NLA0:");
6962             return SS$_NORMAL;
6963         }
6964     }
6965 }
6966
6967
6968 /* The built in routines do not understand perl's special needs, so
6969     doing a manual conversion from UNIX to VMS
6970
6971     If the utf8_fl is not null and points to a non-zero value, then
6972     treat 8 bit characters as UTF-8.
6973
6974     The sequence starting with '$(' and ending with ')' will be passed
6975     through with out interpretation instead of being escaped.
6976
6977   */
6978 static int posix_to_vmsspec_hardway
6979   (char *vmspath, int vmspath_len,
6980    const char *unixpath,
6981    int dir_flag,
6982    int * utf8_fl) {
6983
6984 char *esa;
6985 const char *unixptr;
6986 const char *unixend;
6987 char *vmsptr;
6988 const char *lastslash;
6989 const char *lastdot;
6990 int unixlen;
6991 int vmslen;
6992 int dir_start;
6993 int dir_dot;
6994 int quoted;
6995 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6996 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6997
6998   if (utf8_fl != NULL)
6999     *utf8_fl = 0;
7000
7001   unixptr = unixpath;
7002   dir_dot = 0;
7003
7004   /* Ignore leading "/" characters */
7005   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7006     unixptr++;
7007   }
7008   unixlen = strlen(unixptr);
7009
7010   /* Do nothing with blank paths */
7011   if (unixlen == 0) {
7012     vmspath[0] = '\0';
7013     return SS$_NORMAL;
7014   }
7015
7016   quoted = 0;
7017   /* This could have a "^UP^ on the front */
7018   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7019     quoted = 1;
7020     unixptr+= 5;
7021     unixlen-= 5;
7022   }
7023
7024   lastslash = strrchr(unixptr,'/');
7025   lastdot = strrchr(unixptr,'.');
7026   unixend = strrchr(unixptr,'\"');
7027   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7028     unixend = unixptr + unixlen;
7029   }
7030
7031   /* last dot is last dot or past end of string */
7032   if (lastdot == NULL)
7033     lastdot = unixptr + unixlen;
7034
7035   /* if no directories, set last slash to beginning of string */
7036   if (lastslash == NULL) {
7037     lastslash = unixptr;
7038   }
7039   else {
7040     /* Watch out for trailing "." after last slash, still a directory */
7041     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7042       lastslash = unixptr + unixlen;
7043     }
7044
7045     /* Watch out for traiing ".." after last slash, still a directory */
7046     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7047       lastslash = unixptr + unixlen;
7048     }
7049
7050     /* dots in directories are aways escaped */
7051     if (lastdot < lastslash)
7052       lastdot = unixptr + unixlen;
7053   }
7054
7055   /* if (unixptr < lastslash) then we are in a directory */
7056
7057   dir_start = 0;
7058
7059   vmsptr = vmspath;
7060   vmslen = 0;
7061
7062   /* Start with the UNIX path */
7063   if (*unixptr != '/') {
7064     /* relative paths */
7065
7066     /* If allowing logical names on relative pathnames, then handle here */
7067     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7068         !decc_posix_compliant_pathnames) {
7069     char * nextslash;
7070     int seg_len;
7071     char * trn;
7072     int islnm;
7073
7074         /* Find the next slash */
7075         nextslash = strchr(unixptr,'/');
7076
7077         esa = PerlMem_malloc(vmspath_len);
7078         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7079
7080         trn = PerlMem_malloc(VMS_MAXRSS);
7081         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7082
7083         if (nextslash != NULL) {
7084
7085             seg_len = nextslash - unixptr;
7086             strncpy(esa, unixptr, seg_len);
7087             esa[seg_len] = 0;
7088         }
7089         else {
7090             strcpy(esa, unixptr);
7091             seg_len = strlen(unixptr);
7092         }
7093         /* trnlnm(section) */
7094         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7095
7096         if (islnm) {
7097             /* Now fix up the directory */
7098
7099             /* Split up the path to find the components */
7100             sts = vms_split_path
7101                   (trn,
7102                    &v_spec,
7103                    &v_len,
7104                    &r_spec,
7105                    &r_len,
7106                    &d_spec,
7107                    &d_len,
7108                    &n_spec,
7109                    &n_len,
7110                    &e_spec,
7111                    &e_len,
7112                    &vs_spec,
7113                    &vs_len);
7114
7115             while (sts == 0) {
7116             char * strt;
7117             int cmp;
7118
7119                 /* A logical name must be a directory  or the full
7120                    specification.  It is only a full specification if
7121                    it is the only component */
7122                 if ((unixptr[seg_len] == '\0') ||
7123                     (unixptr[seg_len+1] == '\0')) {
7124
7125                     /* Is a directory being required? */
7126                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7127                         /* Not a logical name */
7128                         break;
7129                     }
7130
7131
7132                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7133                         /* This must be a directory */
7134                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7135                             strcpy(vmsptr, esa);
7136                             vmslen=strlen(vmsptr);
7137                             vmsptr[vmslen] = ':';
7138                             vmslen++;
7139                             vmsptr[vmslen] = '\0';
7140                             return SS$_NORMAL;
7141                         }
7142                     }
7143
7144                 }
7145
7146
7147                 /* must be dev/directory - ignore version */
7148                 if ((n_len + e_len) != 0)
7149                     break;
7150
7151                 /* transfer the volume */
7152                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7153                     strncpy(vmsptr, v_spec, v_len);
7154                     vmsptr += v_len;
7155                     vmsptr[0] = '\0';
7156                     vmslen += v_len;
7157                 }
7158
7159                 /* unroot the rooted directory */
7160                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7161                     r_spec[0] = '[';
7162                     r_spec[r_len - 1] = ']';
7163
7164                     /* This should not be there, but nothing is perfect */
7165                     if (r_len > 9) {
7166                         cmp = strcmp(&r_spec[1], "000000.");
7167                         if (cmp == 0) {
7168                             r_spec += 7;
7169                             r_spec[7] = '[';
7170                             r_len -= 7;
7171                             if (r_len == 2)
7172                                 r_len = 0;
7173                         }
7174                     }
7175                     if (r_len > 0) {
7176                         strncpy(vmsptr, r_spec, r_len);
7177                         vmsptr += r_len;
7178                         vmslen += r_len;
7179                         vmsptr[0] = '\0';
7180                     }
7181                 }
7182                 /* Bring over the directory. */
7183                 if ((d_len > 0) &&
7184                     ((d_len + vmslen) < vmspath_len)) {
7185                     d_spec[0] = '[';
7186                     d_spec[d_len - 1] = ']';
7187                     if (d_len > 9) {
7188                         cmp = strcmp(&d_spec[1], "000000.");
7189                         if (cmp == 0) {
7190                             d_spec += 7;
7191                             d_spec[7] = '[';
7192                             d_len -= 7;
7193                             if (d_len == 2)
7194                                 d_len = 0;
7195                         }
7196                     }
7197
7198                     if (r_len > 0) {
7199                         /* Remove the redundant root */
7200                         if (r_len > 0) {
7201                             /* remove the ][ */
7202                             vmsptr--;
7203                             vmslen--;
7204                             d_spec++;
7205                             d_len--;
7206                         }
7207                         strncpy(vmsptr, d_spec, d_len);
7208                             vmsptr += d_len;
7209                             vmslen += d_len;
7210                             vmsptr[0] = '\0';
7211                     }
7212                 }
7213                 break;
7214             }
7215         }
7216
7217         PerlMem_free(esa);
7218         PerlMem_free(trn);
7219     }
7220
7221     if (lastslash > unixptr) {
7222     int dotdir_seen;
7223
7224       /* skip leading ./ */
7225       dotdir_seen = 0;
7226       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7227         dotdir_seen = 1;
7228         unixptr++;
7229         unixptr++;
7230       }
7231
7232       /* Are we still in a directory? */
7233       if (unixptr <= lastslash) {
7234         *vmsptr++ = '[';
7235         vmslen = 1;
7236         dir_start = 1;
7237
7238         /* if not backing up, then it is relative forward. */
7239         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7240               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7241           *vmsptr++ = '.';
7242           vmslen++;
7243           dir_dot = 1;
7244           }
7245        }
7246        else {
7247          if (dotdir_seen) {
7248            /* Perl wants an empty directory here to tell the difference
7249             * between a DCL commmand and a filename
7250             */
7251           *vmsptr++ = '[';
7252           *vmsptr++ = ']';
7253           vmslen = 2;
7254         }
7255       }
7256     }
7257     else {
7258       /* Handle two special files . and .. */
7259       if (unixptr[0] == '.') {
7260         if (&unixptr[1] == unixend) {
7261           *vmsptr++ = '[';
7262           *vmsptr++ = ']';
7263           vmslen += 2;
7264           *vmsptr++ = '\0';
7265           return SS$_NORMAL;
7266         }
7267         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7268           *vmsptr++ = '[';
7269           *vmsptr++ = '-';
7270           *vmsptr++ = ']';
7271           vmslen += 3;
7272           *vmsptr++ = '\0';
7273           return SS$_NORMAL;
7274         }
7275       }
7276     }
7277   }
7278   else {        /* Absolute PATH handling */
7279   int sts;
7280   char * nextslash;
7281   int seg_len;
7282     /* Need to find out where root is */
7283
7284     /* In theory, this procedure should never get an absolute POSIX pathname
7285      * that can not be found on the POSIX root.
7286      * In practice, that can not be relied on, and things will show up
7287      * here that are a VMS device name or concealed logical name instead.
7288      * So to make things work, this procedure must be tolerant.
7289      */
7290     esa = PerlMem_malloc(vmspath_len);
7291     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7292
7293     sts = SS$_NORMAL;
7294     nextslash = strchr(&unixptr[1],'/');
7295     seg_len = 0;
7296     if (nextslash != NULL) {
7297     int cmp;
7298       seg_len = nextslash - &unixptr[1];
7299       strncpy(vmspath, unixptr, seg_len + 1);
7300       vmspath[seg_len+1] = 0;
7301       cmp = 1;
7302       if (seg_len == 3) {
7303         cmp = strncmp(vmspath, "dev", 4);
7304         if (cmp == 0) {
7305             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7306             if (sts = SS$_NORMAL)
7307                 return SS$_NORMAL;
7308         }
7309       }
7310       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
7311     }
7312
7313     if ($VMS_STATUS_SUCCESS(sts)) {
7314       /* This is verified to be a real path */
7315
7316       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7317       if ($VMS_STATUS_SUCCESS(sts)) {
7318         strcpy(vmspath, esa);
7319         vmslen = strlen(vmspath);
7320         vmsptr = vmspath + vmslen;
7321         unixptr++;
7322         if (unixptr < lastslash) {
7323         char * rptr;
7324           vmsptr--;
7325           *vmsptr++ = '.';
7326           dir_start = 1;
7327           dir_dot = 1;
7328           if (vmslen > 7) {
7329           int cmp;
7330             rptr = vmsptr - 7;
7331             cmp = strcmp(rptr,"000000.");
7332             if (cmp == 0) {
7333               vmslen -= 7;
7334               vmsptr -= 7;
7335               vmsptr[1] = '\0';
7336             } /* removing 6 zeros */
7337           } /* vmslen < 7, no 6 zeros possible */
7338         } /* Not in a directory */
7339       } /* Posix root found */
7340       else {
7341         /* No posix root, fall back to default directory */
7342         strcpy(vmspath, "SYS$DISK:[");
7343         vmsptr = &vmspath[10];
7344         vmslen = 10;
7345         if (unixptr > lastslash) {
7346            *vmsptr = ']';
7347            vmsptr++;
7348            vmslen++;
7349         }
7350         else {
7351            dir_start = 1;
7352         }
7353       }
7354     } /* end of verified real path handling */
7355     else {
7356     int add_6zero;
7357     int islnm;
7358
7359       /* Ok, we have a device or a concealed root that is not in POSIX
7360        * or we have garbage.  Make the best of it.
7361        */
7362
7363       /* Posix to VMS destroyed this, so copy it again */
7364       strncpy(vmspath, &unixptr[1], seg_len);
7365       vmspath[seg_len] = 0;
7366       vmslen = seg_len;
7367       vmsptr = &vmsptr[vmslen];
7368       islnm = 0;
7369
7370       /* Now do we need to add the fake 6 zero directory to it? */
7371       add_6zero = 1;
7372       if ((*lastslash == '/') && (nextslash < lastslash)) {
7373         /* No there is another directory */
7374         add_6zero = 0;
7375       }
7376       else {
7377       int trnend;
7378       int cmp;
7379
7380         /* now we have foo:bar or foo:[000000]bar to decide from */
7381         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
7382
7383         if (!islnm && !decc_posix_compliant_pathnames) {
7384
7385             cmp = strncmp("bin", vmspath, 4);
7386             if (cmp == 0) {
7387                 /* bin => SYS$SYSTEM: */
7388                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7389             }
7390             else {
7391                 /* tmp => SYS$SCRATCH: */
7392                 cmp = strncmp("tmp", vmspath, 4);
7393                 if (cmp == 0) {
7394                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
7395                 }
7396             }
7397         }
7398
7399         trnend = islnm ? islnm - 1 : 0;
7400
7401         /* if this was a logical name, ']' or '>' must be present */
7402         /* if not a logical name, then assume a device and hope. */
7403         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
7404
7405         /* if log name and trailing '.' then rooted - treat as device */
7406         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
7407
7408         /* Fix me, if not a logical name, a device lookup should be
7409          * done to see if the device is file structured.  If the device
7410          * is not file structured, the 6 zeros should not be put on.
7411          *
7412          * As it is, perl is occasionally looking for dev:[000000]tty.
7413          * which looks a little strange.
7414          *
7415          * Not that easy to detect as "/dev" may be file structured with
7416          * special device files.
7417          */
7418
7419         if ((add_6zero == 0) && (*nextslash == '/') &&
7420             (&nextslash[1] == unixend)) {
7421           /* No real directory present */
7422           add_6zero = 1;
7423         }
7424       }
7425
7426       /* Put the device delimiter on */
7427       *vmsptr++ = ':';
7428       vmslen++;
7429       unixptr = nextslash;
7430       unixptr++;
7431
7432       /* Start directory if needed */
7433       if (!islnm || add_6zero) {
7434         *vmsptr++ = '[';
7435         vmslen++;
7436         dir_start = 1;
7437       }
7438
7439       /* add fake 000000] if needed */
7440       if (add_6zero) {
7441         *vmsptr++ = '0';
7442         *vmsptr++ = '0';
7443         *vmsptr++ = '0';
7444         *vmsptr++ = '0';
7445         *vmsptr++ = '0';
7446         *vmsptr++ = '0';
7447         *vmsptr++ = ']';
7448         vmslen += 7;
7449         dir_start = 0;
7450       }
7451
7452     } /* non-POSIX translation */
7453     PerlMem_free(esa);
7454   } /* End of relative/absolute path handling */
7455
7456   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
7457   int dash_flag;
7458   int in_cnt;
7459   int out_cnt;
7460
7461     dash_flag = 0;
7462
7463     if (dir_start != 0) {
7464
7465       /* First characters in a directory are handled special */
7466       while ((*unixptr == '/') ||
7467              ((*unixptr == '.') &&
7468               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
7469                 (&unixptr[1]==unixend)))) {
7470       int loop_flag;
7471
7472         loop_flag = 0;
7473
7474         /* Skip redundant / in specification */
7475         while ((*unixptr == '/') && (dir_start != 0)) {
7476           loop_flag = 1;
7477           unixptr++;
7478           if (unixptr == lastslash)
7479             break;
7480         }
7481         if (unixptr == lastslash)
7482           break;
7483
7484         /* Skip redundant ./ characters */
7485         while ((*unixptr == '.') &&
7486                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
7487           loop_flag = 1;
7488           unixptr++;
7489           if (unixptr == lastslash)
7490             break;
7491           if (*unixptr == '/')
7492             unixptr++;
7493         }
7494         if (unixptr == lastslash)
7495           break;
7496
7497         /* Skip redundant ../ characters */
7498         while ((*unixptr == '.') && (unixptr[1] == '.') &&
7499              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
7500           /* Set the backing up flag */
7501           loop_flag = 1;
7502           dir_dot = 0;
7503           dash_flag = 1;
7504           *vmsptr++ = '-';
7505           vmslen++;
7506           unixptr++; /* first . */
7507           unixptr++; /* second . */
7508           if (unixptr == lastslash)
7509             break;
7510           if (*unixptr == '/') /* The slash */
7511             unixptr++;
7512         }
7513         if (unixptr == lastslash)
7514           break;
7515
7516         /* To do: Perl expects /.../ to be translated to [...] on VMS */
7517         /* Not needed when VMS is pretending to be UNIX. */
7518
7519         /* Is this loop stuck because of too many dots? */
7520         if (loop_flag == 0) {
7521           /* Exit the loop and pass the rest through */
7522           break;
7523         }
7524       }
7525
7526       /* Are we done with directories yet? */
7527       if (unixptr >= lastslash) {
7528
7529         /* Watch out for trailing dots */
7530         if (dir_dot != 0) {
7531             vmslen --;
7532             vmsptr--;
7533         }
7534         *vmsptr++ = ']';
7535         vmslen++;
7536         dash_flag = 0;
7537         dir_start = 0;
7538         if (*unixptr == '/')
7539           unixptr++;
7540       }
7541       else {
7542         /* Have we stopped backing up? */
7543         if (dash_flag) {
7544           *vmsptr++ = '.';
7545           vmslen++;
7546           dash_flag = 0;
7547           /* dir_start continues to be = 1 */
7548         }
7549         if (*unixptr == '-') {
7550           *vmsptr++ = '^';
7551           *vmsptr++ = *unixptr++;
7552           vmslen += 2;
7553           dir_start = 0;
7554
7555           /* Now are we done with directories yet? */
7556           if (unixptr >= lastslash) {
7557
7558             /* Watch out for trailing dots */
7559             if (dir_dot != 0) {
7560               vmslen --;
7561               vmsptr--;
7562             }
7563
7564             *vmsptr++ = ']';
7565             vmslen++;
7566             dash_flag = 0;
7567             dir_start = 0;
7568           }
7569         }
7570       }
7571     }
7572
7573     /* All done? */
7574     if (unixptr >= unixend)
7575       break;
7576
7577     /* Normal characters - More EFS work probably needed */
7578     dir_start = 0;
7579     dir_dot = 0;
7580
7581     switch(*unixptr) {
7582     case '/':
7583         /* remove multiple / */
7584         while (unixptr[1] == '/') {
7585            unixptr++;
7586         }
7587         if (unixptr == lastslash) {
7588           /* Watch out for trailing dots */
7589           if (dir_dot != 0) {
7590             vmslen --;
7591             vmsptr--;
7592           }
7593           *vmsptr++ = ']';
7594         }
7595         else {
7596           dir_start = 1;
7597           *vmsptr++ = '.';
7598           dir_dot = 1;
7599
7600           /* To do: Perl expects /.../ to be translated to [...] on VMS */
7601           /* Not needed when VMS is pretending to be UNIX. */
7602
7603         }
7604         dash_flag = 0;
7605         if (unixptr != unixend)
7606           unixptr++;
7607         vmslen++;
7608         break;
7609     case '.':
7610         if ((unixptr < lastdot) || (unixptr < lastslash) ||
7611             (&unixptr[1] == unixend)) {
7612           *vmsptr++ = '^';
7613           *vmsptr++ = '.';
7614           vmslen += 2;
7615           unixptr++;
7616
7617           /* trailing dot ==> '^..' on VMS */
7618           if (unixptr == unixend) {
7619             *vmsptr++ = '.';
7620             vmslen++;
7621             unixptr++;
7622           }
7623           break;
7624         }
7625
7626         *vmsptr++ = *unixptr++;
7627         vmslen ++;
7628         break;
7629     case '"':
7630         if (quoted && (&unixptr[1] == unixend)) {
7631             unixptr++;
7632             break;
7633         }
7634         in_cnt = copy_expand_unix_filename_escape
7635                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7636         vmsptr += out_cnt;
7637         unixptr += in_cnt;
7638         break;
7639     case '~':
7640     case ';':
7641     case '\\':
7642     case '?':
7643     case ' ':
7644     default:
7645         in_cnt = copy_expand_unix_filename_escape
7646                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7647         vmsptr += out_cnt;
7648         unixptr += in_cnt;
7649         break;
7650     }
7651   }
7652
7653   /* Make sure directory is closed */
7654   if (unixptr == lastslash) {
7655     char *vmsptr2;
7656     vmsptr2 = vmsptr - 1;
7657
7658     if (*vmsptr2 != ']') {
7659       *vmsptr2--;
7660
7661       /* directories do not end in a dot bracket */
7662       if (*vmsptr2 == '.') {
7663         vmsptr2--;
7664
7665         /* ^. is allowed */
7666         if (*vmsptr2 != '^') {
7667           vmsptr--; /* back up over the dot */
7668         }
7669       }
7670       *vmsptr++ = ']';
7671     }
7672   }
7673   else {
7674     char *vmsptr2;
7675     /* Add a trailing dot if a file with no extension */
7676     vmsptr2 = vmsptr - 1;
7677     if ((vmslen > 1) &&
7678         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
7679         (*vmsptr2 != ')') && (*lastdot != '.')) {
7680         *vmsptr++ = '.';
7681         vmslen++;
7682     }
7683   }
7684
7685   *vmsptr = '\0';
7686   return SS$_NORMAL;
7687 }
7688 #endif
7689
7690  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
7691 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
7692 {
7693 char * result;
7694 int utf8_flag;
7695
7696    /* If a UTF8 flag is being passed, honor it */
7697    utf8_flag = 0;
7698    if (utf8_fl != NULL) {
7699      utf8_flag = *utf8_fl;
7700     *utf8_fl = 0;
7701    }
7702
7703    if (utf8_flag) {
7704      /* If there is a possibility of UTF8, then if any UTF8 characters
7705         are present, then they must be converted to VTF-7
7706       */
7707      result = strcpy(rslt, path); /* FIX-ME */
7708    }
7709    else
7710      result = strcpy(rslt, path);
7711
7712    return result;
7713 }
7714
7715
7716 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
7717 static char *mp_do_tovmsspec
7718    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
7719   static char __tovmsspec_retbuf[VMS_MAXRSS];
7720   char *rslt, *dirend;
7721   char *lastdot;
7722   char *vms_delim;
7723   register char *cp1;
7724   const char *cp2;
7725   unsigned long int infront = 0, hasdir = 1;
7726   int rslt_len;
7727   int no_type_seen;
7728   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7729   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7730
7731   if (path == NULL) return NULL;
7732   rslt_len = VMS_MAXRSS-1;
7733   if (buf) rslt = buf;
7734   else if (ts) Newx(rslt, VMS_MAXRSS, char);
7735   else rslt = __tovmsspec_retbuf;
7736
7737   /* '.' and '..' are "[]" and "[-]" for a quick check */
7738   if (path[0] == '.') {
7739     if (path[1] == '\0') {
7740       strcpy(rslt,"[]");
7741       if (utf8_flag != NULL)
7742         *utf8_flag = 0;
7743       return rslt;
7744     }
7745     else {
7746       if (path[1] == '.' && path[2] == '\0') {
7747         strcpy(rslt,"[-]");
7748         if (utf8_flag != NULL)
7749            *utf8_flag = 0;
7750         return rslt;
7751       }
7752     }
7753   }
7754
7755    /* Posix specifications are now a native VMS format */
7756   /*--------------------------------------------------*/
7757 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7758   if (decc_posix_compliant_pathnames) {
7759     if (strncmp(path,"\"^UP^",5) == 0) {
7760       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7761       return rslt;
7762     }
7763   }
7764 #endif
7765
7766   /* This is really the only way to see if this is already in VMS format */
7767   sts = vms_split_path
7768        (path,
7769         &v_spec,
7770         &v_len,
7771         &r_spec,
7772         &r_len,
7773         &d_spec,
7774         &d_len,
7775         &n_spec,
7776         &n_len,
7777         &e_spec,
7778         &e_len,
7779         &vs_spec,
7780         &vs_len);
7781   if (sts == 0) {
7782     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
7783        replacement, because the above parse just took care of most of
7784        what is needed to do vmspath when the specification is already
7785        in VMS format.
7786
7787        And if it is not already, it is easier to do the conversion as
7788        part of this routine than to call this routine and then work on
7789        the result.
7790      */
7791
7792     /* If VMS punctuation was found, it is already VMS format */
7793     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
7794       if (utf8_flag != NULL)
7795         *utf8_flag = 0;
7796       strcpy(rslt, path);
7797       return rslt;
7798     }
7799     /* Now, what to do with trailing "." cases where there is no
7800        extension?  If this is a UNIX specification, and EFS characters
7801        are enabled, then the trailing "." should be converted to a "^.".
7802        But if this was already a VMS specification, then it should be
7803        left alone.
7804
7805        So in the case of ambiguity, leave the specification alone.
7806      */
7807
7808
7809     /* If there is a possibility of UTF8, then if any UTF8 characters
7810         are present, then they must be converted to VTF-7
7811      */
7812     if (utf8_flag != NULL)
7813       *utf8_flag = 0;
7814     strcpy(rslt, path);
7815     return rslt;
7816   }
7817
7818   dirend = strrchr(path,'/');
7819
7820   if (dirend == NULL) {
7821      /* If we get here with no UNIX directory delimiters, then this is
7822         not a complete file specification, either garbage a UNIX glob
7823         specification that can not be converted to a VMS wildcard, or
7824         it a UNIX shell macro.  MakeMaker wants these passed through AS-IS,
7825         so apparently other programs expect this also.
7826
7827         utf8 flag setting needs to be preserved.
7828       */
7829       strcpy(rslt, path);
7830       return rslt;
7831   }
7832
7833 /* If POSIX mode active, handle the conversion */
7834 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7835   if (decc_efs_charset) {
7836     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7837     return rslt;
7838   }
7839 #endif
7840
7841   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
7842     if (!*(dirend+2)) dirend +=2;
7843     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7844     if (decc_efs_charset == 0) {
7845       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7846     }
7847   }
7848
7849   cp1 = rslt;
7850   cp2 = path;
7851   lastdot = strrchr(cp2,'.');
7852   if (*cp2 == '/') {
7853     char *trndev;
7854     int islnm, rooted;
7855     STRLEN trnend;
7856
7857     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7858     if (!*(cp2+1)) {
7859       if (decc_disable_posix_root) {
7860         strcpy(rslt,"sys$disk:[000000]");
7861       }
7862       else {
7863         strcpy(rslt,"sys$posix_root:[000000]");
7864       }
7865       if (utf8_flag != NULL)
7866         *utf8_flag = 0;
7867       return rslt;
7868     }
7869     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7870     *cp1 = '\0';
7871     trndev = PerlMem_malloc(VMS_MAXRSS);
7872     if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7873     islnm =  my_trnlnm(rslt,trndev,0);
7874
7875      /* DECC special handling */
7876     if (!islnm) {
7877       if (strcmp(rslt,"bin") == 0) {
7878         strcpy(rslt,"sys$system");
7879         cp1 = rslt + 10;
7880         *cp1 = 0;
7881         islnm =  my_trnlnm(rslt,trndev,0);
7882       }
7883       else if (strcmp(rslt,"tmp") == 0) {
7884         strcpy(rslt,"sys$scratch");
7885         cp1 = rslt + 11;
7886         *cp1 = 0;
7887         islnm =  my_trnlnm(rslt,trndev,0);
7888       }
7889       else if (!decc_disable_posix_root) {
7890         strcpy(rslt, "sys$posix_root");
7891         cp1 = rslt + 13;
7892         *cp1 = 0;
7893         cp2 = path;
7894         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7895         islnm =  my_trnlnm(rslt,trndev,0);
7896       }
7897       else if (strcmp(rslt,"dev") == 0) {
7898         if (strncmp(cp2,"/null", 5) == 0) {
7899           if ((cp2[5] == 0) || (cp2[5] == '/')) {
7900             strcpy(rslt,"NLA0");
7901             cp1 = rslt + 4;
7902             *cp1 = 0;
7903             cp2 = cp2 + 5;
7904             islnm =  my_trnlnm(rslt,trndev,0);
7905           }
7906         }
7907       }
7908     }
7909
7910     trnend = islnm ? strlen(trndev) - 1 : 0;
7911     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
7912     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
7913     /* If the first element of the path is a logical name, determine
7914      * whether it has to be translated so we can add more directories. */
7915     if (!islnm || rooted) {
7916       *(cp1++) = ':';
7917       *(cp1++) = '[';
7918       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
7919       else cp2++;
7920     }
7921     else {
7922       if (cp2 != dirend) {
7923         strcpy(rslt,trndev);
7924         cp1 = rslt + trnend;
7925         if (*cp2 != 0) {
7926           *(cp1++) = '.';
7927           cp2++;
7928         }
7929       }
7930       else {
7931         if (decc_disable_posix_root) {
7932           *(cp1++) = ':';
7933           hasdir = 0;
7934         }
7935       }
7936     }
7937     PerlMem_free(trndev);
7938   }
7939   else {
7940     *(cp1++) = '[';
7941     if (*cp2 == '.') {
7942       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
7943         cp2 += 2;         /* skip over "./" - it's redundant */
7944         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
7945       }
7946       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7947         *(cp1++) = '-';                                 /* "../" --> "-" */
7948         cp2 += 3;
7949       }
7950       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
7951                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
7952         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7953         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
7954         cp2 += 4;
7955       }
7956       else if ((cp2 != lastdot) || (lastdot < dirend)) {
7957         /* Escape the extra dots in EFS file specifications */
7958         *(cp1++) = '^';
7959       }
7960       if (cp2 > dirend) cp2 = dirend;
7961     }
7962     else *(cp1++) = '.';
7963   }
7964   for (; cp2 < dirend; cp2++) {
7965     if (*cp2 == '/') {
7966       if (*(cp2-1) == '/') continue;
7967       if (*(cp1-1) != '.') *(cp1++) = '.';
7968       infront = 0;
7969     }
7970     else if (!infront && *cp2 == '.') {
7971       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
7972       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
7973       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7974         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
7975         else if (*(cp1-2) == '[') *(cp1-1) = '-';
7976         else {  /* back up over previous directory name */
7977           cp1--;
7978           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
7979           if (*(cp1-1) == '[') {
7980             memcpy(cp1,"000000.",7);
7981             cp1 += 7;
7982           }
7983         }
7984         cp2 += 2;
7985         if (cp2 == dirend) break;
7986       }
7987       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
7988                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
7989         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
7990         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7991         if (!*(cp2+3)) {
7992           *(cp1++) = '.';  /* Simulate trailing '/' */
7993           cp2 += 2;  /* for loop will incr this to == dirend */
7994         }
7995         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
7996       }
7997       else {
7998         if (decc_efs_charset == 0)
7999           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8000         else {
8001           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
8002           *(cp1++) = '.';
8003         }
8004       }
8005     }
8006     else {
8007       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
8008       if (*cp2 == '.') {
8009         if (decc_efs_charset == 0)
8010           *(cp1++) = '_';
8011         else {
8012           *(cp1++) = '^';
8013           *(cp1++) = '.';
8014         }
8015       }
8016       else                  *(cp1++) =  *cp2;
8017       infront = 1;
8018     }
8019   }
8020   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8021   if (hasdir) *(cp1++) = ']';
8022   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
8023   /* fixme for ODS5 */
8024   no_type_seen = 0;
8025   if (cp2 > lastdot)
8026     no_type_seen = 1;
8027   while (*cp2) {
8028     switch(*cp2) {
8029     case '?':
8030         if (decc_efs_charset == 0)
8031           *(cp1++) = '%';
8032         else
8033           *(cp1++) = '?';
8034         cp2++;
8035     case ' ':
8036         *(cp1)++ = '^';
8037         *(cp1)++ = '_';
8038         cp2++;
8039         break;
8040     case '.':
8041         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8042             decc_readdir_dropdotnotype) {
8043           *(cp1)++ = '^';
8044           *(cp1)++ = '.';
8045           cp2++;
8046
8047           /* trailing dot ==> '^..' on VMS */
8048           if (*cp2 == '\0') {
8049             *(cp1++) = '.';
8050             no_type_seen = 0;
8051           }
8052         }
8053         else {
8054           *(cp1++) = *(cp2++);
8055           no_type_seen = 0;
8056         }
8057         break;
8058     case '$':
8059          /* This could be a macro to be passed through */
8060         *(cp1++) = *(cp2++);
8061         if (*cp2 == '(') {
8062         const char * save_cp2;
8063         char * save_cp1;
8064         int is_macro;
8065
8066             /* paranoid check */
8067             save_cp2 = cp2;
8068             save_cp1 = cp1;
8069             is_macro = 0;
8070
8071             /* Test through */
8072             *(cp1++) = *(cp2++);
8073             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8074                 *(cp1++) = *(cp2++);
8075                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8076                     *(cp1++) = *(cp2++);
8077                 }
8078                 if (*cp2 == ')') {
8079                     *(cp1++) = *(cp2++);
8080                     is_macro = 1;
8081                 }
8082             }
8083             if (is_macro == 0) {
8084                 /* Not really a macro - never mind */
8085                 cp2 = save_cp2;
8086                 cp1 = save_cp1;
8087             }
8088         }
8089         break;
8090     case '\"':
8091     case '~':
8092     case '`':
8093     case '!':
8094     case '#':
8095     case '%':
8096     case '^':
8097         /* Don't escape again if following character is
8098          * already something we escape.
8099          */
8100         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8101             *(cp1++) = *(cp2++);
8102             break;
8103         }
8104         /* But otherwise fall through and escape it. */
8105     case '&':
8106     case '(':
8107     case ')':
8108     case '=':
8109     case '+':
8110     case '\'':
8111     case '@':
8112     case '[':
8113     case ']':
8114     case '{':
8115     case '}':
8116     case ':':
8117     case '\\':
8118     case '|':
8119     case '<':
8120     case '>':
8121         *(cp1++) = '^';
8122         *(cp1++) = *(cp2++);
8123         break;
8124     case ';':
8125         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8126          * which is wrong.  UNIX notation should be ".dir." unless
8127          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8128          * changing this behavior could break more things at this time.
8129          * efs character set effectively does not allow "." to be a version
8130          * delimiter as a further complication about changing this.
8131          */
8132         if (decc_filename_unix_report != 0) {
8133           *(cp1++) = '^';
8134         }
8135         *(cp1++) = *(cp2++);
8136         break;
8137     default:
8138         *(cp1++) = *(cp2++);
8139     }
8140   }
8141   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8142   char *lcp1;
8143     lcp1 = cp1;
8144     lcp1--;
8145      /* Fix me for "^]", but that requires making sure that you do
8146       * not back up past the start of the filename
8147       */
8148     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8149       *cp1++ = '.';
8150   }
8151   *cp1 = '\0';
8152
8153   if (utf8_flag != NULL)
8154     *utf8_flag = 0;
8155   return rslt;
8156
8157 }  /* end of do_tovmsspec() */
8158 /*}}}*/
8159 /* External entry points */
8160 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8161   { return do_tovmsspec(path,buf,0,NULL); }
8162 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8163   { return do_tovmsspec(path,buf,1,NULL); }
8164 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8165   { return do_tovmsspec(path,buf,0,utf8_fl); }
8166 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8167   { return do_tovmsspec(path,buf,1,utf8_fl); }
8168
8169 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8170 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8171   static char __tovmspath_retbuf[VMS_MAXRSS];
8172   int vmslen;
8173   char *pathified, *vmsified, *cp;
8174
8175   if (path == NULL) return NULL;
8176   pathified = PerlMem_malloc(VMS_MAXRSS);
8177   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8178   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
8179     PerlMem_free(pathified);
8180     return NULL;
8181   }
8182
8183   vmsified = NULL;
8184   if (buf == NULL)
8185      Newx(vmsified, VMS_MAXRSS, char);
8186   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8187     PerlMem_free(pathified);
8188     if (vmsified) Safefree(vmsified);
8189     return NULL;
8190   }
8191   PerlMem_free(pathified);
8192   if (buf) {
8193     return buf;
8194   }
8195   else if (ts) {
8196     vmslen = strlen(vmsified);
8197     Newx(cp,vmslen+1,char);
8198     memcpy(cp,vmsified,vmslen);
8199     cp[vmslen] = '\0';
8200     Safefree(vmsified);
8201     return cp;
8202   }
8203   else {
8204     strcpy(__tovmspath_retbuf,vmsified);
8205     Safefree(vmsified);
8206     return __tovmspath_retbuf;
8207   }
8208
8209 }  /* end of do_tovmspath() */
8210 /*}}}*/
8211 /* External entry points */
8212 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8213   { return do_tovmspath(path,buf,0, NULL); }
8214 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8215   { return do_tovmspath(path,buf,1, NULL); }
8216 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8217   { return do_tovmspath(path,buf,0,utf8_fl); }
8218 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8219   { return do_tovmspath(path,buf,1,utf8_fl); }
8220
8221
8222 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8223 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8224   static char __tounixpath_retbuf[VMS_MAXRSS];
8225   int unixlen;
8226   char *pathified, *unixified, *cp;
8227
8228   if (path == NULL) return NULL;
8229   pathified = PerlMem_malloc(VMS_MAXRSS);
8230   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8231   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
8232     PerlMem_free(pathified);
8233     return NULL;
8234   }
8235
8236   unixified = NULL;
8237   if (buf == NULL) {
8238       Newx(unixified, VMS_MAXRSS, char);
8239   }
8240   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
8241     PerlMem_free(pathified);
8242     if (unixified) Safefree(unixified);
8243     return NULL;
8244   }
8245   PerlMem_free(pathified);
8246   if (buf) {
8247     return buf;
8248   }
8249   else if (ts) {
8250     unixlen = strlen(unixified);
8251     Newx(cp,unixlen+1,char);
8252     memcpy(cp,unixified,unixlen);
8253     cp[unixlen] = '\0';
8254     Safefree(unixified);
8255     return cp;
8256   }
8257   else {
8258     strcpy(__tounixpath_retbuf,unixified);
8259     Safefree(unixified);
8260     return __tounixpath_retbuf;
8261   }
8262
8263 }  /* end of do_tounixpath() */
8264 /*}}}*/
8265 /* External entry points */
8266 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8267   { return do_tounixpath(path,buf,0,NULL); }
8268 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8269   { return do_tounixpath(path,buf,1,NULL); }
8270 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8271   { return do_tounixpath(path,buf,0,utf8_fl); }
8272 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8273   { return do_tounixpath(path,buf,1,utf8_fl); }
8274
8275 /*
8276  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
8277  *
8278  *****************************************************************************
8279  *                                                                           *
8280  *  Copyright (C) 1989-1994, 2007 by                                         *
8281  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
8282  *                                                                           *
8283  *  Permission is hereby granted for the reproduction of this software       *
8284  *  on condition that this copyright notice is included in source            *
8285  *  distributions of the software.  The code may be modified and             *
8286  *  distributed under the same terms as Perl itself.                         *
8287  *                                                                           *
8288  *  27-Aug-1994 Modified for inclusion in perl5                              *
8289  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
8290  *****************************************************************************
8291  */
8292
8293 /*
8294  * getredirection() is intended to aid in porting C programs
8295  * to VMS (Vax-11 C).  The native VMS environment does not support
8296  * '>' and '<' I/O redirection, or command line wild card expansion,
8297  * or a command line pipe mechanism using the '|' AND background
8298  * command execution '&'.  All of these capabilities are provided to any
8299  * C program which calls this procedure as the first thing in the
8300  * main program.
8301  * The piping mechanism will probably work with almost any 'filter' type
8302  * of program.  With suitable modification, it may useful for other
8303  * portability problems as well.
8304  *
8305  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
8306  */
8307 struct list_item
8308     {
8309     struct list_item *next;
8310     char *value;
8311     };
8312
8313 static void add_item(struct list_item **head,
8314                      struct list_item **tail,
8315                      char *value,
8316                      int *count);
8317
8318 static void mp_expand_wild_cards(pTHX_ char *item,
8319                                 struct list_item **head,
8320                                 struct list_item **tail,
8321                                 int *count);
8322
8323 static int background_process(pTHX_ int argc, char **argv);
8324
8325 static void pipe_and_fork(pTHX_ char **cmargv);
8326
8327 /*{{{ void getredirection(int *ac, char ***av)*/
8328 static void
8329 mp_getredirection(pTHX_ int *ac, char ***av)
8330 /*
8331  * Process vms redirection arg's.  Exit if any error is seen.
8332  * If getredirection() processes an argument, it is erased
8333  * from the vector.  getredirection() returns a new argc and argv value.
8334  * In the event that a background command is requested (by a trailing "&"),
8335  * this routine creates a background subprocess, and simply exits the program.
8336  *
8337  * Warning: do not try to simplify the code for vms.  The code
8338  * presupposes that getredirection() is called before any data is
8339  * read from stdin or written to stdout.
8340  *
8341  * Normal usage is as follows:
8342  *
8343  *      main(argc, argv)
8344  *      int             argc;
8345  *      char            *argv[];
8346  *      {
8347  *              getredirection(&argc, &argv);
8348  *      }
8349  */
8350 {
8351     int                 argc = *ac;     /* Argument Count         */
8352     char                **argv = *av;   /* Argument Vector        */
8353     char                *ap;            /* Argument pointer       */
8354     int                 j;              /* argv[] index           */
8355     int                 item_count = 0; /* Count of Items in List */
8356     struct list_item    *list_head = 0; /* First Item in List       */
8357     struct list_item    *list_tail;     /* Last Item in List        */
8358     char                *in = NULL;     /* Input File Name          */
8359     char                *out = NULL;    /* Output File Name         */
8360     char                *outmode = "w"; /* Mode to Open Output File */
8361     char                *err = NULL;    /* Error File Name          */
8362     char                *errmode = "w"; /* Mode to Open Error File  */
8363     int                 cmargc = 0;     /* Piped Command Arg Count  */
8364     char                **cmargv = NULL;/* Piped Command Arg Vector */
8365
8366     /*
8367      * First handle the case where the last thing on the line ends with
8368      * a '&'.  This indicates the desire for the command to be run in a
8369      * subprocess, so we satisfy that desire.
8370      */
8371     ap = argv[argc-1];
8372     if (0 == strcmp("&", ap))
8373        exit(background_process(aTHX_ --argc, argv));
8374     if (*ap && '&' == ap[strlen(ap)-1])
8375         {
8376         ap[strlen(ap)-1] = '\0';
8377        exit(background_process(aTHX_ argc, argv));
8378         }
8379     /*
8380      * Now we handle the general redirection cases that involve '>', '>>',
8381      * '<', and pipes '|'.
8382      */
8383     for (j = 0; j < argc; ++j)
8384         {
8385         if (0 == strcmp("<", argv[j]))
8386             {
8387             if (j+1 >= argc)
8388                 {
8389                 fprintf(stderr,"No input file after < on command line");
8390                 exit(LIB$_WRONUMARG);
8391                 }
8392             in = argv[++j];
8393             continue;
8394             }
8395         if ('<' == *(ap = argv[j]))
8396             {
8397             in = 1 + ap;
8398             continue;
8399             }
8400         if (0 == strcmp(">", ap))
8401             {
8402             if (j+1 >= argc)
8403                 {
8404                 fprintf(stderr,"No output file after > on command line");
8405                 exit(LIB$_WRONUMARG);
8406                 }
8407             out = argv[++j];
8408             continue;
8409             }
8410         if ('>' == *ap)
8411             {
8412             if ('>' == ap[1])
8413                 {
8414                 outmode = "a";
8415                 if ('\0' == ap[2])
8416                     out = argv[++j];
8417                 else
8418                     out = 2 + ap;
8419                 }
8420             else
8421                 out = 1 + ap;
8422             if (j >= argc)
8423                 {
8424                 fprintf(stderr,"No output file after > or >> on command line");
8425                 exit(LIB$_WRONUMARG);
8426                 }
8427             continue;
8428             }
8429         if (('2' == *ap) && ('>' == ap[1]))
8430             {
8431             if ('>' == ap[2])
8432                 {
8433                 errmode = "a";
8434                 if ('\0' == ap[3])
8435                     err = argv[++j];
8436                 else
8437                     err = 3 + ap;
8438                 }
8439             else
8440                 if ('\0' == ap[2])
8441                     err = argv[++j];
8442                 else
8443                     err = 2 + ap;
8444             if (j >= argc)
8445                 {
8446                 fprintf(stderr,"No output file after 2> or 2>> on command line");
8447                 exit(LIB$_WRONUMARG);
8448                 }
8449             continue;
8450             }
8451         if (0 == strcmp("|", argv[j]))
8452             {
8453             if (j+1 >= argc)
8454                 {
8455                 fprintf(stderr,"No command into which to pipe on command line");
8456                 exit(LIB$_WRONUMARG);
8457                 }
8458             cmargc = argc-(j+1);
8459             cmargv = &argv[j+1];
8460             argc = j;
8461             continue;
8462             }
8463         if ('|' == *(ap = argv[j]))
8464             {
8465             ++argv[j];
8466             cmargc = argc-j;
8467             cmargv = &argv[j];
8468             argc = j;
8469             continue;
8470             }
8471         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
8472         }
8473     /*
8474      * Allocate and fill in the new argument vector, Some Unix's terminate
8475      * the list with an extra null pointer.
8476      */
8477     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
8478     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8479     *av = argv;
8480     for (j = 0; j < item_count; ++j, list_head = list_head->next)
8481         argv[j] = list_head->value;
8482     *ac = item_count;
8483     if (cmargv != NULL)
8484         {
8485         if (out != NULL)
8486             {
8487             fprintf(stderr,"'|' and '>' may not both be specified on command line");
8488             exit(LIB$_INVARGORD);
8489             }
8490         pipe_and_fork(aTHX_ cmargv);
8491         }
8492
8493     /* Check for input from a pipe (mailbox) */
8494
8495     if (in == NULL && 1 == isapipe(0))
8496         {
8497         char mbxname[L_tmpnam];
8498         long int bufsize;
8499         long int dvi_item = DVI$_DEVBUFSIZ;
8500         $DESCRIPTOR(mbxnam, "");
8501         $DESCRIPTOR(mbxdevnam, "");
8502
8503         /* Input from a pipe, reopen it in binary mode to disable       */
8504         /* carriage control processing.                                 */
8505
8506         fgetname(stdin, mbxname);
8507         mbxnam.dsc$a_pointer = mbxname;
8508         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
8509         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
8510         mbxdevnam.dsc$a_pointer = mbxname;
8511         mbxdevnam.dsc$w_length = sizeof(mbxname);
8512         dvi_item = DVI$_DEVNAM;
8513         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
8514         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
8515         set_errno(0);
8516         set_vaxc_errno(1);
8517         freopen(mbxname, "rb", stdin);
8518         if (errno != 0)
8519             {
8520             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
8521             exit(vaxc$errno);
8522             }
8523         }
8524     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
8525         {
8526         fprintf(stderr,"Can't open input file %s as stdin",in);
8527         exit(vaxc$errno);
8528         }
8529     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
8530         {
8531         fprintf(stderr,"Can't open output file %s as stdout",out);
8532         exit(vaxc$errno);
8533         }
8534         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
8535
8536     if (err != NULL) {
8537         if (strcmp(err,"&1") == 0) {
8538             dup2(fileno(stdout), fileno(stderr));
8539             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
8540         } else {
8541         FILE *tmperr;
8542         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
8543             {
8544             fprintf(stderr,"Can't open error file %s as stderr",err);
8545             exit(vaxc$errno);
8546             }
8547             fclose(tmperr);
8548            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
8549                 {
8550                 exit(vaxc$errno);
8551                 }
8552             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
8553         }
8554         }
8555 #ifdef ARGPROC_DEBUG
8556     PerlIO_printf(Perl_debug_log, "Arglist:\n");
8557     for (j = 0; j < *ac;  ++j)
8558         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
8559 #endif
8560    /* Clear errors we may have hit expanding wildcards, so they don't
8561       show up in Perl's $! later */
8562    set_errno(0); set_vaxc_errno(1);
8563 }  /* end of getredirection() */
8564 /*}}}*/
8565
8566 static void add_item(struct list_item **head,
8567                      struct list_item **tail,
8568                      char *value,
8569                      int *count)
8570 {
8571     if (*head == 0)
8572         {
8573         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8574         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8575         *tail = *head;
8576         }
8577     else {
8578         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8579         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8580         *tail = (*tail)->next;
8581         }
8582     (*tail)->value = value;
8583     ++(*count);
8584 }
8585
8586 static void mp_expand_wild_cards(pTHX_ char *item,
8587                               struct list_item **head,
8588                               struct list_item **tail,
8589                               int *count)
8590 {
8591 int expcount = 0;
8592 unsigned long int context = 0;
8593 int isunix = 0;
8594 int item_len = 0;
8595 char *had_version;
8596 char *had_device;
8597 int had_directory;
8598 char *devdir,*cp;
8599 char *vmsspec;
8600 $DESCRIPTOR(filespec, "");
8601 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
8602 $DESCRIPTOR(resultspec, "");
8603 unsigned long int lff_flags = 0;
8604 int sts;
8605 int rms_sts;
8606
8607 #ifdef VMS_LONGNAME_SUPPORT
8608     lff_flags = LIB$M_FIL_LONG_NAMES;
8609 #endif
8610
8611     for (cp = item; *cp; cp++) {
8612         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
8613         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
8614     }
8615     if (!*cp || isspace(*cp))
8616         {
8617         add_item(head, tail, item, count);
8618         return;
8619         }
8620     else
8621         {
8622      /* "double quoted" wild card expressions pass as is */
8623      /* From DCL that means using e.g.:                  */
8624      /* perl program """perl.*"""                        */
8625      item_len = strlen(item);
8626      if ( '"' == *item && '"' == item[item_len-1] )
8627        {
8628        item++;
8629        item[item_len-2] = '\0';
8630        add_item(head, tail, item, count);
8631        return;
8632        }
8633      }
8634     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
8635     resultspec.dsc$b_class = DSC$K_CLASS_D;
8636     resultspec.dsc$a_pointer = NULL;
8637     vmsspec = PerlMem_malloc(VMS_MAXRSS);
8638     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8639     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
8640       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
8641     if (!isunix || !filespec.dsc$a_pointer)
8642       filespec.dsc$a_pointer = item;
8643     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
8644     /*
8645      * Only return version specs, if the caller specified a version
8646      */
8647     had_version = strchr(item, ';');
8648     /*
8649      * Only return device and directory specs, if the caller specifed either.
8650      */
8651     had_device = strchr(item, ':');
8652     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
8653
8654     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
8655                                  (&filespec, &resultspec, &context,
8656                                   &defaultspec, 0, &rms_sts, &lff_flags)))
8657         {
8658         char *string;
8659         char *c;
8660
8661         string = PerlMem_malloc(resultspec.dsc$w_length+1);
8662         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8663         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
8664         string[resultspec.dsc$w_length] = '\0';
8665         if (NULL == had_version)
8666             *(strrchr(string, ';')) = '\0';
8667         if ((!had_directory) && (had_device == NULL))
8668             {
8669             if (NULL == (devdir = strrchr(string, ']')))
8670                 devdir = strrchr(string, '>');
8671             strcpy(string, devdir + 1);
8672             }
8673         /*
8674          * Be consistent with what the C RTL has already done to the rest of
8675          * the argv items and lowercase all of these names.
8676          */
8677         if (!decc_efs_case_preserve) {
8678             for (c = string; *c; ++c)
8679             if (isupper(*c))
8680                 *c = tolower(*c);
8681         }
8682         if (isunix) trim_unixpath(string,item,1);
8683         add_item(head, tail, string, count);
8684         ++expcount;
8685     }
8686     PerlMem_free(vmsspec);
8687     if (sts != RMS$_NMF)
8688         {
8689         set_vaxc_errno(sts);
8690         switch (sts)
8691             {
8692             case RMS$_FNF: case RMS$_DNF:
8693                 set_errno(ENOENT); break;
8694             case RMS$_DIR:
8695                 set_errno(ENOTDIR); break;
8696             case RMS$_DEV:
8697                 set_errno(ENODEV); break;
8698             case RMS$_FNM: case RMS$_SYN:
8699                 set_errno(EINVAL); break;
8700             case RMS$_PRV:
8701                 set_errno(EACCES); break;
8702             default:
8703                 _ckvmssts_noperl(sts);
8704             }
8705         }
8706     if (expcount == 0)
8707         add_item(head, tail, item, count);
8708     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
8709     _ckvmssts_noperl(lib$find_file_end(&context));
8710 }
8711
8712 static int child_st[2];/* Event Flag set when child process completes   */
8713
8714 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
8715
8716 static unsigned long int exit_handler(int *status)
8717 {
8718 short iosb[4];
8719
8720     if (0 == child_st[0])
8721         {
8722 #ifdef ARGPROC_DEBUG
8723         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
8724 #endif
8725         fflush(stdout);     /* Have to flush pipe for binary data to    */
8726                             /* terminate properly -- <tp@mccall.com>    */
8727         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
8728         sys$dassgn(child_chan);
8729         fclose(stdout);
8730         sys$synch(0, child_st);
8731         }
8732     return(1);
8733 }
8734
8735 static void sig_child(int chan)
8736 {
8737 #ifdef ARGPROC_DEBUG
8738     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
8739 #endif
8740     if (child_st[0] == 0)
8741         child_st[0] = 1;
8742 }
8743
8744 static struct exit_control_block exit_block =
8745     {
8746     0,
8747     exit_handler,
8748     1,
8749     &exit_block.exit_status,
8750     0
8751     };
8752
8753 static void
8754 pipe_and_fork(pTHX_ char **cmargv)
8755 {
8756     PerlIO *fp;
8757     struct dsc$descriptor_s *vmscmd;
8758     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
8759     int sts, j, l, ismcr, quote, tquote = 0;
8760
8761     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
8762     vms_execfree(vmscmd);
8763
8764     j = l = 0;
8765     p = subcmd;
8766     q = cmargv[0];
8767     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
8768               && toupper(*(q+2)) == 'R' && !*(q+3);
8769
8770     while (q && l < MAX_DCL_LINE_LENGTH) {
8771         if (!*q) {
8772             if (j > 0 && quote) {
8773                 *p++ = '"';
8774                 l++;
8775             }
8776             q = cmargv[++j];
8777             if (q) {
8778                 if (ismcr && j > 1) quote = 1;
8779                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
8780                 *p++ = ' ';
8781                 l++;
8782                 if (quote || tquote) {
8783                     *p++ = '"';
8784                     l++;
8785                 }
8786             }
8787         } else {
8788             if ((quote||tquote) && *q == '"') {
8789                 *p++ = '"';
8790                 l++;
8791             }
8792             *p++ = *q++;
8793             l++;
8794         }
8795     }
8796     *p = '\0';
8797
8798     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
8799     if (fp == Nullfp) {
8800         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
8801     }
8802 }
8803
8804 static int background_process(pTHX_ int argc, char **argv)
8805 {
8806 char command[MAX_DCL_SYMBOL + 1] = "$";
8807 $DESCRIPTOR(value, "");
8808 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
8809 static $DESCRIPTOR(null, "NLA0:");
8810 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
8811 char pidstring[80];
8812 $DESCRIPTOR(pidstr, "");
8813 int pid;
8814 unsigned long int flags = 17, one = 1, retsts;
8815 int len;
8816
8817     strcat(command, argv[0]);
8818     len = strlen(command);
8819     while (--argc && (len < MAX_DCL_SYMBOL))
8820         {
8821         strcat(command, " \"");
8822         strcat(command, *(++argv));
8823         strcat(command, "\"");
8824         len = strlen(command);
8825         }
8826     value.dsc$a_pointer = command;
8827     value.dsc$w_length = strlen(value.dsc$a_pointer);
8828     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
8829     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
8830     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
8831         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8832     }
8833     else {
8834         _ckvmssts_noperl(retsts);
8835     }
8836 #ifdef ARGPROC_DEBUG
8837     PerlIO_printf(Perl_debug_log, "%s\n", command);
8838 #endif
8839     sprintf(pidstring, "%08X", pid);
8840     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8841     pidstr.dsc$a_pointer = pidstring;
8842     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8843     lib$set_symbol(&pidsymbol, &pidstr);
8844     return(SS$_NORMAL);
8845 }
8846 /*}}}*/
8847 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8848
8849
8850 /* OS-specific initialization at image activation (not thread startup) */
8851 /* Older VAXC header files lack these constants */
8852 #ifndef JPI$_RIGHTS_SIZE
8853 #  define JPI$_RIGHTS_SIZE 817
8854 #endif
8855 #ifndef KGB$M_SUBSYSTEM
8856 #  define KGB$M_SUBSYSTEM 0x8
8857 #endif
8858
8859 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8860
8861 /*{{{void vms_image_init(int *, char ***)*/
8862 void
8863 vms_image_init(int *argcp, char ***argvp)
8864 {
8865   char eqv[LNM$C_NAMLENGTH+1] = "";
8866   unsigned int len, tabct = 8, tabidx = 0;
8867   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8868   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8869   unsigned short int dummy, rlen;
8870   struct dsc$descriptor_s **tabvec;
8871 #if defined(PERL_IMPLICIT_CONTEXT)
8872   pTHX = NULL;
8873 #endif
8874   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
8875                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
8876                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8877                                  {          0,                0,    0,      0} };
8878
8879 #ifdef KILL_BY_SIGPRC
8880     Perl_csighandler_init();
8881 #endif
8882
8883   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8884   _ckvmssts_noperl(iosb[0]);
8885   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8886     if (iprv[i]) {           /* Running image installed with privs? */
8887       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
8888       will_taint = TRUE;
8889       break;
8890     }
8891   }
8892   /* Rights identifiers might trigger tainting as well. */
8893   if (!will_taint && (rlen || rsz)) {
8894     while (rlen < rsz) {
8895       /* We didn't get all the identifiers on the first pass.  Allocate a
8896        * buffer much larger than $GETJPI wants (rsz is size in bytes that
8897        * were needed to hold all identifiers at time of last call; we'll
8898        * allocate that many unsigned long ints), and go back and get 'em.
8899        * If it gave us less than it wanted to despite ample buffer space,
8900        * something's broken.  Is your system missing a system identifier?
8901        */
8902       if (rsz <= jpilist[1].buflen) {
8903          /* Perl_croak accvios when used this early in startup. */
8904          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
8905                          rsz, (unsigned long) jpilist[1].buflen,
8906                          "Check your rights database for corruption.\n");
8907          exit(SS$_ABORT);
8908       }
8909       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
8910       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
8911       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8912       jpilist[1].buflen = rsz * sizeof(unsigned long int);
8913       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
8914       _ckvmssts_noperl(iosb[0]);
8915     }
8916     mask = jpilist[1].bufadr;
8917     /* Check attribute flags for each identifier (2nd longword); protected
8918      * subsystem identifiers trigger tainting.
8919      */
8920     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
8921       if (mask[i] & KGB$M_SUBSYSTEM) {
8922         will_taint = TRUE;
8923         break;
8924       }
8925     }
8926     if (mask != rlst) PerlMem_free(mask);
8927   }
8928
8929   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
8930    * logical, some versions of the CRTL will add a phanthom /000000/
8931    * directory.  This needs to be removed.
8932    */
8933   if (decc_filename_unix_report) {
8934   char * zeros;
8935   int ulen;
8936     ulen = strlen(argvp[0][0]);
8937     if (ulen > 7) {
8938       zeros = strstr(argvp[0][0], "/000000/");
8939       if (zeros != NULL) {
8940         int mlen;
8941         mlen = ulen - (zeros - argvp[0][0]) - 7;
8942         memmove(zeros, &zeros[7], mlen);
8943         ulen = ulen - 7;
8944         argvp[0][0][ulen] = '\0';
8945       }
8946     }
8947     /* It also may have a trailing dot that needs to be removed otherwise
8948      * it will be converted to VMS mode incorrectly.
8949      */
8950     ulen--;
8951     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
8952       argvp[0][0][ulen] = '\0';
8953   }
8954
8955   /* We need to use this hack to tell Perl it should run with tainting,
8956    * since its tainting flag may be part of the PL_curinterp struct, which
8957    * hasn't been allocated when vms_image_init() is called.
8958    */
8959   if (will_taint) {
8960     char **newargv, **oldargv;
8961     oldargv = *argvp;
8962     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
8963     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8964     newargv[0] = oldargv[0];
8965     newargv[1] = PerlMem_malloc(3 * sizeof(char));
8966     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8967     strcpy(newargv[1], "-T");
8968     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
8969     (*argcp)++;
8970     newargv[*argcp] = NULL;
8971     /* We orphan the old argv, since we don't know where it's come from,
8972      * so we don't know how to free it.
8973      */
8974     *argvp = newargv;
8975   }
8976   else {  /* Did user explicitly request tainting? */
8977     int i;
8978     char *cp, **av = *argvp;
8979     for (i = 1; i < *argcp; i++) {
8980       if (*av[i] != '-') break;
8981       for (cp = av[i]+1; *cp; cp++) {
8982         if (*cp == 'T') { will_taint = 1; break; }
8983         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
8984                   strchr("DFIiMmx",*cp)) break;
8985       }
8986       if (will_taint) break;
8987     }
8988   }
8989
8990   for (tabidx = 0;
8991        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
8992        tabidx++) {
8993     if (!tabidx) {
8994       tabvec = (struct dsc$descriptor_s **)
8995             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
8996       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8997     }
8998     else if (tabidx >= tabct) {
8999       tabct += 8;
9000       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9001       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9002     }
9003     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9004     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9005     tabvec[tabidx]->dsc$w_length  = 0;
9006     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9007     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
9008     tabvec[tabidx]->dsc$a_pointer = NULL;
9009     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9010   }
9011   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9012
9013   getredirection(argcp,argvp);
9014 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9015   {
9016 # include <reentrancy.h>
9017   decc$set_reentrancy(C$C_MULTITHREAD);
9018   }
9019 #endif
9020   return;
9021 }
9022 /*}}}*/
9023
9024
9025 /* trim_unixpath()
9026  * Trim Unix-style prefix off filespec, so it looks like what a shell
9027  * glob expansion would return (i.e. from specified prefix on, not
9028  * full path).  Note that returned filespec is Unix-style, regardless
9029  * of whether input filespec was VMS-style or Unix-style.
9030  *
9031  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9032  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9033  * vector of options; at present, only bit 0 is used, and if set tells
9034  * trim unixpath to try the current default directory as a prefix when
9035  * presented with a possibly ambiguous ... wildcard.
9036  *
9037  * Returns !=0 on success, with trimmed filespec replacing contents of
9038  * fspec, and 0 on failure, with contents of fpsec unchanged.
9039  */
9040 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9041 int
9042 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9043 {
9044   char *unixified, *unixwild,
9045        *template, *base, *end, *cp1, *cp2;
9046   register int tmplen, reslen = 0, dirs = 0;
9047
9048   unixwild = PerlMem_malloc(VMS_MAXRSS);
9049   if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
9050   if (!wildspec || !fspec) return 0;
9051   template = unixwild;
9052   if (strpbrk(wildspec,"]>:") != NULL) {
9053     if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
9054         PerlMem_free(unixwild);
9055         return 0;
9056     }
9057   }
9058   else {
9059     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
9060     unixwild[VMS_MAXRSS-1] = 0;
9061   }
9062   unixified = PerlMem_malloc(VMS_MAXRSS);
9063   if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
9064   if (strpbrk(fspec,"]>:") != NULL) {
9065     if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
9066         PerlMem_free(unixwild);
9067         PerlMem_free(unixified);
9068         return 0;
9069     }
9070     else base = unixified;
9071     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9072      * check to see that final result fits into (isn't longer than) fspec */
9073     reslen = strlen(fspec);
9074   }
9075   else base = fspec;
9076
9077   /* No prefix or absolute path on wildcard, so nothing to remove */
9078   if (!*template || *template == '/') {
9079     PerlMem_free(unixwild);
9080     if (base == fspec) {
9081         PerlMem_free(unixified);
9082         return 1;
9083     }
9084     tmplen = strlen(unixified);
9085     if (tmplen > reslen) {
9086         PerlMem_free(unixified);
9087         return 0;  /* not enough space */
9088     }
9089     /* Copy unixified resultant, including trailing NUL */
9090     memmove(fspec,unixified,tmplen+1);
9091     PerlMem_free(unixified);
9092     return 1;
9093   }
9094
9095   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
9096   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
9097     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
9098     for (cp1 = end ;cp1 >= base; cp1--)
9099       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9100         { cp1++; break; }
9101     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9102     PerlMem_free(unixified);
9103     PerlMem_free(unixwild);
9104     return 1;
9105   }
9106   else {
9107     char *tpl, *lcres;
9108     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9109     int ells = 1, totells, segdirs, match;
9110     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9111                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9112
9113     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9114     totells = ells;
9115     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9116     tpl = PerlMem_malloc(VMS_MAXRSS);
9117     if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
9118     if (ellipsis == template && opts & 1) {
9119       /* Template begins with an ellipsis.  Since we can't tell how many
9120        * directory names at the front of the resultant to keep for an
9121        * arbitrary starting point, we arbitrarily choose the current
9122        * default directory as a starting point.  If it's there as a prefix,
9123        * clip it off.  If not, fall through and act as if the leading
9124        * ellipsis weren't there (i.e. return shortest possible path that
9125        * could match template).
9126        */
9127       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9128           PerlMem_free(tpl);
9129           PerlMem_free(unixified);
9130           PerlMem_free(unixwild);
9131           return 0;
9132       }
9133       if (!decc_efs_case_preserve) {
9134         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9135           if (_tolower(*cp1) != _tolower(*cp2)) break;
9136       }
9137       segdirs = dirs - totells;  /* Min # of dirs we must have left */
9138       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9139       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9140         memmove(fspec,cp2+1,end - cp2);
9141         PerlMem_free(tpl);
9142         PerlMem_free(unixified);
9143         PerlMem_free(unixwild);
9144         return 1;
9145       }
9146     }
9147     /* First off, back up over constant elements at end of path */
9148     if (dirs) {
9149       for (front = end ; front >= base; front--)
9150          if (*front == '/' && !dirs--) { front++; break; }
9151     }
9152     lcres = PerlMem_malloc(VMS_MAXRSS);
9153     if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
9154     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9155          cp1++,cp2++) {
9156             if (!decc_efs_case_preserve) {
9157                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
9158             }
9159             else {
9160                 *cp2 = *cp1;
9161             }
9162     }
9163     if (cp1 != '\0') {
9164         PerlMem_free(tpl);
9165         PerlMem_free(unixified);
9166         PerlMem_free(unixwild);
9167         PerlMem_free(lcres);
9168         return 0;  /* Path too long. */
9169     }
9170     lcend = cp2;
9171     *cp2 = '\0';  /* Pick up with memcpy later */
9172     lcfront = lcres + (front - base);
9173     /* Now skip over each ellipsis and try to match the path in front of it. */
9174     while (ells--) {
9175       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
9176         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
9177             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
9178       if (cp1 < template) break; /* template started with an ellipsis */
9179       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9180         ellipsis = cp1; continue;
9181       }
9182       wilddsc.dsc$a_pointer = tpl;
9183       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9184       nextell = cp1;
9185       for (segdirs = 0, cp2 = tpl;
9186            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9187            cp1++, cp2++) {
9188          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9189          else {
9190             if (!decc_efs_case_preserve) {
9191               *cp2 = _tolower(*cp1);  /* else lowercase for match */
9192             }
9193             else {
9194               *cp2 = *cp1;  /* else preserve case for match */
9195             }
9196          }
9197          if (*cp2 == '/') segdirs++;
9198       }
9199       if (cp1 != ellipsis - 1) {
9200           PerlMem_free(tpl);
9201           PerlMem_free(unixified);
9202           PerlMem_free(unixwild);
9203           PerlMem_free(lcres);
9204           return 0; /* Path too long */
9205       }
9206       /* Back up at least as many dirs as in template before matching */
9207       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9208         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9209       for (match = 0; cp1 > lcres;) {
9210         resdsc.dsc$a_pointer = cp1;
9211         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9212           match++;
9213           if (match == 1) lcfront = cp1;
9214         }
9215         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9216       }
9217       if (!match) {
9218         PerlMem_free(tpl);
9219         PerlMem_free(unixified);
9220         PerlMem_free(unixwild);
9221         PerlMem_free(lcres);
9222         return 0;  /* Can't find prefix ??? */
9223       }
9224       if (match > 1 && opts & 1) {
9225         /* This ... wildcard could cover more than one set of dirs (i.e.
9226          * a set of similar dir names is repeated).  If the template
9227          * contains more than 1 ..., upstream elements could resolve the
9228          * ambiguity, but it's not worth a full backtracking setup here.
9229          * As a quick heuristic, clip off the current default directory
9230          * if it's present to find the trimmed spec, else use the
9231          * shortest string that this ... could cover.
9232          */
9233         char def[NAM$C_MAXRSS+1], *st;
9234
9235         if (getcwd(def, sizeof def,0) == NULL) {
9236             Safefree(unixified);
9237             Safefree(unixwild);
9238             Safefree(lcres);
9239             Safefree(tpl);
9240             return 0;
9241         }
9242         if (!decc_efs_case_preserve) {
9243           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9244             if (_tolower(*cp1) != _tolower(*cp2)) break;
9245         }
9246         segdirs = dirs - totells;  /* Min # of dirs we must have left */
9247         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9248         if (*cp1 == '\0' && *cp2 == '/') {
9249           memmove(fspec,cp2+1,end - cp2);
9250           PerlMem_free(tpl);
9251           PerlMem_free(unixified);
9252           PerlMem_free(unixwild);
9253           PerlMem_free(lcres);
9254           return 1;
9255         }
9256         /* Nope -- stick with lcfront from above and keep going. */
9257       }
9258     }
9259     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
9260     PerlMem_free(tpl);
9261     PerlMem_free(unixified);
9262     PerlMem_free(unixwild);
9263     PerlMem_free(lcres);
9264     return 1;
9265     ellipsis = nextell;
9266   }
9267
9268 }  /* end of trim_unixpath() */
9269 /*}}}*/
9270
9271
9272 /*
9273  *  VMS readdir() routines.
9274  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
9275  *
9276  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
9277  *  Minor modifications to original routines.
9278  */
9279
9280 /* readdir may have been redefined by reentr.h, so make sure we get
9281  * the local version for what we do here.
9282  */
9283 #ifdef readdir
9284 # undef readdir
9285 #endif
9286 #if !defined(PERL_IMPLICIT_CONTEXT)
9287 # define readdir Perl_readdir
9288 #else
9289 # define readdir(a) Perl_readdir(aTHX_ a)
9290 #endif
9291
9292     /* Number of elements in vms_versions array */
9293 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
9294
9295 /*
9296  *  Open a directory, return a handle for later use.
9297  */
9298 /*{{{ DIR *opendir(char*name) */
9299 DIR *
9300 Perl_opendir(pTHX_ const char *name)
9301 {
9302     DIR *dd;
9303     char *dir;
9304     Stat_t sb;
9305
9306     Newx(dir, VMS_MAXRSS, char);
9307     if (do_tovmspath(name,dir,0,NULL) == NULL) {
9308       Safefree(dir);
9309       return NULL;
9310     }
9311     /* Check access before stat; otherwise stat does not
9312      * accurately report whether it's a directory.
9313      */
9314     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
9315       /* cando_by_name has already set errno */
9316       Safefree(dir);
9317       return NULL;
9318     }
9319     if (flex_stat(dir,&sb) == -1) return NULL;
9320     if (!S_ISDIR(sb.st_mode)) {
9321       Safefree(dir);
9322       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
9323       return NULL;
9324     }
9325     /* Get memory for the handle, and the pattern. */
9326     Newx(dd,1,DIR);
9327     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
9328
9329     /* Fill in the fields; mainly playing with the descriptor. */
9330     sprintf(dd->pattern, "%s*.*",dir);
9331     Safefree(dir);
9332     dd->context = 0;
9333     dd->count = 0;
9334     dd->flags = 0;
9335     /* By saying we always want the result of readdir() in unix format, we
9336      * are really saying we want all the escapes removed.  Otherwise the caller,
9337      * having no way to know whether it's already in VMS format, might send it
9338      * through tovmsspec again, thus double escaping.
9339      */
9340     dd->flags = PERL_VMSDIR_M_UNIXSPECS;
9341     dd->pat.dsc$a_pointer = dd->pattern;
9342     dd->pat.dsc$w_length = strlen(dd->pattern);
9343     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
9344     dd->pat.dsc$b_class = DSC$K_CLASS_S;
9345 #if defined(USE_ITHREADS)
9346     Newx(dd->mutex,1,perl_mutex);
9347     MUTEX_INIT( (perl_mutex *) dd->mutex );
9348 #else
9349     dd->mutex = NULL;
9350 #endif
9351
9352     return dd;
9353 }  /* end of opendir() */
9354 /*}}}*/
9355
9356 /*
9357  *  Set the flag to indicate we want versions or not.
9358  */
9359 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
9360 void
9361 vmsreaddirversions(DIR *dd, int flag)
9362 {
9363     if (flag)
9364         dd->flags |= PERL_VMSDIR_M_VERSIONS;
9365     else
9366         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9367 }
9368 /*}}}*/
9369
9370 /*
9371  *  Free up an opened directory.
9372  */
9373 /*{{{ void closedir(DIR *dd)*/
9374 void
9375 Perl_closedir(DIR *dd)
9376 {
9377     int sts;
9378
9379     sts = lib$find_file_end(&dd->context);
9380     Safefree(dd->pattern);
9381 #if defined(USE_ITHREADS)
9382     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
9383     Safefree(dd->mutex);
9384 #endif
9385     Safefree(dd);
9386 }
9387 /*}}}*/
9388
9389 /*
9390  *  Collect all the version numbers for the current file.
9391  */
9392 static void
9393 collectversions(pTHX_ DIR *dd)
9394 {
9395     struct dsc$descriptor_s     pat;
9396     struct dsc$descriptor_s     res;
9397     struct dirent *e;
9398     char *p, *text, *buff;
9399     int i;
9400     unsigned long context, tmpsts;
9401
9402     /* Convenient shorthand. */
9403     e = &dd->entry;
9404
9405     /* Add the version wildcard, ignoring the "*.*" put on before */
9406     i = strlen(dd->pattern);
9407     Newx(text,i + e->d_namlen + 3,char);
9408     strcpy(text, dd->pattern);
9409     sprintf(&text[i - 3], "%s;*", e->d_name);
9410
9411     /* Set up the pattern descriptor. */
9412     pat.dsc$a_pointer = text;
9413     pat.dsc$w_length = i + e->d_namlen - 1;
9414     pat.dsc$b_dtype = DSC$K_DTYPE_T;
9415     pat.dsc$b_class = DSC$K_CLASS_S;
9416
9417     /* Set up result descriptor. */
9418     Newx(buff, VMS_MAXRSS, char);
9419     res.dsc$a_pointer = buff;
9420     res.dsc$w_length = VMS_MAXRSS - 1;
9421     res.dsc$b_dtype = DSC$K_DTYPE_T;
9422     res.dsc$b_class = DSC$K_CLASS_S;
9423
9424     /* Read files, collecting versions. */
9425     for (context = 0, e->vms_verscount = 0;
9426          e->vms_verscount < VERSIZE(e);
9427          e->vms_verscount++) {
9428         unsigned long rsts;
9429         unsigned long flags = 0;
9430
9431 #ifdef VMS_LONGNAME_SUPPORT
9432         flags = LIB$M_FIL_LONG_NAMES;
9433 #endif
9434         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
9435         if (tmpsts == RMS$_NMF || context == 0) break;
9436         _ckvmssts(tmpsts);
9437         buff[VMS_MAXRSS - 1] = '\0';
9438         if ((p = strchr(buff, ';')))
9439             e->vms_versions[e->vms_verscount] = atoi(p + 1);
9440         else
9441             e->vms_versions[e->vms_verscount] = -1;
9442     }
9443
9444     _ckvmssts(lib$find_file_end(&context));
9445     Safefree(text);
9446     Safefree(buff);
9447
9448 }  /* end of collectversions() */
9449
9450 /*
9451  *  Read the next entry from the directory.
9452  */
9453 /*{{{ struct dirent *readdir(DIR *dd)*/
9454 struct dirent *
9455 Perl_readdir(pTHX_ DIR *dd)
9456 {
9457     struct dsc$descriptor_s     res;
9458     char *p, *buff;
9459     unsigned long int tmpsts;
9460     unsigned long rsts;
9461     unsigned long flags = 0;
9462     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
9463     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
9464
9465     /* Set up result descriptor, and get next file. */
9466     Newx(buff, VMS_MAXRSS, char);
9467     res.dsc$a_pointer = buff;
9468     res.dsc$w_length = VMS_MAXRSS - 1;
9469     res.dsc$b_dtype = DSC$K_DTYPE_T;
9470     res.dsc$b_class = DSC$K_CLASS_S;
9471
9472 #ifdef VMS_LONGNAME_SUPPORT
9473     flags = LIB$M_FIL_LONG_NAMES;
9474 #endif
9475
9476     tmpsts = lib$find_file
9477         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
9478     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
9479     if (!(tmpsts & 1)) {
9480       set_vaxc_errno(tmpsts);
9481       switch (tmpsts) {
9482         case RMS$_PRV:
9483           set_errno(EACCES); break;
9484         case RMS$_DEV:
9485           set_errno(ENODEV); break;
9486         case RMS$_DIR:
9487           set_errno(ENOTDIR); break;
9488         case RMS$_FNF: case RMS$_DNF:
9489           set_errno(ENOENT); break;
9490         default:
9491           set_errno(EVMSERR);
9492       }
9493       Safefree(buff);
9494       return NULL;
9495     }
9496     dd->count++;
9497     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
9498     if (!decc_efs_case_preserve) {
9499       buff[VMS_MAXRSS - 1] = '\0';
9500       for (p = buff; *p; p++) *p = _tolower(*p);
9501     }
9502     else {
9503       /* we don't want to force to lowercase, just null terminate */
9504       buff[res.dsc$w_length] = '\0';
9505     }
9506     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
9507     *p = '\0';
9508
9509     /* Skip any directory component and just copy the name. */
9510     sts = vms_split_path
9511        (buff,
9512         &v_spec,
9513         &v_len,
9514         &r_spec,
9515         &r_len,
9516         &d_spec,
9517         &d_len,
9518         &n_spec,
9519         &n_len,
9520         &e_spec,
9521         &e_len,
9522         &vs_spec,
9523         &vs_len);
9524
9525     /* Drop NULL extensions on UNIX file specification */
9526     if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
9527         (e_len == 1) && decc_readdir_dropdotnotype)) {
9528         e_len = 0;
9529         e_spec[0] = '\0';
9530     }
9531
9532     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
9533     dd->entry.d_name[n_len + e_len] = '\0';
9534     dd->entry.d_namlen = strlen(dd->entry.d_name);
9535
9536     /* Convert the filename to UNIX format if needed */
9537     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
9538
9539         /* Translate the encoded characters. */
9540         /* Fixme: Unicode handling could result in embedded 0 characters */
9541         if (strchr(dd->entry.d_name, '^') != NULL) {
9542             char new_name[256];
9543             char * q;
9544             p = dd->entry.d_name;
9545             q = new_name;
9546             while (*p != 0) {
9547                 int inchars_read, outchars_added;
9548                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
9549                 p += inchars_read;
9550                 q += outchars_added;
9551                 /* fix-me */
9552                 /* if outchars_added > 1, then this is a wide file specification */
9553                 /* Wide file specifications need to be passed in Perl */
9554                 /* counted strings apparently with a Unicode flag */
9555             }
9556             *q = 0;
9557             strcpy(dd->entry.d_name, new_name);
9558             dd->entry.d_namlen = strlen(dd->entry.d_name);
9559         }
9560     }
9561
9562     dd->entry.vms_verscount = 0;
9563     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
9564     Safefree(buff);
9565     return &dd->entry;
9566
9567 }  /* end of readdir() */
9568 /*}}}*/
9569
9570 /*
9571  *  Read the next entry from the directory -- thread-safe version.
9572  */
9573 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
9574 int
9575 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
9576 {
9577     int retval;
9578
9579     MUTEX_LOCK( (perl_mutex *) dd->mutex );
9580
9581     entry = readdir(dd);
9582     *result = entry;
9583     retval = ( *result == NULL ? errno : 0 );
9584
9585     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
9586
9587     return retval;
9588
9589 }  /* end of readdir_r() */
9590 /*}}}*/
9591
9592 /*
9593  *  Return something that can be used in a seekdir later.
9594  */
9595 /*{{{ long telldir(DIR *dd)*/
9596 long
9597 Perl_telldir(DIR *dd)
9598 {
9599     return dd->count;
9600 }
9601 /*}}}*/
9602
9603 /*
9604  *  Return to a spot where we used to be.  Brute force.
9605  */
9606 /*{{{ void seekdir(DIR *dd,long count)*/
9607 void
9608 Perl_seekdir(pTHX_ DIR *dd, long count)
9609 {
9610     int old_flags;
9611
9612     /* If we haven't done anything yet... */
9613     if (dd->count == 0)
9614         return;
9615
9616     /* Remember some state, and clear it. */
9617     old_flags = dd->flags;
9618     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9619     _ckvmssts(lib$find_file_end(&dd->context));
9620     dd->context = 0;
9621
9622     /* The increment is in readdir(). */
9623     for (dd->count = 0; dd->count < count; )
9624         readdir(dd);
9625
9626     dd->flags = old_flags;
9627
9628 }  /* end of seekdir() */
9629 /*}}}*/
9630
9631 /* VMS subprocess management
9632  *
9633  * my_vfork() - just a vfork(), after setting a flag to record that
9634  * the current script is trying a Unix-style fork/exec.
9635  *
9636  * vms_do_aexec() and vms_do_exec() are called in response to the
9637  * perl 'exec' function.  If this follows a vfork call, then they
9638  * call out the regular perl routines in doio.c which do an
9639  * execvp (for those who really want to try this under VMS).
9640  * Otherwise, they do exactly what the perl docs say exec should
9641  * do - terminate the current script and invoke a new command
9642  * (See below for notes on command syntax.)
9643  *
9644  * do_aspawn() and do_spawn() implement the VMS side of the perl
9645  * 'system' function.
9646  *
9647  * Note on command arguments to perl 'exec' and 'system': When handled
9648  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
9649  * are concatenated to form a DCL command string.  If the first non-numeric
9650  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
9651  * the command string is handed off to DCL directly.  Otherwise,
9652  * the first token of the command is taken as the filespec of an image
9653  * to run.  The filespec is expanded using a default type of '.EXE' and
9654  * the process defaults for device, directory, etc., and if found, the resultant
9655  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
9656  * the command string as parameters.  This is perhaps a bit complicated,
9657  * but I hope it will form a happy medium between what VMS folks expect
9658  * from lib$spawn and what Unix folks expect from exec.
9659  */
9660
9661 static int vfork_called;
9662
9663 /*{{{int my_vfork()*/
9664 int
9665 my_vfork()
9666 {
9667   vfork_called++;
9668   return vfork();
9669 }
9670 /*}}}*/
9671
9672
9673 static void
9674 vms_execfree(struct dsc$descriptor_s *vmscmd)
9675 {
9676   if (vmscmd) {
9677       if (vmscmd->dsc$a_pointer) {
9678           PerlMem_free(vmscmd->dsc$a_pointer);
9679       }
9680       PerlMem_free(vmscmd);
9681   }
9682 }
9683
9684 static char *
9685 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
9686 {
9687   char *junk, *tmps = Nullch;
9688   register size_t cmdlen = 0;
9689   size_t rlen;
9690   register SV **idx;
9691   STRLEN n_a;
9692
9693   idx = mark;
9694   if (really) {
9695     tmps = SvPV(really,rlen);
9696     if (*tmps) {
9697       cmdlen += rlen + 1;
9698       idx++;
9699     }
9700   }
9701
9702   for (idx++; idx <= sp; idx++) {
9703     if (*idx) {
9704       junk = SvPVx(*idx,rlen);
9705       cmdlen += rlen ? rlen + 1 : 0;
9706     }
9707   }
9708   Newx(PL_Cmd, cmdlen+1, char);
9709
9710   if (tmps && *tmps) {
9711     strcpy(PL_Cmd,tmps);
9712     mark++;
9713   }
9714   else *PL_Cmd = '\0';
9715   while (++mark <= sp) {
9716     if (*mark) {
9717       char *s = SvPVx(*mark,n_a);
9718       if (!*s) continue;
9719       if (*PL_Cmd) strcat(PL_Cmd," ");
9720       strcat(PL_Cmd,s);
9721     }
9722   }
9723   return PL_Cmd;
9724
9725 }  /* end of setup_argstr() */
9726
9727
9728 static unsigned long int
9729 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
9730                    struct dsc$descriptor_s **pvmscmd)
9731 {
9732   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
9733   char image_name[NAM$C_MAXRSS+1];
9734   char image_argv[NAM$C_MAXRSS+1];
9735   $DESCRIPTOR(defdsc,".EXE");
9736   $DESCRIPTOR(defdsc2,".");
9737   $DESCRIPTOR(resdsc,resspec);
9738   struct dsc$descriptor_s *vmscmd;
9739   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9740   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
9741   register char *s, *rest, *cp, *wordbreak;
9742   char * cmd;
9743   int cmdlen;
9744   register int isdcl;
9745
9746   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9747   if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
9748
9749   /* Make a copy for modification */
9750   cmdlen = strlen(incmd);
9751   cmd = PerlMem_malloc(cmdlen+1);
9752   if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
9753   strncpy(cmd, incmd, cmdlen);
9754   cmd[cmdlen] = 0;
9755   image_name[0] = 0;
9756   image_argv[0] = 0;
9757
9758   vmscmd->dsc$a_pointer = NULL;
9759   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
9760   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
9761   vmscmd->dsc$w_length = 0;
9762   if (pvmscmd) *pvmscmd = vmscmd;
9763
9764   if (suggest_quote) *suggest_quote = 0;
9765
9766   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
9767     PerlMem_free(cmd);
9768     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
9769   }
9770
9771   s = cmd;
9772
9773   while (*s && isspace(*s)) s++;
9774
9775   if (*s == '@' || *s == '$') {
9776     vmsspec[0] = *s;  rest = s + 1;
9777     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
9778   }
9779   else { cp = vmsspec; rest = s; }
9780   if (*rest == '.' || *rest == '/') {
9781     char *cp2;
9782     for (cp2 = resspec;
9783          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
9784          rest++, cp2++) *cp2 = *rest;
9785     *cp2 = '\0';
9786     if (do_tovmsspec(resspec,cp,0,NULL)) {
9787       s = vmsspec;
9788       if (*rest) {
9789         for (cp2 = vmsspec + strlen(vmsspec);
9790              *rest && cp2 - vmsspec < sizeof vmsspec;
9791              rest++, cp2++) *cp2 = *rest;
9792         *cp2 = '\0';
9793       }
9794     }
9795   }
9796   /* Intuit whether verb (first word of cmd) is a DCL command:
9797    *   - if first nonspace char is '@', it's a DCL indirection
9798    * otherwise
9799    *   - if verb contains a filespec separator, it's not a DCL command
9800    *   - if it doesn't, caller tells us whether to default to a DCL
9801    *     command, or to a local image unless told it's DCL (by leading '$')
9802    */
9803   if (*s == '@') {
9804       isdcl = 1;
9805       if (suggest_quote) *suggest_quote = 1;
9806   } else {
9807     register char *filespec = strpbrk(s,":<[.;");
9808     rest = wordbreak = strpbrk(s," \"\t/");
9809     if (!wordbreak) wordbreak = s + strlen(s);
9810     if (*s == '$') check_img = 0;
9811     if (filespec && (filespec < wordbreak)) isdcl = 0;
9812     else isdcl = !check_img;
9813   }
9814
9815   if (!isdcl) {
9816     int rsts;
9817     imgdsc.dsc$a_pointer = s;
9818     imgdsc.dsc$w_length = wordbreak - s;
9819     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9820     if (!(retsts&1)) {
9821         _ckvmssts(lib$find_file_end(&cxt));
9822         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9823       if (!(retsts & 1) && *s == '$') {
9824         _ckvmssts(lib$find_file_end(&cxt));
9825         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
9826         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9827         if (!(retsts&1)) {
9828           _ckvmssts(lib$find_file_end(&cxt));
9829           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9830         }
9831       }
9832     }
9833     _ckvmssts(lib$find_file_end(&cxt));
9834
9835     if (retsts & 1) {
9836       FILE *fp;
9837       s = resspec;
9838       while (*s && !isspace(*s)) s++;
9839       *s = '\0';
9840
9841       /* check that it's really not DCL with no file extension */
9842       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9843       if (fp) {
9844         char b[256] = {0,0,0,0};
9845         read(fileno(fp), b, 256);
9846         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9847         if (isdcl) {
9848           int shebang_len;
9849
9850           /* Check for script */
9851           shebang_len = 0;
9852           if ((b[0] == '#') && (b[1] == '!'))
9853              shebang_len = 2;
9854 #ifdef ALTERNATE_SHEBANG
9855           else {
9856             shebang_len = strlen(ALTERNATE_SHEBANG);
9857             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9858               char * perlstr;
9859                 perlstr = strstr("perl",b);
9860                 if (perlstr == NULL)
9861                   shebang_len = 0;
9862             }
9863             else
9864               shebang_len = 0;
9865           }
9866 #endif
9867
9868           if (shebang_len > 0) {
9869           int i;
9870           int j;
9871           char tmpspec[NAM$C_MAXRSS + 1];
9872
9873             i = shebang_len;
9874              /* Image is following after white space */
9875             /*--------------------------------------*/
9876             while (isprint(b[i]) && isspace(b[i]))
9877                 i++;
9878
9879             j = 0;
9880             while (isprint(b[i]) && !isspace(b[i])) {
9881                 tmpspec[j++] = b[i++];
9882                 if (j >= NAM$C_MAXRSS)
9883                    break;
9884             }
9885             tmpspec[j] = '\0';
9886
9887              /* There may be some default parameters to the image */
9888             /*---------------------------------------------------*/
9889             j = 0;
9890             while (isprint(b[i])) {
9891                 image_argv[j++] = b[i++];
9892                 if (j >= NAM$C_MAXRSS)
9893                    break;
9894             }
9895             while ((j > 0) && !isprint(image_argv[j-1]))
9896                 j--;
9897             image_argv[j] = 0;
9898
9899             /* It will need to be converted to VMS format and validated */
9900             if (tmpspec[0] != '\0') {
9901               char * iname;
9902
9903                /* Try to find the exact program requested to be run */
9904               /*---------------------------------------------------*/
9905               iname = do_rmsexpand
9906                  (tmpspec, image_name, 0, ".exe",
9907                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
9908               if (iname != NULL) {
9909                 if (cando_by_name_int
9910                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
9911                   /* MCR prefix needed */
9912                   isdcl = 0;
9913                 }
9914                 else {
9915                    /* Try again with a null type */
9916                   /*----------------------------*/
9917                   iname = do_rmsexpand
9918                     (tmpspec, image_name, 0, ".",
9919                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
9920                   if (iname != NULL) {
9921                     if (cando_by_name_int
9922                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
9923                       /* MCR prefix needed */
9924                       isdcl = 0;
9925                     }
9926                   }
9927                 }
9928
9929                  /* Did we find the image to run the script? */
9930                 /*------------------------------------------*/
9931                 if (isdcl) {
9932                   char *tchr;
9933
9934                    /* Assume DCL or foreign command exists */
9935                   /*--------------------------------------*/
9936                   tchr = strrchr(tmpspec, '/');
9937                   if (tchr != NULL) {
9938                     tchr++;
9939                   }
9940                   else {
9941                     tchr = tmpspec;
9942                   }
9943                   strcpy(image_name, tchr);
9944                 }
9945               }
9946             }
9947           }
9948         }
9949         fclose(fp);
9950       }
9951       if (check_img && isdcl) return RMS$_FNF;
9952
9953       if (cando_by_name(S_IXUSR,0,resspec)) {
9954         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
9955         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
9956         if (!isdcl) {
9957             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
9958             if (image_name[0] != 0) {
9959                 strcat(vmscmd->dsc$a_pointer, image_name);
9960                 strcat(vmscmd->dsc$a_pointer, " ");
9961             }
9962         } else if (image_name[0] != 0) {
9963             strcpy(vmscmd->dsc$a_pointer, image_name);
9964             strcat(vmscmd->dsc$a_pointer, " ");
9965         } else {
9966             strcpy(vmscmd->dsc$a_pointer,"@");
9967         }
9968         if (suggest_quote) *suggest_quote = 1;
9969
9970         /* If there is an image name, use original command */
9971         if (image_name[0] == 0)
9972             strcat(vmscmd->dsc$a_pointer,resspec);
9973         else {
9974             rest = cmd;
9975             while (*rest && isspace(*rest)) rest++;
9976         }
9977
9978         if (image_argv[0] != 0) {
9979           strcat(vmscmd->dsc$a_pointer,image_argv);
9980           strcat(vmscmd->dsc$a_pointer, " ");
9981         }
9982         if (rest) {
9983            int rest_len;
9984            int vmscmd_len;
9985
9986            rest_len = strlen(rest);
9987            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
9988            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
9989               strcat(vmscmd->dsc$a_pointer,rest);
9990            else
9991              retsts = CLI$_BUFOVF;
9992         }
9993         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
9994         PerlMem_free(cmd);
9995         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9996       }
9997       else
9998         retsts = RMS$_PRV;
9999     }
10000   }
10001   /* It's either a DCL command or we couldn't find a suitable image */
10002   vmscmd->dsc$w_length = strlen(cmd);
10003
10004   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
10005   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
10006   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
10007
10008   PerlMem_free(cmd);
10009
10010   /* check if it's a symbol (for quoting purposes) */
10011   if (suggest_quote && !*suggest_quote) {
10012     int iss;
10013     char equiv[LNM$C_NAMLENGTH];
10014     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10015     eqvdsc.dsc$a_pointer = equiv;
10016
10017     iss = lib$get_symbol(vmscmd,&eqvdsc);
10018     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10019   }
10020   if (!(retsts & 1)) {
10021     /* just hand off status values likely to be due to user error */
10022     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10023         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10024        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10025     else { _ckvmssts(retsts); }
10026   }
10027
10028   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10029
10030 }  /* end of setup_cmddsc() */
10031
10032
10033 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10034 bool
10035 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10036 {
10037 bool exec_sts;
10038 char * cmd;
10039
10040   if (sp > mark) {
10041     if (vfork_called) {           /* this follows a vfork - act Unixish */
10042       vfork_called--;
10043       if (vfork_called < 0) {
10044         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10045         vfork_called = 0;
10046       }
10047       else return do_aexec(really,mark,sp);
10048     }
10049                                            /* no vfork - act VMSish */
10050     cmd = setup_argstr(aTHX_ really,mark,sp);
10051     exec_sts = vms_do_exec(cmd);
10052     Safefree(cmd);  /* Clean up from setup_argstr() */
10053     return exec_sts;
10054   }
10055
10056   return FALSE;
10057 }  /* end of vms_do_aexec() */
10058 /*}}}*/
10059
10060 /* {{{bool vms_do_exec(char *cmd) */
10061 bool
10062 Perl_vms_do_exec(pTHX_ const char *cmd)
10063 {
10064   struct dsc$descriptor_s *vmscmd;
10065
10066   if (vfork_called) {             /* this follows a vfork - act Unixish */
10067     vfork_called--;
10068     if (vfork_called < 0) {
10069       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10070       vfork_called = 0;
10071     }
10072     else return do_exec(cmd);
10073   }
10074
10075   {                               /* no vfork - act VMSish */
10076     unsigned long int retsts;
10077
10078     TAINT_ENV();
10079     TAINT_PROPER("exec");
10080     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10081       retsts = lib$do_command(vmscmd);
10082
10083     switch (retsts) {
10084       case RMS$_FNF: case RMS$_DNF:
10085         set_errno(ENOENT); break;
10086       case RMS$_DIR:
10087         set_errno(ENOTDIR); break;
10088       case RMS$_DEV:
10089         set_errno(ENODEV); break;
10090       case RMS$_PRV:
10091         set_errno(EACCES); break;
10092       case RMS$_SYN:
10093         set_errno(EINVAL); break;
10094       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10095         set_errno(E2BIG); break;
10096       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10097         _ckvmssts(retsts); /* fall through */
10098       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10099         set_errno(EVMSERR);
10100     }
10101     set_vaxc_errno(retsts);
10102     if (ckWARN(WARN_EXEC)) {
10103       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10104              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10105     }
10106     vms_execfree(vmscmd);
10107   }
10108
10109   return FALSE;
10110
10111 }  /* end of vms_do_exec() */
10112 /*}}}*/
10113
10114 unsigned long int Perl_do_spawn(pTHX_ const char *);
10115 unsigned long int do_spawn2(pTHX_ const char *, int);
10116
10117 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
10118 unsigned long int
10119 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
10120 {
10121 unsigned long int sts;
10122 char * cmd;
10123 int flags = 0;
10124
10125   if (sp > mark) {
10126
10127     /* We'll copy the (undocumented?) Win32 behavior and allow a
10128      * numeric first argument.  But the only value we'll support
10129      * through do_aspawn is a value of 1, which means spawn without
10130      * waiting for completion -- other values are ignored.
10131      */
10132     if (SvNIOKp(*((SV**)mark+1)) && !SvPOKp(*((SV**)mark+1))) {
10133         ++mark;
10134         flags = SvIVx(*(SV**)mark);
10135     }
10136
10137     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
10138         flags = CLI$M_NOWAIT;
10139     else
10140         flags = 0;
10141
10142     cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
10143     sts = do_spawn2(aTHX_ cmd, flags);
10144     /* pp_sys will clean up cmd */
10145     return sts;
10146   }
10147   return SS$_ABORT;
10148 }  /* end of do_aspawn() */
10149 /*}}}*/
10150
10151
10152 /* {{{unsigned long int do_spawn(char *cmd) */
10153 unsigned long int
10154 Perl_do_spawn(pTHX_ const char *cmd)
10155 {
10156     return do_spawn2(aTHX_ cmd, 0);
10157 }
10158 /*}}}*/
10159
10160 /* {{{unsigned long int do_spawn2(char *cmd) */
10161 unsigned long int
10162 do_spawn2(pTHX_ const char *cmd, int flags)
10163 {
10164   unsigned long int sts, substs;
10165
10166   /* The caller of this routine expects to Safefree(PL_Cmd) */
10167   Newx(PL_Cmd,10,char);
10168
10169   TAINT_ENV();
10170   TAINT_PROPER("spawn");
10171   if (!cmd || !*cmd) {
10172     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
10173     if (!(sts & 1)) {
10174       switch (sts) {
10175         case RMS$_FNF:  case RMS$_DNF:
10176           set_errno(ENOENT); break;
10177         case RMS$_DIR:
10178           set_errno(ENOTDIR); break;
10179         case RMS$_DEV:
10180           set_errno(ENODEV); break;
10181         case RMS$_PRV:
10182           set_errno(EACCES); break;
10183         case RMS$_SYN:
10184           set_errno(EINVAL); break;
10185         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10186           set_errno(E2BIG); break;
10187         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10188           _ckvmssts(sts); /* fall through */
10189         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10190           set_errno(EVMSERR);
10191       }
10192       set_vaxc_errno(sts);
10193       if (ckWARN(WARN_EXEC)) {
10194         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
10195                     Strerror(errno));
10196       }
10197     }
10198     sts = substs;
10199   }
10200   else {
10201     char mode[3];
10202     PerlIO * fp;
10203     if (flags & CLI$M_NOWAIT)
10204         strcpy(mode, "n");
10205     else
10206         strcpy(mode, "nW");
10207
10208     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
10209     if (fp != NULL)
10210       my_pclose(fp);
10211     /* sts will be the pid in the nowait case */
10212   }
10213   return sts;
10214 }  /* end of do_spawn2() */
10215 /*}}}*/
10216
10217
10218 static unsigned int *sockflags, sockflagsize;
10219
10220 /*
10221  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
10222  * routines found in some versions of the CRTL can't deal with sockets.
10223  * We don't shim the other file open routines since a socket isn't
10224  * likely to be opened by a name.
10225  */
10226 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
10227 FILE *my_fdopen(int fd, const char *mode)
10228 {
10229   FILE *fp = fdopen(fd, mode);
10230
10231   if (fp) {
10232     unsigned int fdoff = fd / sizeof(unsigned int);
10233     Stat_t sbuf; /* native stat; we don't need flex_stat */
10234     if (!sockflagsize || fdoff > sockflagsize) {
10235       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
10236       else           Newx  (sockflags,fdoff+2,unsigned int);
10237       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
10238       sockflagsize = fdoff + 2;
10239     }
10240     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
10241       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
10242   }
10243   return fp;
10244
10245 }
10246 /*}}}*/
10247
10248
10249 /*
10250  * Clear the corresponding bit when the (possibly) socket stream is closed.
10251  * There still a small hole: we miss an implicit close which might occur
10252  * via freopen().  >> Todo
10253  */
10254 /*{{{ int my_fclose(FILE *fp)*/
10255 int my_fclose(FILE *fp) {
10256   if (fp) {
10257     unsigned int fd = fileno(fp);
10258     unsigned int fdoff = fd / sizeof(unsigned int);
10259
10260     if (sockflagsize && fdoff <= sockflagsize)
10261       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
10262   }
10263   return fclose(fp);
10264 }
10265 /*}}}*/
10266
10267
10268 /*
10269  * A simple fwrite replacement which outputs itmsz*nitm chars without
10270  * introducing record boundaries every itmsz chars.
10271  * We are using fputs, which depends on a terminating null.  We may
10272  * well be writing binary data, so we need to accommodate not only
10273  * data with nulls sprinkled in the middle but also data with no null
10274  * byte at the end.
10275  */
10276 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
10277 int
10278 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
10279 {
10280   register char *cp, *end, *cpd, *data;
10281   register unsigned int fd = fileno(dest);
10282   register unsigned int fdoff = fd / sizeof(unsigned int);
10283   int retval;
10284   int bufsize = itmsz * nitm + 1;
10285
10286   if (fdoff < sockflagsize &&
10287       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
10288     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
10289     return nitm;
10290   }
10291
10292   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
10293   memcpy( data, src, itmsz*nitm );
10294   data[itmsz*nitm] = '\0';
10295
10296   end = data + itmsz * nitm;
10297   retval = (int) nitm; /* on success return # items written */
10298
10299   cpd = data;
10300   while (cpd <= end) {
10301     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
10302     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
10303     if (cp < end)
10304       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
10305     cpd = cp + 1;
10306   }
10307
10308   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
10309   return retval;
10310
10311 }  /* end of my_fwrite() */
10312 /*}}}*/
10313
10314 /*{{{ int my_flush(FILE *fp)*/
10315 int
10316 Perl_my_flush(pTHX_ FILE *fp)
10317 {
10318     int res;
10319     if ((res = fflush(fp)) == 0 && fp) {
10320 #ifdef VMS_DO_SOCKETS
10321         Stat_t s;
10322         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
10323 #endif
10324             res = fsync(fileno(fp));
10325     }
10326 /*
10327  * If the flush succeeded but set end-of-file, we need to clear
10328  * the error because our caller may check ferror().  BTW, this
10329  * probably means we just flushed an empty file.
10330  */
10331     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
10332
10333     return res;
10334 }
10335 /*}}}*/
10336
10337 /*
10338  * Here are replacements for the following Unix routines in the VMS environment:
10339  *      getpwuid    Get information for a particular UIC or UID
10340  *      getpwnam    Get information for a named user
10341  *      getpwent    Get information for each user in the rights database
10342  *      setpwent    Reset search to the start of the rights database
10343  *      endpwent    Finish searching for users in the rights database
10344  *
10345  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
10346  * (defined in pwd.h), which contains the following fields:-
10347  *      struct passwd {
10348  *              char        *pw_name;    Username (in lower case)
10349  *              char        *pw_passwd;  Hashed password
10350  *              unsigned int pw_uid;     UIC
10351  *              unsigned int pw_gid;     UIC group  number
10352  *              char        *pw_unixdir; Default device/directory (VMS-style)
10353  *              char        *pw_gecos;   Owner name
10354  *              char        *pw_dir;     Default device/directory (Unix-style)
10355  *              char        *pw_shell;   Default CLI name (eg. DCL)
10356  *      };
10357  * If the specified user does not exist, getpwuid and getpwnam return NULL.
10358  *
10359  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
10360  * not the UIC member number (eg. what's returned by getuid()),
10361  * getpwuid() can accept either as input (if uid is specified, the caller's
10362  * UIC group is used), though it won't recognise gid=0.
10363  *
10364  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
10365  * information about other users in your group or in other groups, respectively.
10366  * If the required privilege is not available, then these routines fill only
10367  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
10368  * string).
10369  *
10370  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
10371  */
10372
10373 /* sizes of various UAF record fields */
10374 #define UAI$S_USERNAME 12
10375 #define UAI$S_IDENT    31
10376 #define UAI$S_OWNER    31
10377 #define UAI$S_DEFDEV   31
10378 #define UAI$S_DEFDIR   63
10379 #define UAI$S_DEFCLI   31
10380 #define UAI$S_PWD       8
10381
10382 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
10383                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
10384                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
10385
10386 static char __empty[]= "";
10387 static struct passwd __passwd_empty=
10388     {(char *) __empty, (char *) __empty, 0, 0,
10389      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
10390 static int contxt= 0;
10391 static struct passwd __pwdcache;
10392 static char __pw_namecache[UAI$S_IDENT+1];
10393
10394 /*
10395  * This routine does most of the work extracting the user information.
10396  */
10397 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
10398 {
10399     static struct {
10400         unsigned char length;
10401         char pw_gecos[UAI$S_OWNER+1];
10402     } owner;
10403     static union uicdef uic;
10404     static struct {
10405         unsigned char length;
10406         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
10407     } defdev;
10408     static struct {
10409         unsigned char length;
10410         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
10411     } defdir;
10412     static struct {
10413         unsigned char length;
10414         char pw_shell[UAI$S_DEFCLI+1];
10415     } defcli;
10416     static char pw_passwd[UAI$S_PWD+1];
10417
10418     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
10419     struct dsc$descriptor_s name_desc;
10420     unsigned long int sts;
10421
10422     static struct itmlst_3 itmlst[]= {
10423         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
10424         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
10425         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
10426         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
10427         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
10428         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
10429         {0,                0,           NULL,    NULL}};
10430
10431     name_desc.dsc$w_length=  strlen(name);
10432     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
10433     name_desc.dsc$b_class=   DSC$K_CLASS_S;
10434     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
10435
10436 /*  Note that sys$getuai returns many fields as counted strings. */
10437     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
10438     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
10439       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
10440     }
10441     else { _ckvmssts(sts); }
10442     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
10443
10444     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
10445     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
10446     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
10447     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
10448     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
10449     owner.pw_gecos[lowner]=            '\0';
10450     defdev.pw_dir[ldefdev+ldefdir]= '\0';
10451     defcli.pw_shell[ldefcli]=          '\0';
10452     if (valid_uic(uic)) {
10453         pwd->pw_uid= uic.uic$l_uic;
10454         pwd->pw_gid= uic.uic$v_group;
10455     }
10456     else
10457       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
10458     pwd->pw_passwd=  pw_passwd;
10459     pwd->pw_gecos=   owner.pw_gecos;
10460     pwd->pw_dir=     defdev.pw_dir;
10461     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
10462     pwd->pw_shell=   defcli.pw_shell;
10463     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
10464         int ldir;
10465         ldir= strlen(pwd->pw_unixdir) - 1;
10466         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
10467     }
10468     else
10469         strcpy(pwd->pw_unixdir, pwd->pw_dir);
10470     if (!decc_efs_case_preserve)
10471         __mystrtolower(pwd->pw_unixdir);
10472     return 1;
10473 }
10474
10475 /*
10476  * Get information for a named user.
10477 */
10478 /*{{{struct passwd *getpwnam(char *name)*/
10479 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
10480 {
10481     struct dsc$descriptor_s name_desc;
10482     union uicdef uic;
10483     unsigned long int status, sts;
10484
10485     __pwdcache = __passwd_empty;
10486     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
10487       /* We still may be able to determine pw_uid and pw_gid */
10488       name_desc.dsc$w_length=  strlen(name);
10489       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
10490       name_desc.dsc$b_class=   DSC$K_CLASS_S;
10491       name_desc.dsc$a_pointer= (char *) name;
10492       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
10493         __pwdcache.pw_uid= uic.uic$l_uic;
10494         __pwdcache.pw_gid= uic.uic$v_group;
10495       }
10496       else {
10497         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
10498           set_vaxc_errno(sts);
10499           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
10500           return NULL;
10501         }
10502         else { _ckvmssts(sts); }
10503       }
10504     }
10505     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
10506     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
10507     __pwdcache.pw_name= __pw_namecache;
10508     return &__pwdcache;
10509 }  /* end of my_getpwnam() */
10510 /*}}}*/
10511
10512 /*
10513  * Get information for a particular UIC or UID.
10514  * Called by my_getpwent with uid=-1 to list all users.
10515 */
10516 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
10517 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
10518 {
10519     const $DESCRIPTOR(name_desc,__pw_namecache);
10520     unsigned short lname;
10521     union uicdef uic;
10522     unsigned long int status;
10523
10524     if (uid == (unsigned int) -1) {
10525       do {
10526         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
10527         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
10528           set_vaxc_errno(status);
10529           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10530           my_endpwent();
10531           return NULL;
10532         }
10533         else { _ckvmssts(status); }
10534       } while (!valid_uic (uic));
10535     }
10536     else {
10537       uic.uic$l_uic= uid;
10538       if (!uic.uic$v_group)
10539         uic.uic$v_group= PerlProc_getgid();
10540       if (valid_uic(uic))
10541         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
10542       else status = SS$_IVIDENT;
10543       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
10544           status == RMS$_PRV) {
10545         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10546         return NULL;
10547       }
10548       else { _ckvmssts(status); }
10549     }
10550     __pw_namecache[lname]= '\0';
10551     __mystrtolower(__pw_namecache);
10552
10553     __pwdcache = __passwd_empty;
10554     __pwdcache.pw_name = __pw_namecache;
10555
10556 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
10557     The identifier's value is usually the UIC, but it doesn't have to be,
10558     so if we can, we let fillpasswd update this. */
10559     __pwdcache.pw_uid =  uic.uic$l_uic;
10560     __pwdcache.pw_gid =  uic.uic$v_group;
10561
10562     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
10563     return &__pwdcache;
10564
10565 }  /* end of my_getpwuid() */
10566 /*}}}*/
10567
10568 /*
10569  * Get information for next user.
10570 */
10571 /*{{{struct passwd *my_getpwent()*/
10572 struct passwd *Perl_my_getpwent(pTHX)
10573 {
10574     return (my_getpwuid((unsigned int) -1));
10575 }
10576 /*}}}*/
10577
10578 /*
10579  * Finish searching rights database for users.
10580 */
10581 /*{{{void my_endpwent()*/
10582 void Perl_my_endpwent(pTHX)
10583 {
10584     if (contxt) {
10585       _ckvmssts(sys$finish_rdb(&contxt));
10586       contxt= 0;
10587     }
10588 }
10589 /*}}}*/
10590
10591 #ifdef HOMEGROWN_POSIX_SIGNALS
10592   /* Signal handling routines, pulled into the core from POSIX.xs.
10593    *
10594    * We need these for threads, so they've been rolled into the core,
10595    * rather than left in POSIX.xs.
10596    *
10597    * (DRS, Oct 23, 1997)
10598    */
10599
10600   /* sigset_t is atomic under VMS, so these routines are easy */
10601 /*{{{int my_sigemptyset(sigset_t *) */
10602 int my_sigemptyset(sigset_t *set) {
10603     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10604     *set = 0; return 0;
10605 }
10606 /*}}}*/
10607
10608
10609 /*{{{int my_sigfillset(sigset_t *)*/
10610 int my_sigfillset(sigset_t *set) {
10611     int i;
10612     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10613     for (i = 0; i < NSIG; i++) *set |= (1 << i);
10614     return 0;
10615 }
10616 /*}}}*/
10617
10618
10619 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
10620 int my_sigaddset(sigset_t *set, int sig) {
10621     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10622     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10623     *set |= (1 << (sig - 1));
10624     return 0;
10625 }
10626 /*}}}*/
10627
10628
10629 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
10630 int my_sigdelset(sigset_t *set, int sig) {
10631     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10632     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10633     *set &= ~(1 << (sig - 1));
10634     return 0;
10635 }
10636 /*}}}*/
10637
10638
10639 /*{{{int my_sigismember(sigset_t *set, int sig)*/
10640 int my_sigismember(sigset_t *set, int sig) {
10641     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10642     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10643     return *set & (1 << (sig - 1));
10644 }
10645 /*}}}*/
10646
10647
10648 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10649 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10650     sigset_t tempmask;
10651
10652     /* If set and oset are both null, then things are badly wrong. Bail out. */
10653     if ((oset == NULL) && (set == NULL)) {
10654       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
10655       return -1;
10656     }
10657
10658     /* If set's null, then we're just handling a fetch. */
10659     if (set == NULL) {
10660         tempmask = sigblock(0);
10661     }
10662     else {
10663       switch (how) {
10664       case SIG_SETMASK:
10665         tempmask = sigsetmask(*set);
10666         break;
10667       case SIG_BLOCK:
10668         tempmask = sigblock(*set);
10669         break;
10670       case SIG_UNBLOCK:
10671         tempmask = sigblock(0);
10672         sigsetmask(*oset & ~tempmask);
10673         break;
10674       default:
10675         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10676         return -1;
10677       }
10678     }
10679
10680     /* Did they pass us an oset? If so, stick our holding mask into it */
10681     if (oset)
10682       *oset = tempmask;
10683
10684     return 0;
10685 }
10686 /*}}}*/
10687 #endif  /* HOMEGROWN_POSIX_SIGNALS */
10688
10689
10690 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
10691  * my_utime(), and flex_stat(), all of which operate on UTC unless
10692  * VMSISH_TIMES is true.
10693  */
10694 /* method used to handle UTC conversions:
10695  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
10696  */
10697 static int gmtime_emulation_type;
10698 /* number of secs to add to UTC POSIX-style time to get local time */
10699 static long int utc_offset_secs;
10700
10701 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
10702  * in vmsish.h.  #undef them here so we can call the CRTL routines
10703  * directly.
10704  */
10705 #undef gmtime
10706 #undef localtime
10707 #undef time
10708
10709
10710 /*
10711  * DEC C previous to 6.0 corrupts the behavior of the /prefix
10712  * qualifier with the extern prefix pragma.  This provisional
10713  * hack circumvents this prefix pragma problem in previous
10714  * precompilers.
10715  */
10716 #if defined(__VMS_VER) && __VMS_VER >= 70000000
10717 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
10718 #    pragma __extern_prefix save
10719 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
10720 #    define gmtime decc$__utctz_gmtime
10721 #    define localtime decc$__utctz_localtime
10722 #    define time decc$__utc_time
10723 #    pragma __extern_prefix restore
10724
10725      struct tm *gmtime(), *localtime();
10726
10727 #  endif
10728 #endif
10729
10730
10731 static time_t toutc_dst(time_t loc) {
10732   struct tm *rsltmp;
10733
10734   if ((rsltmp = localtime(&loc)) == NULL) return -1;
10735   loc -= utc_offset_secs;
10736   if (rsltmp->tm_isdst) loc -= 3600;
10737   return loc;
10738 }
10739 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10740        ((gmtime_emulation_type || my_time(NULL)), \
10741        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
10742        ((secs) - utc_offset_secs))))
10743
10744 static time_t toloc_dst(time_t utc) {
10745   struct tm *rsltmp;
10746
10747   utc += utc_offset_secs;
10748   if ((rsltmp = localtime(&utc)) == NULL) return -1;
10749   if (rsltmp->tm_isdst) utc += 3600;
10750   return utc;
10751 }
10752 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10753        ((gmtime_emulation_type || my_time(NULL)), \
10754        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
10755        ((secs) + utc_offset_secs))))
10756
10757 #ifndef RTL_USES_UTC
10758 /*
10759
10760     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
10761         DST starts on 1st sun of april      at 02:00  std time
10762             ends on last sun of october     at 02:00  dst time
10763     see the UCX management command reference, SET CONFIG TIMEZONE
10764     for formatting info.
10765
10766     No, it's not as general as it should be, but then again, NOTHING
10767     will handle UK times in a sensible way.
10768 */
10769
10770
10771 /*
10772     parse the DST start/end info:
10773     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
10774 */
10775
10776 static char *
10777 tz_parse_startend(char *s, struct tm *w, int *past)
10778 {
10779     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
10780     int ly, dozjd, d, m, n, hour, min, sec, j, k;
10781     time_t g;
10782
10783     if (!s)    return 0;
10784     if (!w) return 0;
10785     if (!past) return 0;
10786
10787     ly = 0;
10788     if (w->tm_year % 4        == 0) ly = 1;
10789     if (w->tm_year % 100      == 0) ly = 0;
10790     if (w->tm_year+1900 % 400 == 0) ly = 1;
10791     if (ly) dinm[1]++;
10792
10793     dozjd = isdigit(*s);
10794     if (*s == 'J' || *s == 'j' || dozjd) {
10795         if (!dozjd && !isdigit(*++s)) return 0;
10796         d = *s++ - '0';
10797         if (isdigit(*s)) {
10798             d = d*10 + *s++ - '0';
10799             if (isdigit(*s)) {
10800                 d = d*10 + *s++ - '0';
10801             }
10802         }
10803         if (d == 0) return 0;
10804         if (d > 366) return 0;
10805         d--;
10806         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
10807         g = d * 86400;
10808         dozjd = 1;
10809     } else if (*s == 'M' || *s == 'm') {
10810         if (!isdigit(*++s)) return 0;
10811         m = *s++ - '0';
10812         if (isdigit(*s)) m = 10*m + *s++ - '0';
10813         if (*s != '.') return 0;
10814         if (!isdigit(*++s)) return 0;
10815         n = *s++ - '0';
10816         if (n < 1 || n > 5) return 0;
10817         if (*s != '.') return 0;
10818         if (!isdigit(*++s)) return 0;
10819         d = *s++ - '0';
10820         if (d > 6) return 0;
10821     }
10822
10823     if (*s == '/') {
10824         if (!isdigit(*++s)) return 0;
10825         hour = *s++ - '0';
10826         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
10827         if (*s == ':') {
10828             if (!isdigit(*++s)) return 0;
10829             min = *s++ - '0';
10830             if (isdigit(*s)) min = 10*min + *s++ - '0';
10831             if (*s == ':') {
10832                 if (!isdigit(*++s)) return 0;
10833                 sec = *s++ - '0';
10834                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
10835             }
10836         }
10837     } else {
10838         hour = 2;
10839         min = 0;
10840         sec = 0;
10841     }
10842
10843     if (dozjd) {
10844         if (w->tm_yday < d) goto before;
10845         if (w->tm_yday > d) goto after;
10846     } else {
10847         if (w->tm_mon+1 < m) goto before;
10848         if (w->tm_mon+1 > m) goto after;
10849
10850         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
10851         k = d - j; /* mday of first d */
10852         if (k <= 0) k += 7;
10853         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
10854         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
10855         if (w->tm_mday < k) goto before;
10856         if (w->tm_mday > k) goto after;
10857     }
10858
10859     if (w->tm_hour < hour) goto before;
10860     if (w->tm_hour > hour) goto after;
10861     if (w->tm_min  < min)  goto before;
10862     if (w->tm_min  > min)  goto after;
10863     if (w->tm_sec  < sec)  goto before;
10864     goto after;
10865
10866 before:
10867     *past = 0;
10868     return s;
10869 after:
10870     *past = 1;
10871     return s;
10872 }
10873
10874
10875
10876
10877 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
10878
10879 static char *
10880 tz_parse_offset(char *s, int *offset)
10881 {
10882     int hour = 0, min = 0, sec = 0;
10883     int neg = 0;
10884     if (!s) return 0;
10885     if (!offset) return 0;
10886
10887     if (*s == '-') {neg++; s++;}
10888     if (*s == '+') s++;
10889     if (!isdigit(*s)) return 0;
10890     hour = *s++ - '0';
10891     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10892     if (hour > 24) return 0;
10893     if (*s == ':') {
10894         if (!isdigit(*++s)) return 0;
10895         min = *s++ - '0';
10896         if (isdigit(*s)) min = min*10 + (*s++ - '0');
10897         if (min > 59) return 0;
10898         if (*s == ':') {
10899             if (!isdigit(*++s)) return 0;
10900             sec = *s++ - '0';
10901             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10902             if (sec > 59) return 0;
10903         }
10904     }
10905
10906     *offset = (hour*60+min)*60 + sec;
10907     if (neg) *offset = -*offset;
10908     return s;
10909 }
10910
10911 /*
10912     input time is w, whatever type of time the CRTL localtime() uses.
10913     sets dst, the zone, and the gmtoff (seconds)
10914
10915     caches the value of TZ and UCX$TZ env variables; note that
10916     my_setenv looks for these and sets a flag if they're changed
10917     for efficiency.
10918
10919     We have to watch out for the "australian" case (dst starts in
10920     october, ends in april)...flagged by "reverse" and checked by
10921     scanning through the months of the previous year.
10922
10923 */
10924
10925 static int
10926 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
10927 {
10928     time_t when;
10929     struct tm *w2;
10930     char *s,*s2;
10931     char *dstzone, *tz, *s_start, *s_end;
10932     int std_off, dst_off, isdst;
10933     int y, dststart, dstend;
10934     static char envtz[1025];  /* longer than any logical, symbol, ... */
10935     static char ucxtz[1025];
10936     static char reversed = 0;
10937
10938     if (!w) return 0;
10939
10940     if (tz_updated) {
10941         tz_updated = 0;
10942         reversed = -1;  /* flag need to check  */
10943         envtz[0] = ucxtz[0] = '\0';
10944         tz = my_getenv("TZ",0);
10945         if (tz) strcpy(envtz, tz);
10946         tz = my_getenv("UCX$TZ",0);
10947         if (tz) strcpy(ucxtz, tz);
10948         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
10949     }
10950     tz = envtz;
10951     if (!*tz) tz = ucxtz;
10952
10953     s = tz;
10954     while (isalpha(*s)) s++;
10955     s = tz_parse_offset(s, &std_off);
10956     if (!s) return 0;
10957     if (!*s) {                  /* no DST, hurray we're done! */
10958         isdst = 0;
10959         goto done;
10960     }
10961
10962     dstzone = s;
10963     while (isalpha(*s)) s++;
10964     s2 = tz_parse_offset(s, &dst_off);
10965     if (s2) {
10966         s = s2;
10967     } else {
10968         dst_off = std_off - 3600;
10969     }
10970
10971     if (!*s) {      /* default dst start/end?? */
10972         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
10973             s = strchr(ucxtz,',');
10974         }
10975         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
10976     }
10977     if (*s != ',') return 0;
10978
10979     when = *w;
10980     when = _toutc(when);      /* convert to utc */
10981     when = when - std_off;    /* convert to pseudolocal time*/
10982
10983     w2 = localtime(&when);
10984     y = w2->tm_year;
10985     s_start = s+1;
10986     s = tz_parse_startend(s_start,w2,&dststart);
10987     if (!s) return 0;
10988     if (*s != ',') return 0;
10989
10990     when = *w;
10991     when = _toutc(when);      /* convert to utc */
10992     when = when - dst_off;    /* convert to pseudolocal time*/
10993     w2 = localtime(&when);
10994     if (w2->tm_year != y) {   /* spans a year, just check one time */
10995         when += dst_off - std_off;
10996         w2 = localtime(&when);
10997     }
10998     s_end = s+1;
10999     s = tz_parse_startend(s_end,w2,&dstend);
11000     if (!s) return 0;
11001
11002     if (reversed == -1) {  /* need to check if start later than end */
11003         int j, ds, de;
11004
11005         when = *w;
11006         if (when < 2*365*86400) {
11007             when += 2*365*86400;
11008         } else {
11009             when -= 365*86400;
11010         }
11011         w2 =localtime(&when);
11012         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
11013
11014         for (j = 0; j < 12; j++) {
11015             w2 =localtime(&when);
11016             tz_parse_startend(s_start,w2,&ds);
11017             tz_parse_startend(s_end,w2,&de);
11018             if (ds != de) break;
11019             when += 30*86400;
11020         }
11021         reversed = 0;
11022         if (de && !ds) reversed = 1;
11023     }
11024
11025     isdst = dststart && !dstend;
11026     if (reversed) isdst = dststart  || !dstend;
11027
11028 done:
11029     if (dst)    *dst = isdst;
11030     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
11031     if (isdst)  tz = dstzone;
11032     if (zone) {
11033         while(isalpha(*tz))  *zone++ = *tz++;
11034         *zone = '\0';
11035     }
11036     return 1;
11037 }
11038
11039 #endif /* !RTL_USES_UTC */
11040
11041 /* my_time(), my_localtime(), my_gmtime()
11042  * By default traffic in UTC time values, using CRTL gmtime() or
11043  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11044  * Note: We need to use these functions even when the CRTL has working
11045  * UTC support, since they also handle C<use vmsish qw(times);>
11046  *
11047  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
11048  * Modified by Charles Bailey <bailey@newman.upenn.edu>
11049  */
11050
11051 /*{{{time_t my_time(time_t *timep)*/
11052 time_t Perl_my_time(pTHX_ time_t *timep)
11053 {
11054   time_t when;
11055   struct tm *tm_p;
11056
11057   if (gmtime_emulation_type == 0) {
11058     int dstnow;
11059     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
11060                               /* results of calls to gmtime() and localtime() */
11061                               /* for same &base */
11062
11063     gmtime_emulation_type++;
11064     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11065       char off[LNM$C_NAMLENGTH+1];;
11066
11067       gmtime_emulation_type++;
11068       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11069         gmtime_emulation_type++;
11070         utc_offset_secs = 0;
11071         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11072       }
11073       else { utc_offset_secs = atol(off); }
11074     }
11075     else { /* We've got a working gmtime() */
11076       struct tm gmt, local;
11077
11078       gmt = *tm_p;
11079       tm_p = localtime(&base);
11080       local = *tm_p;
11081       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
11082       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11083       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
11084       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
11085     }
11086   }
11087
11088   when = time(NULL);
11089 # ifdef VMSISH_TIME
11090 # ifdef RTL_USES_UTC
11091   if (VMSISH_TIME) when = _toloc(when);
11092 # else
11093   if (!VMSISH_TIME) when = _toutc(when);
11094 # endif
11095 # endif
11096   if (timep != NULL) *timep = when;
11097   return when;
11098
11099 }  /* end of my_time() */
11100 /*}}}*/
11101
11102
11103 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11104 struct tm *
11105 Perl_my_gmtime(pTHX_ const time_t *timep)
11106 {
11107   char *p;
11108   time_t when;
11109   struct tm *rsltmp;
11110
11111   if (timep == NULL) {
11112     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11113     return NULL;
11114   }
11115   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11116
11117   when = *timep;
11118 # ifdef VMSISH_TIME
11119   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11120 #  endif
11121 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
11122   return gmtime(&when);
11123 # else
11124   /* CRTL localtime() wants local time as input, so does no tz correction */
11125   rsltmp = localtime(&when);
11126   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
11127   return rsltmp;
11128 #endif
11129 }  /* end of my_gmtime() */
11130 /*}}}*/
11131
11132
11133 /*{{{struct tm *my_localtime(const time_t *timep)*/
11134 struct tm *
11135 Perl_my_localtime(pTHX_ const time_t *timep)
11136 {
11137   time_t when, whenutc;
11138   struct tm *rsltmp;
11139   int dst, offset;
11140
11141   if (timep == NULL) {
11142     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11143     return NULL;
11144   }
11145   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11146   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11147
11148   when = *timep;
11149 # ifdef RTL_USES_UTC
11150 # ifdef VMSISH_TIME
11151   if (VMSISH_TIME) when = _toutc(when);
11152 # endif
11153   /* CRTL localtime() wants UTC as input, does tz correction itself */
11154   return localtime(&when);
11155
11156 # else /* !RTL_USES_UTC */
11157   whenutc = when;
11158 # ifdef VMSISH_TIME
11159   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
11160   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
11161 # endif
11162   dst = -1;
11163 #ifndef RTL_USES_UTC
11164   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
11165       when = whenutc - offset;                   /* pseudolocal time*/
11166   }
11167 # endif
11168   /* CRTL localtime() wants local time as input, so does no tz correction */
11169   rsltmp = localtime(&when);
11170   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
11171   return rsltmp;
11172 # endif
11173
11174 } /*  end of my_localtime() */
11175 /*}}}*/
11176
11177 /* Reset definitions for later calls */
11178 #define gmtime(t)    my_gmtime(t)
11179 #define localtime(t) my_localtime(t)
11180 #define time(t)      my_time(t)
11181
11182
11183 /* my_utime - update modification/access time of a file
11184  *
11185  * VMS 7.3 and later implementation
11186  * Only the UTC translation is home-grown. The rest is handled by the
11187  * CRTL utime(), which will take into account the relevant feature
11188  * logicals and ODS-5 volume characteristics for true access times.
11189  *
11190  * pre VMS 7.3 implementation:
11191  * The calling sequence is identical to POSIX utime(), but under
11192  * VMS with ODS-2, only the modification time is changed; ODS-2 does
11193  * not maintain access times.  Restrictions differ from the POSIX
11194  * definition in that the time can be changed as long as the
11195  * caller has permission to execute the necessary IO$_MODIFY $QIO;
11196  * no separate checks are made to insure that the caller is the
11197  * owner of the file or has special privs enabled.
11198  * Code here is based on Joe Meadows' FILE utility.
11199  *
11200  */
11201
11202 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11203  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
11204  * in 100 ns intervals.
11205  */
11206 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11207
11208 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11209 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11210 {
11211 #if __CRTL_VER >= 70300000
11212   struct utimbuf utc_utimes, *utc_utimesp;
11213
11214   if (utimes != NULL) {
11215     utc_utimes.actime = utimes->actime;
11216     utc_utimes.modtime = utimes->modtime;
11217 # ifdef VMSISH_TIME
11218     /* If input was local; convert to UTC for sys svc */
11219     if (VMSISH_TIME) {
11220       utc_utimes.actime = _toutc(utimes->actime);
11221       utc_utimes.modtime = _toutc(utimes->modtime);
11222     }
11223 # endif
11224     utc_utimesp = &utc_utimes;
11225   }
11226   else {
11227     utc_utimesp = NULL;
11228   }
11229
11230   return utime(file, utc_utimesp);
11231
11232 #else /* __CRTL_VER < 70300000 */
11233
11234   register int i;
11235   int sts;
11236   long int bintime[2], len = 2, lowbit, unixtime,
11237            secscale = 10000000; /* seconds --> 100 ns intervals */
11238   unsigned long int chan, iosb[2], retsts;
11239   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11240   struct FAB myfab = cc$rms_fab;
11241   struct NAM mynam = cc$rms_nam;
11242 #if defined (__DECC) && defined (__VAX)
11243   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11244    * at least through VMS V6.1, which causes a type-conversion warning.
11245    */
11246 #  pragma message save
11247 #  pragma message disable cvtdiftypes
11248 #endif
11249   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11250   struct fibdef myfib;
11251 #if defined (__DECC) && defined (__VAX)
11252   /* This should be right after the declaration of myatr, but due
11253    * to a bug in VAX DEC C, this takes effect a statement early.
11254    */
11255 #  pragma message restore
11256 #endif
11257   /* cast ok for read only parameter */
11258   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11259                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11260                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
11261
11262   if (file == NULL || *file == '\0') {
11263     SETERRNO(ENOENT, LIB$_INVARG);
11264     return -1;
11265   }
11266
11267   /* Convert to VMS format ensuring that it will fit in 255 characters */
11268   if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
11269       SETERRNO(ENOENT, LIB$_INVARG);
11270       return -1;
11271   }
11272   if (utimes != NULL) {
11273     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
11274      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11275      * Since time_t is unsigned long int, and lib$emul takes a signed long int
11276      * as input, we force the sign bit to be clear by shifting unixtime right
11277      * one bit, then multiplying by an extra factor of 2 in lib$emul().
11278      */
11279     lowbit = (utimes->modtime & 1) ? secscale : 0;
11280     unixtime = (long int) utimes->modtime;
11281 #   ifdef VMSISH_TIME
11282     /* If input was UTC; convert to local for sys svc */
11283     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
11284 #   endif
11285     unixtime >>= 1;  secscale <<= 1;
11286     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11287     if (!(retsts & 1)) {
11288       SETERRNO(EVMSERR, retsts);
11289       return -1;
11290     }
11291     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11292     if (!(retsts & 1)) {
11293       SETERRNO(EVMSERR, retsts);
11294       return -1;
11295     }
11296   }
11297   else {
11298     /* Just get the current time in VMS format directly */
11299     retsts = sys$gettim(bintime);
11300     if (!(retsts & 1)) {
11301       SETERRNO(EVMSERR, retsts);
11302       return -1;
11303     }
11304   }
11305
11306   myfab.fab$l_fna = vmsspec;
11307   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11308   myfab.fab$l_nam = &mynam;
11309   mynam.nam$l_esa = esa;
11310   mynam.nam$b_ess = (unsigned char) sizeof esa;
11311   mynam.nam$l_rsa = rsa;
11312   mynam.nam$b_rss = (unsigned char) sizeof rsa;
11313   if (decc_efs_case_preserve)
11314       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
11315
11316   /* Look for the file to be affected, letting RMS parse the file
11317    * specification for us as well.  I have set errno using only
11318    * values documented in the utime() man page for VMS POSIX.
11319    */
11320   retsts = sys$parse(&myfab,0,0);
11321   if (!(retsts & 1)) {
11322     set_vaxc_errno(retsts);
11323     if      (retsts == RMS$_PRV) set_errno(EACCES);
11324     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11325     else                         set_errno(EVMSERR);
11326     return -1;
11327   }
11328   retsts = sys$search(&myfab,0,0);
11329   if (!(retsts & 1)) {
11330     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11331     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11332     set_vaxc_errno(retsts);
11333     if      (retsts == RMS$_PRV) set_errno(EACCES);
11334     else if (retsts == RMS$_FNF) set_errno(ENOENT);
11335     else                         set_errno(EVMSERR);
11336     return -1;
11337   }
11338
11339   devdsc.dsc$w_length = mynam.nam$b_dev;
11340   /* cast ok for read only parameter */
11341   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11342
11343   retsts = sys$assign(&devdsc,&chan,0,0);
11344   if (!(retsts & 1)) {
11345     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11346     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11347     set_vaxc_errno(retsts);
11348     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
11349     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
11350     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
11351     else                               set_errno(EVMSERR);
11352     return -1;
11353   }
11354
11355   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11356   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11357
11358   memset((void *) &myfib, 0, sizeof myfib);
11359 #if defined(__DECC) || defined(__DECCXX)
11360   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11361   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11362   /* This prevents the revision time of the file being reset to the current
11363    * time as a result of our IO$_MODIFY $QIO. */
11364   myfib.fib$l_acctl = FIB$M_NORECORD;
11365 #else
11366   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11367   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11368   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11369 #endif
11370   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
11371   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11372   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11373   _ckvmssts(sys$dassgn(chan));
11374   if (retsts & 1) retsts = iosb[0];
11375   if (!(retsts & 1)) {
11376     set_vaxc_errno(retsts);
11377     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11378     else                      set_errno(EVMSERR);
11379     return -1;
11380   }
11381
11382   return 0;
11383
11384 #endif /* #if __CRTL_VER >= 70300000 */
11385
11386 }  /* end of my_utime() */
11387 /*}}}*/
11388
11389 /*
11390  * flex_stat, flex_lstat, flex_fstat
11391  * basic stat, but gets it right when asked to stat
11392  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11393  */
11394
11395 #ifndef _USE_STD_STAT
11396 /* encode_dev packs a VMS device name string into an integer to allow
11397  * simple comparisons. This can be used, for example, to check whether two
11398  * files are located on the same device, by comparing their encoded device
11399  * names. Even a string comparison would not do, because stat() reuses the
11400  * device name buffer for each call; so without encode_dev, it would be
11401  * necessary to save the buffer and use strcmp (this would mean a number of
11402  * changes to the standard Perl code, to say nothing of what a Perl script
11403  * would have to do.
11404  *
11405  * The device lock id, if it exists, should be unique (unless perhaps compared
11406  * with lock ids transferred from other nodes). We have a lock id if the disk is
11407  * mounted cluster-wide, which is when we tend to get long (host-qualified)
11408  * device names. Thus we use the lock id in preference, and only if that isn't
11409  * available, do we try to pack the device name into an integer (flagged by
11410  * the sign bit (LOCKID_MASK) being set).
11411  *
11412  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11413  * name and its encoded form, but it seems very unlikely that we will find
11414  * two files on different disks that share the same encoded device names,
11415  * and even more remote that they will share the same file id (if the test
11416  * is to check for the same file).
11417  *
11418  * A better method might be to use sys$device_scan on the first call, and to
11419  * search for the device, returning an index into the cached array.
11420  * The number returned would be more intelligible.
11421  * This is probably not worth it, and anyway would take quite a bit longer
11422  * on the first call.
11423  */
11424 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
11425 static mydev_t encode_dev (pTHX_ const char *dev)
11426 {
11427   int i;
11428   unsigned long int f;
11429   mydev_t enc;
11430   char c;
11431   const char *q;
11432
11433   if (!dev || !dev[0]) return 0;
11434
11435 #if LOCKID_MASK
11436   {
11437     struct dsc$descriptor_s dev_desc;
11438     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11439
11440     /* For cluster-mounted disks, the disk lock identifier is unique, so we
11441        can try that first. */
11442     dev_desc.dsc$w_length =  strlen (dev);
11443     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
11444     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
11445     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
11446     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11447     if (!$VMS_STATUS_SUCCESS(status)) {
11448       switch (status) {
11449         case SS$_NOSUCHDEV:
11450           SETERRNO(ENODEV, status);
11451           return 0;
11452         default:
11453           _ckvmssts(status);
11454       }
11455     }
11456     if (lockid) return (lockid & ~LOCKID_MASK);
11457   }
11458 #endif
11459
11460   /* Otherwise we try to encode the device name */
11461   enc = 0;
11462   f = 1;
11463   i = 0;
11464   for (q = dev + strlen(dev); q--; q >= dev) {
11465     if (*q == ':')
11466         break;
11467     if (isdigit (*q))
11468       c= (*q) - '0';
11469     else if (isalpha (toupper (*q)))
11470       c= toupper (*q) - 'A' + (char)10;
11471     else
11472       continue; /* Skip '$'s */
11473     i++;
11474     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
11475     if (i>1) f *= 36;
11476     enc += f * (unsigned long int) c;
11477   }
11478   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
11479
11480 }  /* end of encode_dev() */
11481 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11482         device_no = encode_dev(aTHX_ devname)
11483 #else
11484 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11485         device_no = new_dev_no
11486 #endif
11487
11488 static int
11489 is_null_device(name)
11490     const char *name;
11491 {
11492   if (decc_bug_devnull != 0) {
11493     if (strncmp("/dev/null", name, 9) == 0)
11494       return 1;
11495   }
11496     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11497        The underscore prefix, controller letter, and unit number are
11498        independently optional; for our purposes, the colon punctuation
11499        is not.  The colon can be trailed by optional directory and/or
11500        filename, but two consecutive colons indicates a nodename rather
11501        than a device.  [pr]  */
11502   if (*name == '_') ++name;
11503   if (tolower(*name++) != 'n') return 0;
11504   if (tolower(*name++) != 'l') return 0;
11505   if (tolower(*name) == 'a') ++name;
11506   if (*name == '0') ++name;
11507   return (*name++ == ':') && (*name != ':');
11508 }
11509
11510
11511 static I32
11512 Perl_cando_by_name_int
11513    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
11514 {
11515   char usrname[L_cuserid];
11516   struct dsc$descriptor_s usrdsc =
11517          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11518   char *vmsname = NULL, *fileified = NULL;
11519   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11520   unsigned short int retlen, trnlnm_iter_count;
11521   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11522   union prvdef curprv;
11523   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11524          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11525          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11526   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11527          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11528          {0,0,0,0}};
11529   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11530          {0,0,0,0}};
11531   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11532   Stat_t st;
11533   static int profile_context = -1;
11534
11535   if (!fname || !*fname) return FALSE;
11536
11537   /* Make sure we expand logical names, since sys$check_access doesn't */
11538   fileified = PerlMem_malloc(VMS_MAXRSS);
11539   if (fileified == NULL) _ckvmssts(SS$_INSFMEM);
11540   if (!strpbrk(fname,"/]>:")) {
11541       strcpy(fileified,fname);
11542       trnlnm_iter_count = 0;
11543       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11544         trnlnm_iter_count++;
11545         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11546       }
11547       fname = fileified;
11548   }
11549
11550   vmsname = PerlMem_malloc(VMS_MAXRSS);
11551   if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
11552   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11553     /* Don't know if already in VMS format, so make sure */
11554     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11555       PerlMem_free(fileified);
11556       PerlMem_free(vmsname);
11557       return FALSE;
11558     }
11559   }
11560   else {
11561     strcpy(vmsname,fname);
11562   }
11563
11564   /* sys$check_access needs a file spec, not a directory spec.
11565    * Don't use flex_stat here, as that depends on thread context
11566    * having been initialized, and we may get here during startup.
11567    */
11568
11569   retlen = namdsc.dsc$w_length = strlen(vmsname);
11570   if (vmsname[retlen-1] == ']'
11571       || vmsname[retlen-1] == '>'
11572       || vmsname[retlen-1] == ':'
11573       || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
11574
11575       if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) {
11576         PerlMem_free(fileified);
11577         PerlMem_free(vmsname);
11578         return FALSE;
11579       }
11580       fname = fileified;
11581   }
11582   else {
11583       fname = vmsname;
11584   }
11585
11586   retlen = namdsc.dsc$w_length = strlen(fname);
11587   namdsc.dsc$a_pointer = (char *)fname;
11588
11589   switch (bit) {
11590     case S_IXUSR: case S_IXGRP: case S_IXOTH:
11591       access = ARM$M_EXECUTE;
11592       flags = CHP$M_READ;
11593       break;
11594     case S_IRUSR: case S_IRGRP: case S_IROTH:
11595       access = ARM$M_READ;
11596       flags = CHP$M_READ | CHP$M_USEREADALL;
11597       break;
11598     case S_IWUSR: case S_IWGRP: case S_IWOTH:
11599       access = ARM$M_WRITE;
11600       flags = CHP$M_READ | CHP$M_WRITE;
11601       break;
11602     case S_IDUSR: case S_IDGRP: case S_IDOTH:
11603       access = ARM$M_DELETE;
11604       flags = CHP$M_READ | CHP$M_WRITE;
11605       break;
11606     default:
11607       if (fileified != NULL)
11608         PerlMem_free(fileified);
11609       if (vmsname != NULL)
11610         PerlMem_free(vmsname);
11611       return FALSE;
11612   }
11613
11614   /* Before we call $check_access, create a user profile with the current
11615    * process privs since otherwise it just uses the default privs from the
11616    * UAF and might give false positives or negatives.  This only works on
11617    * VMS versions v6.0 and later since that's when sys$create_user_profile
11618    * became available.
11619    */
11620
11621   /* get current process privs and username */
11622   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11623   _ckvmssts(iosb[0]);
11624
11625 #if defined(__VMS_VER) && __VMS_VER >= 60000000
11626
11627   /* find out the space required for the profile */
11628   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11629                                     &usrprodsc.dsc$w_length,&profile_context));
11630
11631   /* allocate space for the profile and get it filled in */
11632   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11633   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
11634   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11635                                     &usrprodsc.dsc$w_length,&profile_context));
11636
11637   /* use the profile to check access to the file; free profile & analyze results */
11638   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
11639   PerlMem_free(usrprodsc.dsc$a_pointer);
11640   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11641
11642 #else
11643
11644   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11645
11646 #endif
11647
11648   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
11649       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11650       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11651     set_vaxc_errno(retsts);
11652     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11653     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11654     else set_errno(ENOENT);
11655     if (fileified != NULL)
11656       PerlMem_free(fileified);
11657     if (vmsname != NULL)
11658       PerlMem_free(vmsname);
11659     return FALSE;
11660   }
11661   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11662     if (fileified != NULL)
11663       PerlMem_free(fileified);
11664     if (vmsname != NULL)
11665       PerlMem_free(vmsname);
11666     return TRUE;
11667   }
11668   _ckvmssts(retsts);
11669
11670   if (fileified != NULL)
11671     PerlMem_free(fileified);
11672   if (vmsname != NULL)
11673     PerlMem_free(vmsname);
11674   return FALSE;  /* Should never get here */
11675
11676 }
11677
11678 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
11679 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11680  * subset of the applicable information.
11681  */
11682 bool
11683 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11684 {
11685   return cando_by_name_int
11686         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11687 }  /* end of cando() */
11688 /*}}}*/
11689
11690
11691 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11692 I32
11693 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11694 {
11695    return cando_by_name_int(bit, effective, fname, 0);
11696
11697 }  /* end of cando_by_name() */
11698 /*}}}*/
11699
11700
11701 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
11702 int
11703 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
11704 {
11705   if (!fstat(fd,(stat_t *) statbufp)) {
11706     char *cptr;
11707     char *vms_filename;
11708     vms_filename = PerlMem_malloc(VMS_MAXRSS);
11709     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
11710
11711     /* Save name for cando by name in VMS format */
11712     cptr = getname(fd, vms_filename, 1);
11713
11714     /* This should not happen, but just in case */
11715     if (cptr == NULL) {
11716         statbufp->st_devnam[0] = 0;
11717     }
11718     else {
11719         /* Make sure that the saved name fits in 255 characters */
11720         cptr = do_rmsexpand
11721                        (vms_filename,
11722                         statbufp->st_devnam,
11723                         0,
11724                         NULL,
11725                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
11726                         NULL,
11727                         NULL);
11728         if (cptr == NULL)
11729             statbufp->st_devnam[0] = 0;
11730     }
11731     PerlMem_free(vms_filename);
11732
11733     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11734     VMS_DEVICE_ENCODE
11735         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11736
11737 #   ifdef RTL_USES_UTC
11738 #   ifdef VMSISH_TIME
11739     if (VMSISH_TIME) {
11740       statbufp->st_mtime = _toloc(statbufp->st_mtime);
11741       statbufp->st_atime = _toloc(statbufp->st_atime);
11742       statbufp->st_ctime = _toloc(statbufp->st_ctime);
11743     }
11744 #   endif
11745 #   else
11746 #   ifdef VMSISH_TIME
11747     if (!VMSISH_TIME) { /* Return UTC instead of local time */
11748 #   else
11749     if (1) {
11750 #   endif
11751       statbufp->st_mtime = _toutc(statbufp->st_mtime);
11752       statbufp->st_atime = _toutc(statbufp->st_atime);
11753       statbufp->st_ctime = _toutc(statbufp->st_ctime);
11754     }
11755 #endif
11756     return 0;
11757   }
11758   return -1;
11759
11760 }  /* end of flex_fstat() */
11761 /*}}}*/
11762
11763 #if !defined(__VAX) && __CRTL_VER >= 80200000
11764 #ifdef lstat
11765 #undef lstat
11766 #endif
11767 #else
11768 #ifdef lstat
11769 #undef lstat
11770 #endif
11771 #define lstat(_x, _y) stat(_x, _y)
11772 #endif
11773
11774 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11775
11776 static int
11777 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
11778 {
11779     char fileified[VMS_MAXRSS];
11780     char temp_fspec[VMS_MAXRSS];
11781     char *save_spec;
11782     int retval = -1;
11783     int saved_errno, saved_vaxc_errno;
11784
11785     if (!fspec) return retval;
11786     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
11787     strcpy(temp_fspec, fspec);
11788
11789     if (decc_bug_devnull != 0) {
11790       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
11791         memset(statbufp,0,sizeof *statbufp);
11792         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
11793         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
11794         statbufp->st_uid = 0x00010001;
11795         statbufp->st_gid = 0x0001;
11796         time((time_t *)&statbufp->st_mtime);
11797         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
11798         return 0;
11799       }
11800     }
11801
11802     /* Try for a directory name first.  If fspec contains a filename without
11803      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
11804      * and sea:[wine.dark]water. exist, we prefer the directory here.
11805      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
11806      * not sea:[wine.dark]., if the latter exists.  If the intended target is
11807      * the file with null type, specify this by calling flex_stat() with
11808      * a '.' at the end of fspec.
11809      *
11810      * If we are in Posix filespec mode, accept the filename as is.
11811      */
11812
11813
11814 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11815   /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
11816    * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
11817    */
11818   if (!decc_efs_charset)
11819     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
11820 #endif
11821
11822 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11823   if (decc_posix_compliant_pathnames == 0) {
11824 #endif
11825     if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
11826       if (lstat_flag == 0)
11827         retval = stat(fileified,(stat_t *) statbufp);
11828       else
11829         retval = lstat(fileified,(stat_t *) statbufp);
11830       save_spec = fileified;
11831     }
11832     if (retval) {
11833       if (lstat_flag == 0)
11834         retval = stat(temp_fspec,(stat_t *) statbufp);
11835       else
11836         retval = lstat(temp_fspec,(stat_t *) statbufp);
11837       save_spec = temp_fspec;
11838     }
11839 /*
11840  * In debugging, on 8.3 Alpha, I found a case where stat was returning a
11841  * file not found error for a directory named foo:[bar.t] or /foo/bar/t
11842  * and lstat was working correctly for the same file.
11843  * The only syntax that was working for stat was "foo:[bar]t.dir".
11844  *
11845  * Other directories with the same syntax worked fine.
11846  * So work around the problem when it shows up here.
11847  */
11848     if (retval) {
11849         int save_errno = errno;
11850         if (do_tovmsspec(fspec, temp_fspec, 0, NULL) != NULL) {
11851             if (do_fileify_dirspec(temp_fspec, fileified, 0, NULL) != NULL) {
11852                 retval = stat(fileified, (stat_t *) statbufp);
11853                 save_spec = fileified;
11854             }
11855         }
11856         /* Restore the errno value if third stat does not succeed */
11857         if (retval != 0)
11858             errno = save_errno;
11859     }
11860 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11861   } else {
11862     if (lstat_flag == 0)
11863       retval = stat(temp_fspec,(stat_t *) statbufp);
11864     else
11865       retval = lstat(temp_fspec,(stat_t *) statbufp);
11866       save_spec = temp_fspec;
11867   }
11868 #endif
11869
11870 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11871   /* As you were... */
11872   if (!decc_efs_charset)
11873     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
11874 #endif
11875
11876     if (!retval) {
11877     char * cptr;
11878       cptr = do_rmsexpand
11879        (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
11880       if (cptr == NULL)
11881         statbufp->st_devnam[0] = 0;
11882
11883       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11884       VMS_DEVICE_ENCODE
11885         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11886 #     ifdef RTL_USES_UTC
11887 #     ifdef VMSISH_TIME
11888       if (VMSISH_TIME) {
11889         statbufp->st_mtime = _toloc(statbufp->st_mtime);
11890         statbufp->st_atime = _toloc(statbufp->st_atime);
11891         statbufp->st_ctime = _toloc(statbufp->st_ctime);
11892       }
11893 #     endif
11894 #     else
11895 #     ifdef VMSISH_TIME
11896       if (!VMSISH_TIME) { /* Return UTC instead of local time */
11897 #     else
11898       if (1) {
11899 #     endif
11900         statbufp->st_mtime = _toutc(statbufp->st_mtime);
11901         statbufp->st_atime = _toutc(statbufp->st_atime);
11902         statbufp->st_ctime = _toutc(statbufp->st_ctime);
11903       }
11904 #     endif
11905     }
11906     /* If we were successful, leave errno where we found it */
11907     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
11908     return retval;
11909
11910 }  /* end of flex_stat_int() */
11911
11912
11913 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
11914 int
11915 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
11916 {
11917    return flex_stat_int(fspec, statbufp, 0);
11918 }
11919 /*}}}*/
11920
11921 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
11922 int
11923 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
11924 {
11925    return flex_stat_int(fspec, statbufp, 1);
11926 }
11927 /*}}}*/
11928
11929
11930 /*{{{char *my_getlogin()*/
11931 /* VMS cuserid == Unix getlogin, except calling sequence */
11932 char *
11933 my_getlogin(void)
11934 {
11935     static char user[L_cuserid];
11936     return cuserid(user);
11937 }
11938 /*}}}*/
11939
11940
11941 /*  rmscopy - copy a file using VMS RMS routines
11942  *
11943  *  Copies contents and attributes of spec_in to spec_out, except owner
11944  *  and protection information.  Name and type of spec_in are used as
11945  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
11946  *  should try to propagate timestamps from the input file to the output file.
11947  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
11948  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
11949  *  propagated to the output file at creation iff the output file specification
11950  *  did not contain an explicit name or type, and the revision date is always
11951  *  updated at the end of the copy operation.  If it is greater than 0, then
11952  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
11953  *  other than the revision date should be propagated, and bit 1 indicates
11954  *  that the revision date should be propagated.
11955  *
11956  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
11957  *
11958  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
11959  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
11960  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
11961  * as part of the Perl standard distribution under the terms of the
11962  * GNU General Public License or the Perl Artistic License.  Copies
11963  * of each may be found in the Perl standard distribution.
11964  */ /* FIXME */
11965 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
11966 int
11967 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
11968 {
11969     char *vmsin, * vmsout, *esa, *esa_out,
11970          *rsa, *ubf;
11971     unsigned long int i, sts, sts2;
11972     int dna_len;
11973     struct FAB fab_in, fab_out;
11974     struct RAB rab_in, rab_out;
11975     rms_setup_nam(nam);
11976     rms_setup_nam(nam_out);
11977     struct XABDAT xabdat;
11978     struct XABFHC xabfhc;
11979     struct XABRDT xabrdt;
11980     struct XABSUM xabsum;
11981
11982     vmsin = PerlMem_malloc(VMS_MAXRSS);
11983     if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
11984     vmsout = PerlMem_malloc(VMS_MAXRSS);
11985     if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
11986     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
11987         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
11988       PerlMem_free(vmsin);
11989       PerlMem_free(vmsout);
11990       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11991       return 0;
11992     }
11993
11994     esa = PerlMem_malloc(VMS_MAXRSS);
11995     if (esa == NULL) _ckvmssts(SS$_INSFMEM);
11996     fab_in = cc$rms_fab;
11997     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
11998     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
11999     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12000     fab_in.fab$l_fop = FAB$M_SQO;
12001     rms_bind_fab_nam(fab_in, nam);
12002     fab_in.fab$l_xab = (void *) &xabdat;
12003
12004     rsa = PerlMem_malloc(VMS_MAXRSS);
12005     if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
12006     rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
12007     rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
12008     rms_nam_esl(nam) = 0;
12009     rms_nam_rsl(nam) = 0;
12010     rms_nam_esll(nam) = 0;
12011     rms_nam_rsll(nam) = 0;
12012 #ifdef NAM$M_NO_SHORT_UPCASE
12013     if (decc_efs_case_preserve)
12014         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12015 #endif
12016
12017     xabdat = cc$rms_xabdat;        /* To get creation date */
12018     xabdat.xab$l_nxt = (void *) &xabfhc;
12019
12020     xabfhc = cc$rms_xabfhc;        /* To get record length */
12021     xabfhc.xab$l_nxt = (void *) &xabsum;
12022
12023     xabsum = cc$rms_xabsum;        /* To get key and area information */
12024
12025     if (!((sts = sys$open(&fab_in)) & 1)) {
12026       PerlMem_free(vmsin);
12027       PerlMem_free(vmsout);
12028       PerlMem_free(esa);
12029       PerlMem_free(rsa);
12030       set_vaxc_errno(sts);
12031       switch (sts) {
12032         case RMS$_FNF: case RMS$_DNF:
12033           set_errno(ENOENT); break;
12034         case RMS$_DIR:
12035           set_errno(ENOTDIR); break;
12036         case RMS$_DEV:
12037           set_errno(ENODEV); break;
12038         case RMS$_SYN:
12039           set_errno(EINVAL); break;
12040         case RMS$_PRV:
12041           set_errno(EACCES); break;
12042         default:
12043           set_errno(EVMSERR);
12044       }
12045       return 0;
12046     }
12047
12048     nam_out = nam;
12049     fab_out = fab_in;
12050     fab_out.fab$w_ifi = 0;
12051     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12052     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12053     fab_out.fab$l_fop = FAB$M_SQO;
12054     rms_bind_fab_nam(fab_out, nam_out);
12055     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12056     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12057     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12058     esa_out = PerlMem_malloc(VMS_MAXRSS);
12059     if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
12060     rms_set_rsa(nam_out, NULL, 0);
12061     rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
12062
12063     if (preserve_dates == 0) {  /* Act like DCL COPY */
12064       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12065       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
12066       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12067         PerlMem_free(vmsin);
12068         PerlMem_free(vmsout);
12069         PerlMem_free(esa);
12070         PerlMem_free(rsa);
12071         PerlMem_free(esa_out);
12072         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12073         set_vaxc_errno(sts);
12074         return 0;
12075       }
12076       fab_out.fab$l_xab = (void *) &xabdat;
12077       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12078         preserve_dates = 1;
12079     }
12080     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
12081       preserve_dates =0;      /* bitmask from this point forward   */
12082
12083     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12084     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12085       PerlMem_free(vmsin);
12086       PerlMem_free(vmsout);
12087       PerlMem_free(esa);
12088       PerlMem_free(rsa);
12089       PerlMem_free(esa_out);
12090       set_vaxc_errno(sts);
12091       switch (sts) {
12092         case RMS$_DNF:
12093           set_errno(ENOENT); break;
12094         case RMS$_DIR:
12095           set_errno(ENOTDIR); break;
12096         case RMS$_DEV:
12097           set_errno(ENODEV); break;
12098         case RMS$_SYN:
12099           set_errno(EINVAL); break;
12100         case RMS$_PRV:
12101           set_errno(EACCES); break;
12102         default:
12103           set_errno(EVMSERR);
12104       }
12105       return 0;
12106     }
12107     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
12108     if (preserve_dates & 2) {
12109       /* sys$close() will process xabrdt, not xabdat */
12110       xabrdt = cc$rms_xabrdt;
12111 #ifndef __GNUC__
12112       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12113 #else
12114       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12115        * is unsigned long[2], while DECC & VAXC use a struct */
12116       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12117 #endif
12118       fab_out.fab$l_xab = (void *) &xabrdt;
12119     }
12120
12121     ubf = PerlMem_malloc(32256);
12122     if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
12123     rab_in = cc$rms_rab;
12124     rab_in.rab$l_fab = &fab_in;
12125     rab_in.rab$l_rop = RAB$M_BIO;
12126     rab_in.rab$l_ubf = ubf;
12127     rab_in.rab$w_usz = 32256;
12128     if (!((sts = sys$connect(&rab_in)) & 1)) {
12129       sys$close(&fab_in); sys$close(&fab_out);
12130       PerlMem_free(vmsin);
12131       PerlMem_free(vmsout);
12132       PerlMem_free(esa);
12133       PerlMem_free(ubf);
12134       PerlMem_free(rsa);
12135       PerlMem_free(esa_out);
12136       set_errno(EVMSERR); set_vaxc_errno(sts);
12137       return 0;
12138     }
12139
12140     rab_out = cc$rms_rab;
12141     rab_out.rab$l_fab = &fab_out;
12142     rab_out.rab$l_rbf = ubf;
12143     if (!((sts = sys$connect(&rab_out)) & 1)) {
12144       sys$close(&fab_in); sys$close(&fab_out);
12145       PerlMem_free(vmsin);
12146       PerlMem_free(vmsout);
12147       PerlMem_free(esa);
12148       PerlMem_free(ubf);
12149       PerlMem_free(rsa);
12150       PerlMem_free(esa_out);
12151       set_errno(EVMSERR); set_vaxc_errno(sts);
12152       return 0;
12153     }
12154
12155     while ((sts = sys$read(&rab_in))) {  /* always true  */
12156       if (sts == RMS$_EOF) break;
12157       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12158       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12159         sys$close(&fab_in); sys$close(&fab_out);
12160         PerlMem_free(vmsin);
12161         PerlMem_free(vmsout);
12162         PerlMem_free(esa);
12163         PerlMem_free(ubf);
12164         PerlMem_free(rsa);
12165         PerlMem_free(esa_out);
12166         set_errno(EVMSERR); set_vaxc_errno(sts);
12167         return 0;
12168       }
12169     }
12170
12171
12172     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
12173     sys$close(&fab_in);  sys$close(&fab_out);
12174     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12175     if (!(sts & 1)) {
12176       PerlMem_free(vmsin);
12177       PerlMem_free(vmsout);
12178       PerlMem_free(esa);
12179       PerlMem_free(ubf);
12180       PerlMem_free(rsa);
12181       PerlMem_free(esa_out);
12182       set_errno(EVMSERR); set_vaxc_errno(sts);
12183       return 0;
12184     }
12185
12186     PerlMem_free(vmsin);
12187     PerlMem_free(vmsout);
12188     PerlMem_free(esa);
12189     PerlMem_free(ubf);
12190     PerlMem_free(rsa);
12191     PerlMem_free(esa_out);
12192     return 1;
12193
12194 }  /* end of rmscopy() */
12195 /*}}}*/
12196
12197
12198 /***  The following glue provides 'hooks' to make some of the routines
12199  * from this file available from Perl.  These routines are sufficiently
12200  * basic, and are required sufficiently early in the build process,
12201  * that's it's nice to have them available to miniperl as well as the
12202  * full Perl, so they're set up here instead of in an extension.  The
12203  * Perl code which handles importation of these names into a given
12204  * package lives in [.VMS]Filespec.pm in @INC.
12205  */
12206
12207 void
12208 rmsexpand_fromperl(pTHX_ CV *cv)
12209 {
12210   dXSARGS;
12211   char *fspec, *defspec = NULL, *rslt;
12212   STRLEN n_a;
12213   int fs_utf8, dfs_utf8;
12214
12215   fs_utf8 = 0;
12216   dfs_utf8 = 0;
12217   if (!items || items > 2)
12218     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12219   fspec = SvPV(ST(0),n_a);
12220   fs_utf8 = SvUTF8(ST(0));
12221   if (!fspec || !*fspec) XSRETURN_UNDEF;
12222   if (items == 2) {
12223     defspec = SvPV(ST(1),n_a);
12224     dfs_utf8 = SvUTF8(ST(1));
12225   }
12226   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12227   ST(0) = sv_newmortal();
12228   if (rslt != NULL) {
12229     sv_usepvn(ST(0),rslt,strlen(rslt));
12230     if (fs_utf8) {
12231         SvUTF8_on(ST(0));
12232     }
12233   }
12234   XSRETURN(1);
12235 }
12236
12237 void
12238 vmsify_fromperl(pTHX_ CV *cv)
12239 {
12240   dXSARGS;
12241   char *vmsified;
12242   STRLEN n_a;
12243   int utf8_fl;
12244
12245   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12246   utf8_fl = SvUTF8(ST(0));
12247   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12248   ST(0) = sv_newmortal();
12249   if (vmsified != NULL) {
12250     sv_usepvn(ST(0),vmsified,strlen(vmsified));
12251     if (utf8_fl) {
12252         SvUTF8_on(ST(0));
12253     }
12254   }
12255   XSRETURN(1);
12256 }
12257
12258 void
12259 unixify_fromperl(pTHX_ CV *cv)
12260 {
12261   dXSARGS;
12262   char *unixified;
12263   STRLEN n_a;
12264   int utf8_fl;
12265
12266   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12267   utf8_fl = SvUTF8(ST(0));
12268   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12269   ST(0) = sv_newmortal();
12270   if (unixified != NULL) {
12271     sv_usepvn(ST(0),unixified,strlen(unixified));
12272     if (utf8_fl) {
12273         SvUTF8_on(ST(0));
12274     }
12275   }
12276   XSRETURN(1);
12277 }
12278
12279 void
12280 fileify_fromperl(pTHX_ CV *cv)
12281 {
12282   dXSARGS;
12283   char *fileified;
12284   STRLEN n_a;
12285   int utf8_fl;
12286
12287   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12288   utf8_fl = SvUTF8(ST(0));
12289   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12290   ST(0) = sv_newmortal();
12291   if (fileified != NULL) {
12292     sv_usepvn(ST(0),fileified,strlen(fileified));
12293     if (utf8_fl) {
12294         SvUTF8_on(ST(0));
12295     }
12296   }
12297   XSRETURN(1);
12298 }
12299
12300 void
12301 pathify_fromperl(pTHX_ CV *cv)
12302 {
12303   dXSARGS;
12304   char *pathified;
12305   STRLEN n_a;
12306   int utf8_fl;
12307
12308   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12309   utf8_fl = SvUTF8(ST(0));
12310   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12311   ST(0) = sv_newmortal();
12312   if (pathified != NULL) {
12313     sv_usepvn(ST(0),pathified,strlen(pathified));
12314     if (utf8_fl) {
12315         SvUTF8_on(ST(0));
12316     }
12317   }
12318   XSRETURN(1);
12319 }
12320
12321 void
12322 vmspath_fromperl(pTHX_ CV *cv)
12323 {
12324   dXSARGS;
12325   char *vmspath;
12326   STRLEN n_a;
12327   int utf8_fl;
12328
12329   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12330   utf8_fl = SvUTF8(ST(0));
12331   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12332   ST(0) = sv_newmortal();
12333   if (vmspath != NULL) {
12334     sv_usepvn(ST(0),vmspath,strlen(vmspath));
12335     if (utf8_fl) {
12336         SvUTF8_on(ST(0));
12337     }
12338   }
12339   XSRETURN(1);
12340 }
12341
12342 void
12343 unixpath_fromperl(pTHX_ CV *cv)
12344 {
12345   dXSARGS;
12346   char *unixpath;
12347   STRLEN n_a;
12348   int utf8_fl;
12349
12350   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12351   utf8_fl = SvUTF8(ST(0));
12352   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12353   ST(0) = sv_newmortal();
12354   if (unixpath != NULL) {
12355     sv_usepvn(ST(0),unixpath,strlen(unixpath));
12356     if (utf8_fl) {
12357         SvUTF8_on(ST(0));
12358     }
12359   }
12360   XSRETURN(1);
12361 }
12362
12363 void
12364 candelete_fromperl(pTHX_ CV *cv)
12365 {
12366   dXSARGS;
12367   char *fspec, *fsp;
12368   SV *mysv;
12369   IO *io;
12370   STRLEN n_a;
12371
12372   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12373
12374   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12375   Newx(fspec, VMS_MAXRSS, char);
12376   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12377   if (SvTYPE(mysv) == SVt_PVGV) {
12378     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12379       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12380       ST(0) = &PL_sv_no;
12381       Safefree(fspec);
12382       XSRETURN(1);
12383     }
12384     fsp = fspec;
12385   }
12386   else {
12387     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12388       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12389       ST(0) = &PL_sv_no;
12390       Safefree(fspec);
12391       XSRETURN(1);
12392     }
12393   }
12394
12395   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12396   Safefree(fspec);
12397   XSRETURN(1);
12398 }
12399
12400 void
12401 rmscopy_fromperl(pTHX_ CV *cv)
12402 {
12403   dXSARGS;
12404   char *inspec, *outspec, *inp, *outp;
12405   int date_flag;
12406   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
12407                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12408   unsigned long int sts;
12409   SV *mysv;
12410   IO *io;
12411   STRLEN n_a;
12412
12413   if (items < 2 || items > 3)
12414     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12415
12416   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12417   Newx(inspec, VMS_MAXRSS, char);
12418   if (SvTYPE(mysv) == SVt_PVGV) {
12419     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12420       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12421       ST(0) = &PL_sv_no;
12422       Safefree(inspec);
12423       XSRETURN(1);
12424     }
12425     inp = inspec;
12426   }
12427   else {
12428     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12429       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12430       ST(0) = &PL_sv_no;
12431       Safefree(inspec);
12432       XSRETURN(1);
12433     }
12434   }
12435   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12436   Newx(outspec, VMS_MAXRSS, char);
12437   if (SvTYPE(mysv) == SVt_PVGV) {
12438     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12439       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12440       ST(0) = &PL_sv_no;
12441       Safefree(inspec);
12442       Safefree(outspec);
12443       XSRETURN(1);
12444     }
12445     outp = outspec;
12446   }
12447   else {
12448     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12449       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12450       ST(0) = &PL_sv_no;
12451       Safefree(inspec);
12452       Safefree(outspec);
12453       XSRETURN(1);
12454     }
12455   }
12456   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12457
12458   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
12459   Safefree(inspec);
12460   Safefree(outspec);
12461   XSRETURN(1);
12462 }
12463
12464 /* The mod2fname is limited to shorter filenames by design, so it should
12465  * not be modified to support longer EFS pathnames
12466  */
12467 void
12468 mod2fname(pTHX_ CV *cv)
12469 {
12470   dXSARGS;
12471   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12472        workbuff[NAM$C_MAXRSS*1 + 1];
12473   int total_namelen = 3, counter, num_entries;
12474   /* ODS-5 ups this, but we want to be consistent, so... */
12475   int max_name_len = 39;
12476   AV *in_array = (AV *)SvRV(ST(0));
12477
12478   num_entries = av_len(in_array);
12479
12480   /* All the names start with PL_. */
12481   strcpy(ultimate_name, "PL_");
12482
12483   /* Clean up our working buffer */
12484   Zero(work_name, sizeof(work_name), char);
12485
12486   /* Run through the entries and build up a working name */
12487   for(counter = 0; counter <= num_entries; counter++) {
12488     /* If it's not the first name then tack on a __ */
12489     if (counter) {
12490       strcat(work_name, "__");
12491     }
12492     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
12493                            PL_na));
12494   }
12495
12496   /* Check to see if we actually have to bother...*/
12497   if (strlen(work_name) + 3 <= max_name_len) {
12498     strcat(ultimate_name, work_name);
12499   } else {
12500     /* It's too darned big, so we need to go strip. We use the same */
12501     /* algorithm as xsubpp does. First, strip out doubled __ */
12502     char *source, *dest, last;
12503     dest = workbuff;
12504     last = 0;
12505     for (source = work_name; *source; source++) {
12506       if (last == *source && last == '_') {
12507         continue;
12508       }
12509       *dest++ = *source;
12510       last = *source;
12511     }
12512     /* Go put it back */
12513     strcpy(work_name, workbuff);
12514     /* Is it still too big? */
12515     if (strlen(work_name) + 3 > max_name_len) {
12516       /* Strip duplicate letters */
12517       last = 0;
12518       dest = workbuff;
12519       for (source = work_name; *source; source++) {
12520         if (last == toupper(*source)) {
12521         continue;
12522         }
12523         *dest++ = *source;
12524         last = toupper(*source);
12525       }
12526       strcpy(work_name, workbuff);
12527     }
12528
12529     /* Is it *still* too big? */
12530     if (strlen(work_name) + 3 > max_name_len) {
12531       /* Too bad, we truncate */
12532       work_name[max_name_len - 2] = 0;
12533     }
12534     strcat(ultimate_name, work_name);
12535   }
12536
12537   /* Okay, return it */
12538   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
12539   XSRETURN(1);
12540 }
12541
12542 void
12543 hushexit_fromperl(pTHX_ CV *cv)
12544 {
12545     dXSARGS;
12546
12547     if (items > 0) {
12548         VMSISH_HUSHED = SvTRUE(ST(0));
12549     }
12550     ST(0) = boolSV(VMSISH_HUSHED);
12551     XSRETURN(1);
12552 }
12553
12554
12555 PerlIO *
12556 Perl_vms_start_glob
12557    (pTHX_ SV *tmpglob,
12558     IO *io)
12559 {
12560     PerlIO *fp;
12561     struct vs_str_st *rslt;
12562     char *vmsspec;
12563     char *rstr;
12564     char *begin, *cp;
12565     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
12566     PerlIO *tmpfp;
12567     STRLEN i;
12568     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12569     struct dsc$descriptor_vs rsdsc;
12570     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
12571     unsigned long hasver = 0, isunix = 0;
12572     unsigned long int lff_flags = 0;
12573     int rms_sts;
12574
12575 #ifdef VMS_LONGNAME_SUPPORT
12576     lff_flags = LIB$M_FIL_LONG_NAMES;
12577 #endif
12578     /* The Newx macro will not allow me to assign a smaller array
12579      * to the rslt pointer, so we will assign it to the begin char pointer
12580      * and then copy the value into the rslt pointer.
12581      */
12582     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
12583     rslt = (struct vs_str_st *)begin;
12584     rslt->length = 0;
12585     rstr = &rslt->str[0];
12586     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
12587     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
12588     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
12589     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
12590
12591     Newx(vmsspec, VMS_MAXRSS, char);
12592
12593         /* We could find out if there's an explicit dev/dir or version
12594            by peeking into lib$find_file's internal context at
12595            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
12596            but that's unsupported, so I don't want to do it now and
12597            have it bite someone in the future. */
12598         /* Fix-me: vms_split_path() is the only way to do this, the
12599            existing method will fail with many legal EFS or UNIX specifications
12600          */
12601
12602     cp = SvPV(tmpglob,i);
12603
12604     for (; i; i--) {
12605         if (cp[i] == ';') hasver = 1;
12606         if (cp[i] == '.') {
12607             if (sts) hasver = 1;
12608             else sts = 1;
12609         }
12610         if (cp[i] == '/') {
12611             hasdir = isunix = 1;
12612             break;
12613         }
12614         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
12615             hasdir = 1;
12616             break;
12617         }
12618     }
12619     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
12620         int found = 0;
12621         Stat_t st;
12622         int stat_sts;
12623         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
12624         if (!stat_sts && S_ISDIR(st.st_mode)) {
12625             wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
12626             ok = (wilddsc.dsc$a_pointer != NULL);
12627             /* maybe passed 'foo' rather than '[.foo]', thus not detected above */
12628             hasdir = 1;
12629         }
12630         else {
12631             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
12632             ok = (wilddsc.dsc$a_pointer != NULL);
12633         }
12634         if (ok)
12635             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
12636
12637         /* If not extended character set, replace ? with % */
12638         /* With extended character set, ? is a wildcard single character */
12639         if (!decc_efs_case_preserve) {
12640             for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
12641                 if (*cp == '?') *cp = '%';
12642         }
12643         sts = SS$_NORMAL;
12644         while (ok && $VMS_STATUS_SUCCESS(sts)) {
12645          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
12646          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
12647
12648             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
12649                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
12650             if (!$VMS_STATUS_SUCCESS(sts))
12651                 break;
12652
12653             found++;
12654
12655             /* with varying string, 1st word of buffer contains result length */
12656             rstr[rslt->length] = '\0';
12657
12658              /* Find where all the components are */
12659              v_sts = vms_split_path
12660                        (rstr,
12661                         &v_spec,
12662                         &v_len,
12663                         &r_spec,
12664                         &r_len,
12665                         &d_spec,
12666                         &d_len,
12667                         &n_spec,
12668                         &n_len,
12669                         &e_spec,
12670                         &e_len,
12671                         &vs_spec,
12672                         &vs_len);
12673
12674             /* If no version on input, truncate the version on output */
12675             if (!hasver && (vs_len > 0)) {
12676                 *vs_spec = '\0';
12677                 vs_len = 0;
12678
12679                 /* No version & a null extension on UNIX handling */
12680                 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
12681                     e_len = 0;
12682                     *e_spec = '\0';
12683                 }
12684             }
12685
12686             if (!decc_efs_case_preserve) {
12687                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
12688             }
12689
12690             if (hasdir) {
12691                 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
12692                 begin = rstr;
12693             }
12694             else {
12695                 /* Start with the name */
12696                 begin = n_spec;
12697             }
12698             strcat(begin,"\n");
12699             ok = (PerlIO_puts(tmpfp,begin) != EOF);
12700         }
12701         if (cxt) (void)lib$find_file_end(&cxt);
12702
12703         if (!found) {
12704             /* Be POSIXish: return the input pattern when no matches */
12705             begin = SvPVX(tmpglob);
12706             strcat(begin,"\n");
12707             ok = (PerlIO_puts(tmpfp,begin) != EOF);
12708         }
12709
12710         if (ok && sts != RMS$_NMF &&
12711             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
12712         if (!ok) {
12713             if (!(sts & 1)) {
12714                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
12715             }
12716             PerlIO_close(tmpfp);
12717             fp = NULL;
12718         }
12719         else {
12720             PerlIO_rewind(tmpfp);
12721             IoTYPE(io) = IoTYPE_RDONLY;
12722             IoIFP(io) = fp = tmpfp;
12723             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
12724         }
12725     }
12726     Safefree(vmsspec);
12727     Safefree(rslt);
12728     return fp;
12729 }
12730
12731
12732 #ifdef HAS_SYMLINK
12733 static char *
12734 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
12735                    const int *utf8_fl);
12736
12737 void
12738 vms_realpath_fromperl(pTHX_ CV *cv)
12739 {
12740   dXSARGS;
12741   char *fspec, *rslt_spec, *rslt;
12742   STRLEN n_a;
12743
12744   if (!items || items != 1)
12745     Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
12746
12747   fspec = SvPV(ST(0),n_a);
12748   if (!fspec || !*fspec) XSRETURN_UNDEF;
12749
12750   Newx(rslt_spec, VMS_MAXRSS + 1, char);
12751   rslt = do_vms_realpath(fspec, rslt_spec, NULL);
12752   ST(0) = sv_newmortal();
12753   if (rslt != NULL)
12754     sv_usepvn(ST(0),rslt,strlen(rslt));
12755   else
12756     Safefree(rslt_spec);
12757   XSRETURN(1);
12758 }
12759
12760 /*
12761  * A thin wrapper around decc$symlink to make sure we follow the
12762  * standard and do not create a symlink with a zero-length name.
12763  */
12764 /*{{{ int my_symlink(const char *path1, const char *path2)*/
12765 int my_symlink(const char *path1, const char *path2) {
12766   if (!path2 || !*path2) {
12767     SETERRNO(ENOENT, SS$_NOSUCHFILE);
12768     return -1;
12769   }
12770   return symlink(path1, path2);
12771 }
12772 /*}}}*/
12773
12774 #endif /* HAS_SYMLINK */
12775
12776 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12777 int do_vms_case_tolerant(void);
12778
12779 void
12780 vms_case_tolerant_fromperl(pTHX_ CV *cv)
12781 {
12782   dXSARGS;
12783   ST(0) = boolSV(do_vms_case_tolerant());
12784   XSRETURN(1);
12785 }
12786 #endif
12787
12788 void
12789 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
12790                           struct interp_intern *dst)
12791 {
12792     memcpy(dst,src,sizeof(struct interp_intern));
12793 }
12794
12795 void
12796 Perl_sys_intern_clear(pTHX)
12797 {
12798 }
12799
12800 void
12801 Perl_sys_intern_init(pTHX)
12802 {
12803     unsigned int ix = RAND_MAX;
12804     double x;
12805
12806     VMSISH_HUSHED = 0;
12807
12808     /* fix me later to track running under GNV */
12809     /* this allows some limited testing */
12810     MY_POSIX_EXIT = decc_filename_unix_report;
12811
12812     x = (float)ix;
12813     MY_INV_RAND_MAX = 1./x;
12814 }
12815
12816 void
12817 init_os_extras(void)
12818 {
12819   dTHX;
12820   char* file = __FILE__;
12821   if (decc_disable_to_vms_logname_translation) {
12822     no_translate_barewords = TRUE;
12823   } else {
12824     no_translate_barewords = FALSE;
12825   }
12826
12827   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
12828   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
12829   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
12830   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
12831   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
12832   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
12833   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
12834   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
12835   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
12836   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
12837   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
12838 #ifdef HAS_SYMLINK
12839   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
12840 #endif
12841 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12842   newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
12843 #endif
12844
12845   store_pipelocs(aTHX);         /* will redo any earlier attempts */
12846
12847   return;
12848 }
12849
12850 #ifdef HAS_SYMLINK
12851
12852 #if __CRTL_VER == 80200000
12853 /* This missed getting in to the DECC SDK for 8.2 */
12854 char *realpath(const char *file_name, char * resolved_name, ...);
12855 #endif
12856
12857 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
12858 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
12859  * The perl fallback routine to provide realpath() is not as efficient
12860  * on OpenVMS.
12861  */
12862 static char *
12863 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
12864                    const int *utf8_fl)
12865 {
12866     return realpath(filespec, outbuf);
12867 }
12868
12869 /*}}}*/
12870 /* External entry points */
12871 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12872 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
12873 #else
12874 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12875 { return NULL; }
12876 #endif
12877
12878
12879 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12880 /* case_tolerant */
12881
12882 /*{{{int do_vms_case_tolerant(void)*/
12883 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
12884  * controlled by a process setting.
12885  */
12886 int do_vms_case_tolerant(void)
12887 {
12888     return vms_process_case_tolerant;
12889 }
12890 /*}}}*/
12891 /* External entry points */
12892 int Perl_vms_case_tolerant(void)
12893 { return do_vms_case_tolerant(); }
12894 #else
12895 int Perl_vms_case_tolerant(void)
12896 { return vms_process_case_tolerant; }
12897 #endif
12898
12899
12900  /* Start of DECC RTL Feature handling */
12901
12902 static int sys_trnlnm
12903    (const char * logname,
12904     char * value,
12905     int value_len)
12906 {
12907     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
12908     const unsigned long attr = LNM$M_CASE_BLIND;
12909     struct dsc$descriptor_s name_dsc;
12910     int status;
12911     unsigned short result;
12912     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
12913                                 {0, 0, 0, 0}};
12914
12915     name_dsc.dsc$w_length = strlen(logname);
12916     name_dsc.dsc$a_pointer = (char *)logname;
12917     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12918     name_dsc.dsc$b_class = DSC$K_CLASS_S;
12919
12920     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
12921
12922     if ($VMS_STATUS_SUCCESS(status)) {
12923
12924          /* Null terminate and return the string */
12925         /*--------------------------------------*/
12926         value[result] = 0;
12927     }
12928
12929     return status;
12930 }
12931
12932 static int sys_crelnm
12933    (const char * logname,
12934     const char * value)
12935 {
12936     int ret_val;
12937     const char * proc_table = "LNM$PROCESS_TABLE";
12938     struct dsc$descriptor_s proc_table_dsc;
12939     struct dsc$descriptor_s logname_dsc;
12940     struct itmlst_3 item_list[2];
12941
12942     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
12943     proc_table_dsc.dsc$w_length = strlen(proc_table);
12944     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12945     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
12946
12947     logname_dsc.dsc$a_pointer = (char *) logname;
12948     logname_dsc.dsc$w_length = strlen(logname);
12949     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12950     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
12951
12952     item_list[0].buflen = strlen(value);
12953     item_list[0].itmcode = LNM$_STRING;
12954     item_list[0].bufadr = (char *)value;
12955     item_list[0].retlen = NULL;
12956
12957     item_list[1].buflen = 0;
12958     item_list[1].itmcode = 0;
12959
12960     ret_val = sys$crelnm
12961                        (NULL,
12962                         (const struct dsc$descriptor_s *)&proc_table_dsc,
12963                         (const struct dsc$descriptor_s *)&logname_dsc,
12964                         NULL,
12965                         (const struct item_list_3 *) item_list);
12966
12967     return ret_val;
12968 }
12969
12970 /* C RTL Feature settings */
12971
12972 static int set_features
12973    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
12974     int (* cli_routine)(void),  /* Not documented */
12975     void *image_info)           /* Not documented */
12976 {
12977     int status;
12978     int s;
12979     int dflt;
12980     char* str;
12981     char val_str[10];
12982 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12983     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
12984     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
12985     unsigned long case_perm;
12986     unsigned long case_image;
12987 #endif
12988
12989     /* Allow an exception to bring Perl into the VMS debugger */
12990     vms_debug_on_exception = 0;
12991     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
12992     if ($VMS_STATUS_SUCCESS(status)) {
12993        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12994          vms_debug_on_exception = 1;
12995        else
12996          vms_debug_on_exception = 0;
12997     }
12998
12999     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
13000     vms_vtf7_filenames = 0;
13001     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
13002     if ($VMS_STATUS_SUCCESS(status)) {
13003        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13004          vms_vtf7_filenames = 1;
13005        else
13006          vms_vtf7_filenames = 0;
13007     }
13008
13009
13010     /* unlink all versions on unlink() or rename() */
13011     vms_vtf7_filenames = 0;
13012     status = sys_trnlnm
13013         ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13014     if ($VMS_STATUS_SUCCESS(status)) {
13015        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13016          vms_unlink_all_versions = 1;
13017        else
13018          vms_unlink_all_versions = 0;
13019     }
13020
13021     /* Dectect running under GNV Bash or other UNIX like shell */
13022 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13023     gnv_unix_shell = 0;
13024     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
13025     if ($VMS_STATUS_SUCCESS(status)) {
13026        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13027          gnv_unix_shell = 1;
13028          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
13029          set_feature_default("DECC$EFS_CHARSET", 1);
13030          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
13031          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
13032          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
13033          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
13034          vms_unlink_all_versions = 1;
13035        }
13036        else
13037          gnv_unix_shell = 0;
13038     }
13039 #endif
13040
13041     /* hacks to see if known bugs are still present for testing */
13042
13043     /* Readdir is returning filenames in VMS syntax always */
13044     decc_bug_readdir_efs1 = 1;
13045     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
13046     if ($VMS_STATUS_SUCCESS(status)) {
13047        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13048          decc_bug_readdir_efs1 = 1;
13049        else
13050          decc_bug_readdir_efs1 = 0;
13051     }
13052
13053     /* PCP mode requires creating /dev/null special device file */
13054     decc_bug_devnull = 0;
13055     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
13056     if ($VMS_STATUS_SUCCESS(status)) {
13057        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13058           decc_bug_devnull = 1;
13059        else
13060           decc_bug_devnull = 0;
13061     }
13062
13063     /* fgetname returning a VMS name in UNIX mode */
13064     decc_bug_fgetname = 1;
13065     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
13066     if ($VMS_STATUS_SUCCESS(status)) {
13067       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13068         decc_bug_fgetname = 1;
13069       else
13070         decc_bug_fgetname = 0;
13071     }
13072
13073     /* UNIX directory names with no paths are broken in a lot of places */
13074     decc_dir_barename = 1;
13075     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
13076     if ($VMS_STATUS_SUCCESS(status)) {
13077       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13078         decc_dir_barename = 1;
13079       else
13080         decc_dir_barename = 0;
13081     }
13082
13083 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13084     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
13085     if (s >= 0) {
13086         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
13087         if (decc_disable_to_vms_logname_translation < 0)
13088             decc_disable_to_vms_logname_translation = 0;
13089     }
13090
13091     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
13092     if (s >= 0) {
13093         decc_efs_case_preserve = decc$feature_get_value(s, 1);
13094         if (decc_efs_case_preserve < 0)
13095             decc_efs_case_preserve = 0;
13096     }
13097
13098     s = decc$feature_get_index("DECC$EFS_CHARSET");
13099     if (s >= 0) {
13100         decc_efs_charset = decc$feature_get_value(s, 1);
13101         if (decc_efs_charset < 0)
13102             decc_efs_charset = 0;
13103     }
13104
13105     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
13106     if (s >= 0) {
13107         decc_filename_unix_report = decc$feature_get_value(s, 1);
13108         if (decc_filename_unix_report > 0)
13109             decc_filename_unix_report = 1;
13110         else
13111             decc_filename_unix_report = 0;
13112     }
13113
13114     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
13115     if (s >= 0) {
13116         decc_filename_unix_only = decc$feature_get_value(s, 1);
13117         if (decc_filename_unix_only > 0) {
13118             decc_filename_unix_only = 1;
13119         }
13120         else {
13121             decc_filename_unix_only = 0;
13122         }
13123     }
13124
13125     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
13126     if (s >= 0) {
13127         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
13128         if (decc_filename_unix_no_version < 0)
13129             decc_filename_unix_no_version = 0;
13130     }
13131
13132     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
13133     if (s >= 0) {
13134         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
13135         if (decc_readdir_dropdotnotype < 0)
13136             decc_readdir_dropdotnotype = 0;
13137     }
13138
13139     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
13140     if ($VMS_STATUS_SUCCESS(status)) {
13141         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
13142         if (s >= 0) {
13143             dflt = decc$feature_get_value(s, 4);
13144             if (dflt > 0) {
13145                 decc_disable_posix_root = decc$feature_get_value(s, 1);
13146                 if (decc_disable_posix_root <= 0) {
13147                     decc$feature_set_value(s, 1, 1);
13148                     decc_disable_posix_root = 1;
13149                 }
13150             }
13151             else {
13152                 /* Traditionally Perl assumes this is off */
13153                 decc_disable_posix_root = 1;
13154                 decc$feature_set_value(s, 1, 1);
13155             }
13156         }
13157     }
13158
13159 #if __CRTL_VER >= 80200000
13160     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
13161     if (s >= 0) {
13162         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
13163         if (decc_posix_compliant_pathnames < 0)
13164             decc_posix_compliant_pathnames = 0;
13165         if (decc_posix_compliant_pathnames > 4)
13166             decc_posix_compliant_pathnames = 0;
13167     }
13168
13169 #endif
13170 #else
13171     status = sys_trnlnm
13172         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
13173     if ($VMS_STATUS_SUCCESS(status)) {
13174         val_str[0] = _toupper(val_str[0]);
13175         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13176            decc_disable_to_vms_logname_translation = 1;
13177         }
13178     }
13179
13180 #ifndef __VAX
13181     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
13182     if ($VMS_STATUS_SUCCESS(status)) {
13183         val_str[0] = _toupper(val_str[0]);
13184         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13185            decc_efs_case_preserve = 1;
13186         }
13187     }
13188 #endif
13189
13190     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
13191     if ($VMS_STATUS_SUCCESS(status)) {
13192         val_str[0] = _toupper(val_str[0]);
13193         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13194            decc_filename_unix_report = 1;
13195         }
13196     }
13197     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
13198     if ($VMS_STATUS_SUCCESS(status)) {
13199         val_str[0] = _toupper(val_str[0]);
13200         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13201            decc_filename_unix_only = 1;
13202            decc_filename_unix_report = 1;
13203         }
13204     }
13205     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
13206     if ($VMS_STATUS_SUCCESS(status)) {
13207         val_str[0] = _toupper(val_str[0]);
13208         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13209            decc_filename_unix_no_version = 1;
13210         }
13211     }
13212     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
13213     if ($VMS_STATUS_SUCCESS(status)) {
13214         val_str[0] = _toupper(val_str[0]);
13215         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13216            decc_readdir_dropdotnotype = 1;
13217         }
13218     }
13219 #endif
13220
13221 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13222
13223      /* Report true case tolerance */
13224     /*----------------------------*/
13225     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
13226     if (!$VMS_STATUS_SUCCESS(status))
13227         case_perm = PPROP$K_CASE_BLIND;
13228     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
13229     if (!$VMS_STATUS_SUCCESS(status))
13230         case_image = PPROP$K_CASE_BLIND;
13231     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
13232         (case_image == PPROP$K_CASE_SENSITIVE))
13233         vms_process_case_tolerant = 0;
13234
13235 #endif
13236
13237
13238     /* CRTL can be initialized past this point, but not before. */
13239 /*    DECC$CRTL_INIT(); */
13240
13241     return SS$_NORMAL;
13242 }
13243
13244 #ifdef __DECC
13245 #pragma nostandard
13246 #pragma extern_model save
13247 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
13248         const __align (LONGWORD) int spare[8] = {0};
13249
13250 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
13251 #if __DECC_VER >= 60560002
13252 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
13253 #else
13254 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
13255 #endif
13256 #endif /* __DECC */
13257
13258 const long vms_cc_features = (const long)set_features;
13259
13260 /*
13261 ** Force a reference to LIB$INITIALIZE to ensure it
13262 ** exists in the image.
13263 */
13264 int lib$initialize(void);
13265 #ifdef __DECC
13266 #pragma extern_model strict_refdef
13267 #endif
13268     int lib_init_ref = (int) lib$initialize;
13269
13270 #ifdef __DECC
13271 #pragma extern_model restore
13272 #pragma standard
13273 #endif
13274
13275 /*  End of vms.c */