vms/vms.c

   1 /* vms.c
   2  *
   3  * VMS-specific routines for perl5
   4  * Version: 5.7.0
   5  *
   6  * August 2005 Convert VMS status code to UNIX status codes
   7  * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
   8  *             and Perl_cando by Craig Berry
   9  * 29-Aug-2000 Charles Lane's piping improvements rolled in
  10  * 20-Aug-1999 revisions by Charles Bailey  bailey@newman.upenn.edu
  11  */
  12
  13 #include <acedef.h>
  14 #include <acldef.h>
  15 #include <armdef.h>
  16 #include <atrdef.h>
  17 #include <chpdef.h>
  18 #include <clidef.h>
  19 #include <climsgdef.h>
  20 #include <dcdef.h>
  21 #include <descrip.h>
  22 #include <devdef.h>
  23 #include <dvidef.h>
  24 #include <fibdef.h>
  25 #include <float.h>
  26 #include <fscndef.h>
  27 #include <iodef.h>
  28 #include <jpidef.h>
  29 #include <kgbdef.h>
  30 #include <libclidef.h>
  31 #include <libdef.h>
  32 #include <lib$routines.h>
  33 #include <lnmdef.h>
  34 #include <msgdef.h>
  35 #include <ossdef.h>
  36 #if __CRTL_VER >= 70301000 && !defined(__VAX)
  37 #include <ppropdef.h>
  38 #endif
  39 #include <prvdef.h>
  40 #include <psldef.h>
  41 #include <rms.h>
  42 #include <shrdef.h>
  43 #include <ssdef.h>
  44 #include <starlet.h>
  45 #include <strdef.h>
  46 #include <str$routines.h>
  47 #include <syidef.h>
  48 #include <uaidef.h>
  49 #include <uicdef.h>
  50 #include <stsdef.h>
  51 #include <rmsdef.h>
  52 #include <smgdef.h>
  53 #if __CRTL_VER >= 70000000 /* FIXME to earliest version */
  54 #include <efndef.h>
  55 #define NO_EFN EFN$C_ENF
  56 #else
  57 #define NO_EFN 0;
  58 #endif
  59
  60 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  61 int   decc$feature_get_index(const char *name);
  62 char* decc$feature_get_name(int index);
  63 int   decc$feature_get_value(int index, int mode);
  64 int   decc$feature_set_value(int index, int mode, int value);
  65 #else
  66 #include <unixlib.h>
  67 #endif
  68
  69 #pragma member_alignment save
  70 #pragma nomember_alignment longword
  71 struct item_list_3 {
  72         unsigned short len;
  73         unsigned short code;
  74         void * bufadr;
  75         unsigned short * retadr;
  76 };
  77 #pragma member_alignment restore
  78
  79 /* More specific prototype than in starlet_c.h makes programming errors
  80    more visible.
  81  */
  82 #ifdef sys$getdviw
  83 #undef sys$getdviw
  84 int sys$getdviw
  85        (unsigned long efn,
  86         unsigned short chan,
  87         const struct dsc$descriptor_s * devnam,
  88         const struct item_list_3 * itmlst,
  89         void * iosb,
  90         void * (astadr)(unsigned long),
  91         void * astprm,
  92         void * nullarg);
  93 #endif
  94
  95 #ifdef sys$get_security
  96 #undef sys$get_security
  97 int sys$get_security
  98        (const struct dsc$descriptor_s * clsnam,
  99         const struct dsc$descriptor_s * objnam,
 100         const unsigned int *objhan,
 101         unsigned int flags,
 102         const struct item_list_3 * itmlst,
 103         unsigned int * contxt,
 104         const unsigned int * acmode);
 105 #endif
 106
 107 #ifdef sys$set_security
 108 #undef sys$set_security
 109 int sys$set_security
 110        (const struct dsc$descriptor_s * clsnam,
 111         const struct dsc$descriptor_s * objnam,
 112         const unsigned int *objhan,
 113         unsigned int flags,
 114         const struct item_list_3 * itmlst,
 115         unsigned int * contxt,
 116         const unsigned int * acmode);
 117 #endif
 118
 119 #ifdef lib$find_image_symbol
 120 #undef lib$find_image_symbol
 121 int lib$find_image_symbol
 122        (const struct dsc$descriptor_s * imgname,
 123         const struct dsc$descriptor_s * symname,
 124         void * symval,
 125         const struct dsc$descriptor_s * defspec,
 126         unsigned long flag);
 127 #endif
 128
 129 #ifdef lib$rename_file
 130 #undef lib$rename_file
 131 int lib$rename_file
 132        (const struct dsc$descriptor_s * old_file_dsc,
 133         const struct dsc$descriptor_s * new_file_dsc,
 134         const struct dsc$descriptor_s * default_file_dsc,
 135         const struct dsc$descriptor_s * related_file_dsc,
 136         const unsigned long * flags,
 137         void * (success)(const struct dsc$descriptor_s * old_dsc,
 138                          const struct dsc$descriptor_s * new_dsc,
 139                          const void *),
 140         void * (error)(const struct dsc$descriptor_s * old_dsc,
 141                        const struct dsc$descriptor_s * new_dsc,
 142                        const int * rms_sts,
 143                        const int * rms_stv,
 144                        const int * error_src,
 145                        const void * usr_arg),
 146         int (confirm)(const struct dsc$descriptor_s * old_dsc,
 147                       const struct dsc$descriptor_s * new_dsc,
 148                       const void * old_fab,
 149                       const void * usr_arg),
 150         void * user_arg,
 151         struct dsc$descriptor_s * old_result_name_dsc,
 152         struct dsc$descriptor_s * new_result_name_dsc,
 153         unsigned long * file_scan_context);
 154 #endif
 155
 156 #if __CRTL_VER >= 70300000 && !defined(__VAX)
 157
 158 static int set_feature_default(const char *name, int value)
 159 {
 160     int status;
 161     int index;
 162
 163     index = decc$feature_get_index(name);
 164
 165     status = decc$feature_set_value(index, 1, value);
 166     if (index == -1 || (status == -1)) {
 167       return -1;
 168     }
 169
 170     status = decc$feature_get_value(index, 1);
 171     if (status != value) {
 172       return -1;
 173     }
 174
 175 return 0;
 176 }
 177 #endif
 178
 179 /* Older versions of ssdef.h don't have these */
 180 #ifndef SS$_INVFILFOROP
 181 #  define SS$_INVFILFOROP 3930
 182 #endif
 183 #ifndef SS$_NOSUCHOBJECT
 184 #  define SS$_NOSUCHOBJECT 2696
 185 #endif
 186
 187 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
 188 #define PERLIO_NOT_STDIO 0
 189
 190 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
 191  * code below needs to get to the underlying CRTL routines. */
 192 #define DONT_MASK_RTL_CALLS
 193 #include "EXTERN.h"
 194 #include "perl.h"
 195 #include "XSUB.h"
 196 /* Anticipating future expansion in lexical warnings . . . */
 197 #ifndef WARN_INTERNAL
 198 #  define WARN_INTERNAL WARN_MISC
 199 #endif
 200
 201 #ifdef VMS_LONGNAME_SUPPORT
 202 #include <libfildef.h>
 203 #endif
 204
 205 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
 206 #  define RTL_USES_UTC 1
 207 #endif
 208
 209 /* Routine to create a decterm for use with the Perl debugger */
 210 /* No headers, this information was found in the Programming Concepts Manual */
 211
 212 static int (*decw_term_port)
 213    (const struct dsc$descriptor_s * display,
 214     const struct dsc$descriptor_s * setup_file,
 215     const struct dsc$descriptor_s * customization,
 216     struct dsc$descriptor_s * result_device_name,
 217     unsigned short * result_device_name_length,
 218     void * controller,
 219     void * char_buffer,
 220     void * char_change_buffer) = 0;
 221
 222 /* gcc's header files don't #define direct access macros
 223  * corresponding to VAXC's variant structs */
 224 #ifdef __GNUC__
 225 #  define uic$v_format uic$r_uic_form.uic$v_format
 226 #  define uic$v_group uic$r_uic_form.uic$v_group
 227 #  define uic$v_member uic$r_uic_form.uic$v_member
 228 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 229 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 230 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 231 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 232 #endif
 233
 234 #if defined(NEED_AN_H_ERRNO)
 235 dEXT int h_errno;
 236 #endif
 237
 238 #ifdef __DECC
 239 #pragma message disable pragma
 240 #pragma member_alignment save
 241 #pragma nomember_alignment longword
 242 #pragma message save
 243 #pragma message disable misalgndmem
 244 #endif
 245 struct itmlst_3 {
 246   unsigned short int buflen;
 247   unsigned short int itmcode;
 248   void *bufadr;
 249   unsigned short int *retlen;
 250 };
 251
 252 struct filescan_itmlst_2 {
 253     unsigned short length;
 254     unsigned short itmcode;
 255     char * component;
 256 };
 257
 258 struct vs_str_st {
 259     unsigned short length;
 260     char str[65536];
 261 };
 262
 263 #ifdef __DECC
 264 #pragma message restore
 265 #pragma member_alignment restore
 266 #endif
 267
 268 #define do_fileify_dirspec(a,b,c,d)     mp_do_fileify_dirspec(aTHX_ a,b,c,d)
 269 #define do_pathify_dirspec(a,b,c,d)     mp_do_pathify_dirspec(aTHX_ a,b,c,d)
 270 #define do_tovmsspec(a,b,c,d)           mp_do_tovmsspec(aTHX_ a,b,c,0,d)
 271 #define do_tovmspath(a,b,c,d)           mp_do_tovmspath(aTHX_ a,b,c,d)
 272 #define do_rmsexpand(a,b,c,d,e,f,g)     mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
 273 #define do_vms_realpath(a,b,c)          mp_do_vms_realpath(aTHX_ a,b,c)
 274 #define do_tounixspec(a,b,c,d)          mp_do_tounixspec(aTHX_ a,b,c,d)
 275 #define do_tounixpath(a,b,c,d)          mp_do_tounixpath(aTHX_ a,b,c,d)
 276 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 277 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 278 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 279
 280 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
 281 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
 282 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
 283 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
 284
 285 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 286 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 287
 288 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 289  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 290  * the Perl facility.
 291  */
 292 #define PERL_LNM_MAX_ITER 10
 293
 294   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 295 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 296 #define MAX_DCL_SYMBOL          (8192)
 297 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 298 #else
 299 #define MAX_DCL_SYMBOL          (1024)
 300 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 301 #endif
 302
 303 static char *__mystrtolower(char *str)
 304 {
 305   if (str) for (; *str; ++str) *str= tolower(*str);
 306   return str;
 307 }
 308
 309 static struct dsc$descriptor_s fildevdsc =
 310   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 311 static struct dsc$descriptor_s crtlenvdsc =
 312   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 313 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 314 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 315 static struct dsc$descriptor_s **env_tables = defenv;
 316 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 317
 318 /* True if we shouldn't treat barewords as logicals during directory */
 319 /* munching */
 320 static int no_translate_barewords;
 321
 322 #ifndef RTL_USES_UTC
 323 static int tz_updated = 1;
 324 #endif
 325
 326 /* DECC Features that may need to affect how Perl interprets
 327  * displays filename information
 328  */
 329 static int decc_disable_to_vms_logname_translation = 1;
 330 static int decc_disable_posix_root = 1;
 331 int decc_efs_case_preserve = 0;
 332 static int decc_efs_charset = 0;
 333 static int decc_filename_unix_no_version = 0;
 334 static int decc_filename_unix_only = 0;
 335 int decc_filename_unix_report = 0;
 336 int decc_posix_compliant_pathnames = 0;
 337 int decc_readdir_dropdotnotype = 0;
 338 static int vms_process_case_tolerant = 1;
 339 int vms_vtf7_filenames = 0;
 340 int gnv_unix_shell = 0;
 341 static int vms_unlink_all_versions = 0;
 342
 343 /* bug workarounds if needed */
 344 int decc_bug_readdir_efs1 = 0;
 345 int decc_bug_devnull = 1;
 346 int decc_bug_fgetname = 0;
 347 int decc_dir_barename = 0;
 348
 349 static int vms_debug_on_exception = 0;
 350
 351 /* Is this a UNIX file specification?
 352  *   No longer a simple check with EFS file specs
 353  *   For now, not a full check, but need to
 354  *   handle POSIX ^UP^ specifications
 355  *   Fixing to handle ^/ cases would require
 356  *   changes to many other conversion routines.
 357  */
 358
 359 static int is_unix_filespec(const char *path)
 360 {
 361 int ret_val;
 362 const char * pch1;
 363
 364     ret_val = 0;
 365     if (strncmp(path,"\"^UP^",5) != 0) {
 366         pch1 = strchr(path, '/');
 367         if (pch1 != NULL)
 368             ret_val = 1;
 369         else {
 370
 371             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 372             if (decc_filename_unix_report || decc_filename_unix_only) {
 373             if (strcmp(path,".") == 0)
 374                 ret_val = 1;
 375             }
 376         }
 377     }
 378     return ret_val;
 379 }
 380
 381 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 382  */
 383
 384 static void ucs2_to_vtf7
 385    (char *outspec,
 386     unsigned long ucs2_char,
 387     int * output_cnt)
 388 {
 389 unsigned char * ucs_ptr;
 390 int hex;
 391
 392     ucs_ptr = (unsigned char *)&ucs2_char;
 393
 394     outspec[0] = '^';
 395     outspec[1] = 'U';
 396     hex = (ucs_ptr[1] >> 4) & 0xf;
 397     if (hex < 0xA)
 398         outspec[2] = hex + '0';
 399     else
 400         outspec[2] = (hex - 9) + 'A';
 401     hex = ucs_ptr[1] & 0xF;
 402     if (hex < 0xA)
 403         outspec[3] = hex + '0';
 404     else {
 405         outspec[3] = (hex - 9) + 'A';
 406     }
 407     hex = (ucs_ptr[0] >> 4) & 0xf;
 408     if (hex < 0xA)
 409         outspec[4] = hex + '0';
 410     else
 411         outspec[4] = (hex - 9) + 'A';
 412     hex = ucs_ptr[1] & 0xF;
 413     if (hex < 0xA)
 414         outspec[5] = hex + '0';
 415     else {
 416         outspec[5] = (hex - 9) + 'A';
 417     }
 418     *output_cnt = 6;
 419 }
 420
 421
 422 /* This handles the conversion of a UNIX extended character set to a ^
 423  * escaped VMS character.
 424  * in a UNIX file specification.
 425  *
 426  * The output count variable contains the number of characters added
 427  * to the output string.
 428  *
 429  * The return value is the number of characters read from the input string
 430  */
 431 static int copy_expand_unix_filename_escape
 432   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 433 {
 434 int count;
 435 int scnt;
 436 int utf8_flag;
 437
 438     utf8_flag = 0;
 439     if (utf8_fl)
 440       utf8_flag = *utf8_fl;
 441
 442     count = 0;
 443     *output_cnt = 0;
 444     if (*inspec >= 0x80) {
 445         if (utf8_fl && vms_vtf7_filenames) {
 446         unsigned long ucs_char;
 447
 448             ucs_char = 0;
 449
 450             if ((*inspec & 0xE0) == 0xC0) {
 451                 /* 2 byte Unicode */
 452                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 453                 if (ucs_char >= 0x80) {
 454                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 455                     return 2;
 456                 }
 457             } else if ((*inspec & 0xF0) == 0xE0) {
 458                 /* 3 byte Unicode */
 459                 ucs_char = ((inspec[0] & 0xF) << 12) +
 460                    ((inspec[1] & 0x3f) << 6) +
 461                    (inspec[2] & 0x3f);
 462                 if (ucs_char >= 0x800) {
 463                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 464                     return 3;
 465                 }
 466
 467 #if 0 /* I do not see longer sequences supported by OpenVMS */
 468       /* Maybe some one can fix this later */
 469             } else if ((*inspec & 0xF8) == 0xF0) {
 470                 /* 4 byte Unicode */
 471                 /* UCS-4 to UCS-2 */
 472             } else if ((*inspec & 0xFC) == 0xF8) {
 473                 /* 5 byte Unicode */
 474                 /* UCS-4 to UCS-2 */
 475             } else if ((*inspec & 0xFE) == 0xFC) {
 476                 /* 6 byte Unicode */
 477                 /* UCS-4 to UCS-2 */
 478 #endif
 479             }
 480         }
 481
 482         /* High bit set, but not a Unicode character! */
 483
 484         /* Non printing DECMCS or ISO Latin-1 character? */
 485         if (*inspec <= 0x9F) {
 486         int hex;
 487             outspec[0] = '^';
 488             outspec++;
 489             hex = (*inspec >> 4) & 0xF;
 490             if (hex < 0xA)
 491                 outspec[1] = hex + '0';
 492             else {
 493                 outspec[1] = (hex - 9) + 'A';
 494             }
 495             hex = *inspec & 0xF;
 496             if (hex < 0xA)
 497                 outspec[2] = hex + '0';
 498             else {
 499                 outspec[2] = (hex - 9) + 'A';
 500             }
 501             *output_cnt = 3;
 502             return 1;
 503         } else if (*inspec == 0xA0) {
 504             outspec[0] = '^';
 505             outspec[1] = 'A';
 506             outspec[2] = '0';
 507             *output_cnt = 3;
 508             return 1;
 509         } else if (*inspec == 0xFF) {
 510             outspec[0] = '^';
 511             outspec[1] = 'F';
 512             outspec[2] = 'F';
 513             *output_cnt = 3;
 514             return 1;
 515         }
 516         *outspec = *inspec;
 517         *output_cnt = 1;
 518         return 1;
 519     }
 520
 521     /* Is this a macro that needs to be passed through?
 522      * Macros start with $( and an alpha character, followed
 523      * by a string of alpha numeric characters ending with a )
 524      * If this does not match, then encode it as ODS-5.
 525      */
 526     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 527     int tcnt;
 528
 529         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 530             tcnt = 3;
 531             outspec[0] = inspec[0];
 532             outspec[1] = inspec[1];
 533             outspec[2] = inspec[2];
 534
 535             while(isalnum(inspec[tcnt]) ||
 536                   (inspec[2] == '.') || (inspec[2] == '_')) {
 537                 outspec[tcnt] = inspec[tcnt];
 538                 tcnt++;
 539             }
 540             if (inspec[tcnt] == ')') {
 541                 outspec[tcnt] = inspec[tcnt];
 542                 tcnt++;
 543                 *output_cnt = tcnt;
 544                 return tcnt;
 545             }
 546         }
 547     }
 548
 549     switch (*inspec) {
 550     case 0x7f:
 551         outspec[0] = '^';
 552         outspec[1] = '7';
 553         outspec[2] = 'F';
 554         *output_cnt = 3;
 555         return 1;
 556         break;
 557     case '?':
 558         if (decc_efs_charset == 0)
 559           outspec[0] = '%';
 560         else
 561           outspec[0] = '?';
 562         *output_cnt = 1;
 563         return 1;
 564         break;
 565     case '.':
 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         /* Don't escape again if following character is
 585          * already something we escape.
 586          */
 587         if (strchr(".~!#&\'`()+@{},;[]%^=_", *(inspec+1))) {
 588             *outspec = *inspec;
 589             *output_cnt = 1;
 590             return 1;
 591             break;
 592         }
 593         /* But otherwise fall through and escape it. */
 594     case '=':
 595         /* Assume that this is to be escaped */
 596         outspec[0] = '^';
 597         outspec[1] = *inspec;
 598         *output_cnt = 2;
 599         return 1;
 600         break;
 601     case ' ': /* space */
 602         /* Assume that this is to be escaped */
 603         outspec[0] = '^';
 604         outspec[1] = '_';
 605         *output_cnt = 2;
 606         return 1;
 607         break;
 608     default:
 609         *outspec = *inspec;
 610         *output_cnt = 1;
 611         return 1;
 612         break;
 613     }
 614 }
 615
 616
 617 /* This handles the expansion of a '^' prefix to the proper character
 618  * in a UNIX file specification.
 619  *
 620  * The output count variable contains the number of characters added
 621  * to the output string.
 622  *
 623  * The return value is the number of characters read from the input
 624  * string
 625  */
 626 static int copy_expand_vms_filename_escape
 627   (char *outspec, const char *inspec, int *output_cnt)
 628 {
 629 int count;
 630 int scnt;
 631
 632     count = 0;
 633     *output_cnt = 0;
 634     if (*inspec == '^') {
 635         inspec++;
 636         switch (*inspec) {
 637         /* Spaces and non-trailing dots should just be passed through,
 638          * but eat the escape character.
 639          */
 640         case '.':
 641             *outspec = *inspec;
 642             count += 2;
 643             (*output_cnt)++;
 644             break;
 645         case '_': /* space */
 646             *outspec = ' ';
 647             count += 2;
 648             (*output_cnt)++;
 649             break;
 650         case '^':
 651             /* Hmm.  Better leave the escape escaped. */
 652             outspec[0] = '^';
 653             outspec[1] = '^';
 654             count += 2;
 655             (*output_cnt) += 2;
 656             break;
 657         case 'U': /* Unicode - FIX-ME this is wrong. */
 658             inspec++;
 659             count++;
 660             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 661             if (scnt == 4) {
 662                 unsigned int c1, c2;
 663                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 664                 outspec[0] == c1 & 0xff;
 665                 outspec[1] == c2 & 0xff;
 666                 if (scnt > 1) {
 667                     (*output_cnt) += 2;
 668                     count += 4;
 669                 }
 670             }
 671             else {
 672                 /* Error - do best we can to continue */
 673                 *outspec = 'U';
 674                 outspec++;
 675                 (*output_cnt++);
 676                 *outspec = *inspec;
 677                 count++;
 678                 (*output_cnt++);
 679             }
 680             break;
 681         default:
 682             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 683             if (scnt == 2) {
 684                 /* Hex encoded */
 685                 unsigned int c1;
 686                 scnt = sscanf(inspec, "%2x", &c1);
 687                 outspec[0] = c1 & 0xff;
 688                 if (scnt > 0) {
 689                     (*output_cnt++);
 690                     count += 2;
 691                 }
 692             }
 693             else {
 694                 *outspec = *inspec;
 695                 count++;
 696                 (*output_cnt++);
 697             }
 698         }
 699     }
 700     else {
 701         *outspec = *inspec;
 702         count++;
 703         (*output_cnt)++;
 704     }
 705     return count;
 706 }
 707
 708 #ifdef sys$filescan
 709 #undef sys$filescan
 710 int sys$filescan
 711    (const struct dsc$descriptor_s * srcstr,
 712     struct filescan_itmlst_2 * valuelist,
 713     unsigned long * fldflags,
 714     struct dsc$descriptor_s *auxout,
 715     unsigned short * retlen);
 716 #endif
 717
 718 /* vms_split_path - Verify that the input file specification is a
 719  * VMS format file specification, and provide pointers to the components of
 720  * it.  With EFS format filenames, this is virtually the only way to
 721  * parse a VMS path specification into components.
 722  *
 723  * If the sum of the components do not add up to the length of the
 724  * string, then the passed file specification is probably a UNIX style
 725  * path.
 726  */
 727 static int vms_split_path
 728    (const char * path,
 729     char * * volume,
 730     int * vol_len,
 731     char * * root,
 732     int * root_len,
 733     char * * dir,
 734     int * dir_len,
 735     char * * name,
 736     int * name_len,
 737     char * * ext,
 738     int * ext_len,
 739     char * * version,
 740     int * ver_len)
 741 {
 742 struct dsc$descriptor path_desc;
 743 int status;
 744 unsigned long flags;
 745 int ret_stat;
 746 struct filescan_itmlst_2 item_list[9];
 747 const int filespec = 0;
 748 const int nodespec = 1;
 749 const int devspec = 2;
 750 const int rootspec = 3;
 751 const int dirspec = 4;
 752 const int namespec = 5;
 753 const int typespec = 6;
 754 const int verspec = 7;
 755
 756     /* Assume the worst for an easy exit */
 757     ret_stat = -1;
 758     *volume = NULL;
 759     *vol_len = 0;
 760     *root = NULL;
 761     *root_len = 0;
 762     *dir = NULL;
 763     *dir_len;
 764     *name = NULL;
 765     *name_len = 0;
 766     *ext = NULL;
 767     *ext_len = 0;
 768     *version = NULL;
 769     *ver_len = 0;
 770
 771     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 772     path_desc.dsc$w_length = strlen(path);
 773     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 774     path_desc.dsc$b_class = DSC$K_CLASS_S;
 775
 776     /* Get the total length, if it is shorter than the string passed
 777      * then this was probably not a VMS formatted file specification
 778      */
 779     item_list[filespec].itmcode = FSCN$_FILESPEC;
 780     item_list[filespec].length = 0;
 781     item_list[filespec].component = NULL;
 782
 783     /* If the node is present, then it gets considered as part of the
 784      * volume name to hopefully make things simple.
 785      */
 786     item_list[nodespec].itmcode = FSCN$_NODE;
 787     item_list[nodespec].length = 0;
 788     item_list[nodespec].component = NULL;
 789
 790     item_list[devspec].itmcode = FSCN$_DEVICE;
 791     item_list[devspec].length = 0;
 792     item_list[devspec].component = NULL;
 793
 794     /* root is a special case,  adding it to either the directory or
 795      * the device components will probalby complicate things for the
 796      * callers of this routine, so leave it separate.
 797      */
 798     item_list[rootspec].itmcode = FSCN$_ROOT;
 799     item_list[rootspec].length = 0;
 800     item_list[rootspec].component = NULL;
 801
 802     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 803     item_list[dirspec].length = 0;
 804     item_list[dirspec].component = NULL;
 805
 806     item_list[namespec].itmcode = FSCN$_NAME;
 807     item_list[namespec].length = 0;
 808     item_list[namespec].component = NULL;
 809
 810     item_list[typespec].itmcode = FSCN$_TYPE;
 811     item_list[typespec].length = 0;
 812     item_list[typespec].component = NULL;
 813
 814     item_list[verspec].itmcode = FSCN$_VERSION;
 815     item_list[verspec].length = 0;
 816     item_list[verspec].component = NULL;
 817
 818     item_list[8].itmcode = 0;
 819     item_list[8].length = 0;
 820     item_list[8].component = NULL;
 821
 822     status = sys$filescan
 823        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 824         &flags, NULL, NULL);
 825     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 826
 827     /* If we parsed it successfully these two lengths should be the same */
 828     if (path_desc.dsc$w_length != item_list[filespec].length)
 829         return ret_stat;
 830
 831     /* If we got here, then it is a VMS file specification */
 832     ret_stat = 0;
 833
 834     /* set the volume name */
 835     if (item_list[nodespec].length > 0) {
 836         *volume = item_list[nodespec].component;
 837         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 838     }
 839     else {
 840         *volume = item_list[devspec].component;
 841         *vol_len = item_list[devspec].length;
 842     }
 843
 844     *root = item_list[rootspec].component;
 845     *root_len = item_list[rootspec].length;
 846
 847     *dir = item_list[dirspec].component;
 848     *dir_len = item_list[dirspec].length;
 849
 850     /* Now fun with versions and EFS file specifications
 851      * The parser can not tell the difference when a "." is a version
 852      * delimiter or a part of the file specification.
 853      */
 854     if ((decc_efs_charset) &&
 855         (item_list[verspec].length > 0) &&
 856         (item_list[verspec].component[0] == '.')) {
 857         *name = item_list[namespec].component;
 858         *name_len = item_list[namespec].length + item_list[typespec].length;
 859         *ext = item_list[verspec].component;
 860         *ext_len = item_list[verspec].length;
 861         *version = NULL;
 862         *ver_len = 0;
 863     }
 864     else {
 865         *name = item_list[namespec].component;
 866         *name_len = item_list[namespec].length;
 867         *ext = item_list[typespec].component;
 868         *ext_len = item_list[typespec].length;
 869         *version = item_list[verspec].component;
 870         *ver_len = item_list[verspec].length;
 871     }
 872     return ret_stat;
 873 }
 874
 875
 876 /* my_maxidx
 877  * Routine to retrieve the maximum equivalence index for an input
 878  * logical name.  Some calls to this routine have no knowledge if
 879  * the variable is a logical or not.  So on error we return a max
 880  * index of zero.
 881  */
 882 /*{{{int my_maxidx(const char *lnm) */
 883 static int
 884 my_maxidx(const char *lnm)
 885 {
 886     int status;
 887     int midx;
 888     int attr = LNM$M_CASE_BLIND;
 889     struct dsc$descriptor lnmdsc;
 890     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 891                                 {0, 0, 0, 0}};
 892
 893     lnmdsc.dsc$w_length = strlen(lnm);
 894     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 895     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 896     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 897
 898     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 899     if ((status & 1) == 0)
 900        midx = 0;
 901
 902     return (midx);
 903 }
 904 /*}}}*/
 905
 906 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 907 int
 908 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 909   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 910 {
 911     const char *cp1;
 912     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 913     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 914     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 915     int midx;
 916     unsigned char acmode;
 917     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 918                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 919     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 920                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 921                                  {0, 0, 0, 0}};
 922     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 923 #if defined(PERL_IMPLICIT_CONTEXT)
 924     pTHX = NULL;
 925     if (PL_curinterp) {
 926       aTHX = PERL_GET_INTERP;
 927     } else {
 928       aTHX = NULL;
 929     }
 930 #endif
 931
 932     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 933       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 934     }
 935     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 936       *cp2 = _toupper(*cp1);
 937       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 938         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 939         return 0;
 940       }
 941     }
 942     lnmdsc.dsc$w_length = cp1 - lnm;
 943     lnmdsc.dsc$a_pointer = uplnm;
 944     uplnm[lnmdsc.dsc$w_length] = '\0';
 945     secure = flags & PERL__TRNENV_SECURE;
 946     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 947     if (!tabvec || !*tabvec) tabvec = env_tables;
 948
 949     for (curtab = 0; tabvec[curtab]; curtab++) {
 950       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 951         if (!ivenv && !secure) {
 952           char *eq, *end;
 953           int i;
 954           if (!environ) {
 955             ivenv = 1;
 956             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 957             continue;
 958           }
 959           retsts = SS$_NOLOGNAM;
 960           for (i = 0; environ[i]; i++) {
 961             if ((eq = strchr(environ[i],'=')) &&
 962                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 963                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 964               eq++;
 965               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 966               if (!eqvlen) continue;
 967               retsts = SS$_NORMAL;
 968               break;
 969             }
 970           }
 971           if (retsts != SS$_NOLOGNAM) break;
 972         }
 973       }
 974       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 975                !str$case_blind_compare(&tmpdsc,&clisym)) {
 976         if (!ivsym && !secure) {
 977           unsigned short int deflen = LNM$C_NAMLENGTH;
 978           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 979           /* dynamic dsc to accomodate possible long value */
 980           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 981           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 982           if (retsts & 1) {
 983             if (eqvlen > MAX_DCL_SYMBOL) {
 984               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 985               eqvlen = MAX_DCL_SYMBOL;
 986               /* Special hack--we might be called before the interpreter's */
 987               /* fully initialized, in which case either thr or PL_curcop */
 988               /* might be bogus. We have to check, since ckWARN needs them */
 989               /* both to be valid if running threaded */
 990                 if (ckWARN(WARN_MISC)) {
 991                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 992                 }
 993             }
 994             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 995           }
 996           _ckvmssts(lib$sfree1_dd(&eqvdsc));
 997           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 998           if (retsts == LIB$_NOSUCHSYM) continue;
 999           break;
1000         }
1001       }
1002       else if (!ivlnm) {
1003         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
1004           midx = my_maxidx(lnm);
1005           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1006             lnmlst[1].bufadr = cp2;
1007             eqvlen = 0;
1008             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1009             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1010             if (retsts == SS$_NOLOGNAM) break;
1011             /* PPFs have a prefix */
1012             if (
1013 #if INTSIZE == 4
1014                  *((int *)uplnm) == *((int *)"SYS$")                    &&
1015 #endif
1016                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
1017                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
1018                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
1019                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
1020                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
1021               memmove(eqv,eqv+4,eqvlen-4);
1022               eqvlen -= 4;
1023             }
1024             cp2 += eqvlen;
1025             *cp2 = '\0';
1026           }
1027           if ((retsts == SS$_IVLOGNAM) ||
1028               (retsts == SS$_NOLOGNAM)) { continue; }
1029         }
1030         else {
1031           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1032           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1033           if (retsts == SS$_NOLOGNAM) continue;
1034           eqv[eqvlen] = '\0';
1035         }
1036         eqvlen = strlen(eqv);
1037         break;
1038       }
1039     }
1040     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1041     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1042              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
1043              retsts == SS$_NOLOGNAM) {
1044       set_errno(EINVAL);  set_vaxc_errno(retsts);
1045     }
1046     else _ckvmssts(retsts);
1047     return 0;
1048 }  /* end of vmstrnenv */
1049 /*}}}*/
1050
1051 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1052 /* Define as a function so we can access statics. */
1053 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1054 {
1055   return vmstrnenv(lnm,eqv,idx,fildev,
1056 #ifdef SECURE_INTERNAL_GETENV
1057                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
1058 #else
1059                    0
1060 #endif
1061                                                                               );
1062 }
1063 /*}}}*/
1064
1065 /* my_getenv
1066  * Note: Uses Perl temp to store result so char * can be returned to
1067  * caller; this pointer will be invalidated at next Perl statement
1068  * transition.
1069  * We define this as a function rather than a macro in terms of my_getenv_len()
1070  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1071  * allocate SVs).
1072  */
1073 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1074 char *
1075 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1076 {
1077     const char *cp1;
1078     static char *__my_getenv_eqv = NULL;
1079     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1080     unsigned long int idx = 0;
1081     int trnsuccess, success, secure, saverr, savvmserr;
1082     int midx, flags;
1083     SV *tmpsv;
1084
1085     midx = my_maxidx(lnm) + 1;
1086
1087     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1088       /* Set up a temporary buffer for the return value; Perl will
1089        * clean it up at the next statement transition */
1090       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1091       if (!tmpsv) return NULL;
1092       eqv = SvPVX(tmpsv);
1093     }
1094     else {
1095       /* Assume no interpreter ==> single thread */
1096       if (__my_getenv_eqv != NULL) {
1097         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1098       }
1099       else {
1100         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1101       }
1102       eqv = __my_getenv_eqv;
1103     }
1104
1105     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1106     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1107       int len;
1108       getcwd(eqv,LNM$C_NAMLENGTH);
1109
1110       len = strlen(eqv);
1111
1112       /* Get rid of "000000/ in rooted filespecs */
1113       if (len > 7) {
1114         char * zeros;
1115         zeros = strstr(eqv, "/000000/");
1116         if (zeros != NULL) {
1117           int mlen;
1118           mlen = len - (zeros - eqv) - 7;
1119           memmove(zeros, &zeros[7], mlen);
1120           len = len - 7;
1121           eqv[len] = '\0';
1122         }
1123       }
1124       return eqv;
1125     }
1126     else {
1127       /* Impose security constraints only if tainting */
1128       if (sys) {
1129         /* Impose security constraints only if tainting */
1130         secure = PL_curinterp ? PL_tainting : will_taint;
1131         saverr = errno;  savvmserr = vaxc$errno;
1132       }
1133       else {
1134         secure = 0;
1135       }
1136
1137       flags =
1138 #ifdef SECURE_INTERNAL_GETENV
1139               secure ? PERL__TRNENV_SECURE : 0
1140 #else
1141               0
1142 #endif
1143       ;
1144
1145       /* For the getenv interface we combine all the equivalence names
1146        * of a search list logical into one value to acquire a maximum
1147        * value length of 255*128 (assuming %ENV is using logicals).
1148        */
1149       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1150
1151       /* If the name contains a semicolon-delimited index, parse it
1152        * off and make sure we only retrieve the equivalence name for
1153        * that index.  */
1154       if ((cp2 = strchr(lnm,';')) != NULL) {
1155         strcpy(uplnm,lnm);
1156         uplnm[cp2-lnm] = '\0';
1157         idx = strtoul(cp2+1,NULL,0);
1158         lnm = uplnm;
1159         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1160       }
1161
1162       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1163
1164       /* Discard NOLOGNAM on internal calls since we're often looking
1165        * for an optional name, and this "error" often shows up as the
1166        * (bogus) exit status for a die() call later on.  */
1167       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1168       return success ? eqv : Nullch;
1169     }
1170
1171 }  /* end of my_getenv() */
1172 /*}}}*/
1173
1174
1175 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1176 char *
1177 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1178 {
1179     const char *cp1;
1180     char *buf, *cp2;
1181     unsigned long idx = 0;
1182     int midx, flags;
1183     static char *__my_getenv_len_eqv = NULL;
1184     int secure, saverr, savvmserr;
1185     SV *tmpsv;
1186
1187     midx = my_maxidx(lnm) + 1;
1188
1189     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1190       /* Set up a temporary buffer for the return value; Perl will
1191        * clean it up at the next statement transition */
1192       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1193       if (!tmpsv) return NULL;
1194       buf = SvPVX(tmpsv);
1195     }
1196     else {
1197       /* Assume no interpreter ==> single thread */
1198       if (__my_getenv_len_eqv != NULL) {
1199         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1200       }
1201       else {
1202         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1203       }
1204       buf = __my_getenv_len_eqv;
1205     }
1206
1207     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1208     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1209     char * zeros;
1210
1211       getcwd(buf,LNM$C_NAMLENGTH);
1212       *len = strlen(buf);
1213
1214       /* Get rid of "000000/ in rooted filespecs */
1215       if (*len > 7) {
1216       zeros = strstr(buf, "/000000/");
1217       if (zeros != NULL) {
1218         int mlen;
1219         mlen = *len - (zeros - buf) - 7;
1220         memmove(zeros, &zeros[7], mlen);
1221         *len = *len - 7;
1222         buf[*len] = '\0';
1223         }
1224       }
1225       return buf;
1226     }
1227     else {
1228       if (sys) {
1229         /* Impose security constraints only if tainting */
1230         secure = PL_curinterp ? PL_tainting : will_taint;
1231         saverr = errno;  savvmserr = vaxc$errno;
1232       }
1233       else {
1234         secure = 0;
1235       }
1236
1237       flags =
1238 #ifdef SECURE_INTERNAL_GETENV
1239               secure ? PERL__TRNENV_SECURE : 0
1240 #else
1241               0
1242 #endif
1243       ;
1244
1245       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1246
1247       if ((cp2 = strchr(lnm,';')) != NULL) {
1248         strcpy(buf,lnm);
1249         buf[cp2-lnm] = '\0';
1250         idx = strtoul(cp2+1,NULL,0);
1251         lnm = buf;
1252         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1253       }
1254
1255       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1256
1257       /* Get rid of "000000/ in rooted filespecs */
1258       if (*len > 7) {
1259       char * zeros;
1260         zeros = strstr(buf, "/000000/");
1261         if (zeros != NULL) {
1262           int mlen;
1263           mlen = *len - (zeros - buf) - 7;
1264           memmove(zeros, &zeros[7], mlen);
1265           *len = *len - 7;
1266           buf[*len] = '\0';
1267         }
1268       }
1269
1270       /* Discard NOLOGNAM on internal calls since we're often looking
1271        * for an optional name, and this "error" often shows up as the
1272        * (bogus) exit status for a die() call later on.  */
1273       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1274       return *len ? buf : Nullch;
1275     }
1276
1277 }  /* end of my_getenv_len() */
1278 /*}}}*/
1279
1280 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
1281
1282 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1283
1284 /*{{{ void prime_env_iter() */
1285 void
1286 prime_env_iter(void)
1287 /* Fill the %ENV associative array with all logical names we can
1288  * find, in preparation for iterating over it.
1289  */
1290 {
1291   static int primed = 0;
1292   HV *seenhv = NULL, *envhv;
1293   SV *sv = NULL;
1294   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
1295   unsigned short int chan;
1296 #ifndef CLI$M_TRUSTED
1297 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1298 #endif
1299   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1300   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1301   long int i;
1302   bool have_sym = FALSE, have_lnm = FALSE;
1303   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1304   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1305   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1306   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1307   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1308 #if defined(PERL_IMPLICIT_CONTEXT)
1309   pTHX;
1310 #endif
1311 #if defined(USE_ITHREADS)
1312   static perl_mutex primenv_mutex;
1313   MUTEX_INIT(&primenv_mutex);
1314 #endif
1315
1316 #if defined(PERL_IMPLICIT_CONTEXT)
1317     /* We jump through these hoops because we can be called at */
1318     /* platform-specific initialization time, which is before anything is */
1319     /* set up--we can't even do a plain dTHX since that relies on the */
1320     /* interpreter structure to be initialized */
1321     if (PL_curinterp) {
1322       aTHX = PERL_GET_INTERP;
1323     } else {
1324       aTHX = NULL;
1325     }
1326 #endif
1327
1328   if (primed || !PL_envgv) return;
1329   MUTEX_LOCK(&primenv_mutex);
1330   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1331   envhv = GvHVn(PL_envgv);
1332   /* Perform a dummy fetch as an lval to insure that the hash table is
1333    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1334   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1335
1336   for (i = 0; env_tables[i]; i++) {
1337      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1338          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1339      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1340   }
1341   if (have_sym || have_lnm) {
1342     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1343     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1344     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1345     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1346   }
1347
1348   for (i--; i >= 0; i--) {
1349     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1350       char *start;
1351       int j;
1352       for (j = 0; environ[j]; j++) {
1353         if (!(start = strchr(environ[j],'='))) {
1354           if (ckWARN(WARN_INTERNAL))
1355             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1356         }
1357         else {
1358           start++;
1359           sv = newSVpv(start,0);
1360           SvTAINTED_on(sv);
1361           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1362         }
1363       }
1364       continue;
1365     }
1366     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1367              !str$case_blind_compare(&tmpdsc,&clisym)) {
1368       strcpy(cmd,"Show Symbol/Global *");
1369       cmddsc.dsc$w_length = 20;
1370       if (env_tables[i]->dsc$w_length == 12 &&
1371           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1372           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1373       flags = defflags | CLI$M_NOLOGNAM;
1374     }
1375     else {
1376       strcpy(cmd,"Show Logical *");
1377       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1378         strcat(cmd," /Table=");
1379         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1380         cmddsc.dsc$w_length = strlen(cmd);
1381       }
1382       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1383       flags = defflags | CLI$M_NOCLISYM;
1384     }
1385
1386     /* Create a new subprocess to execute each command, to exclude the
1387      * remote possibility that someone could subvert a mbx or file used
1388      * to write multiple commands to a single subprocess.
1389      */
1390     do {
1391       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1392                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1393       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1394       defflags &= ~CLI$M_TRUSTED;
1395     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1396     _ckvmssts(retsts);
1397     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1398     if (seenhv) SvREFCNT_dec(seenhv);
1399     seenhv = newHV();
1400     while (1) {
1401       char *cp1, *cp2, *key;
1402       unsigned long int sts, iosb[2], retlen, keylen;
1403       register U32 hash;
1404
1405       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1406       if (sts & 1) sts = iosb[0] & 0xffff;
1407       if (sts == SS$_ENDOFFILE) {
1408         int wakect = 0;
1409         while (substs == 0) { sys$hiber(); wakect++;}
1410         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1411         _ckvmssts(substs);
1412         break;
1413       }
1414       _ckvmssts(sts);
1415       retlen = iosb[0] >> 16;
1416       if (!retlen) continue;  /* blank line */
1417       buf[retlen] = '\0';
1418       if (iosb[1] != subpid) {
1419         if (iosb[1]) {
1420           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1421         }
1422         continue;
1423       }
1424       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1425         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1426
1427       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1428       if (*cp1 == '(' || /* Logical name table name */
1429           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1430       if (*cp1 == '"') cp1++;
1431       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1432       key = cp1;  keylen = cp2 - cp1;
1433       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1434       while (*cp2 && *cp2 != '=') cp2++;
1435       while (*cp2 && *cp2 == '=') cp2++;
1436       while (*cp2 && *cp2 == ' ') cp2++;
1437       if (*cp2 == '"') {  /* String translation; may embed "" */
1438         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1439         cp2++;  cp1--; /* Skip "" surrounding translation */
1440       }
1441       else {  /* Numeric translation */
1442         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1443         cp1--;  /* stop on last non-space char */
1444       }
1445       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1446         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1447         continue;
1448       }
1449       PERL_HASH(hash,key,keylen);
1450
1451       if (cp1 == cp2 && *cp2 == '.') {
1452         /* A single dot usually means an unprintable character, such as a null
1453          * to indicate a zero-length value.  Get the actual value to make sure.
1454          */
1455         char lnm[LNM$C_NAMLENGTH+1];
1456         char eqv[MAX_DCL_SYMBOL+1];
1457         int trnlen;
1458         strncpy(lnm, key, keylen);
1459         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1460         sv = newSVpvn(eqv, strlen(eqv));
1461       }
1462       else {
1463         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1464       }
1465
1466       SvTAINTED_on(sv);
1467       hv_store(envhv,key,keylen,sv,hash);
1468       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1469     }
1470     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1471       /* get the PPFs for this process, not the subprocess */
1472       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1473       char eqv[LNM$C_NAMLENGTH+1];
1474       int trnlen, i;
1475       for (i = 0; ppfs[i]; i++) {
1476         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1477         sv = newSVpv(eqv,trnlen);
1478         SvTAINTED_on(sv);
1479         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1480       }
1481     }
1482   }
1483   primed = 1;
1484   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1485   if (buf) Safefree(buf);
1486   if (seenhv) SvREFCNT_dec(seenhv);
1487   MUTEX_UNLOCK(&primenv_mutex);
1488   return;
1489
1490 }  /* end of prime_env_iter */
1491 /*}}}*/
1492
1493
1494 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1495 /* Define or delete an element in the same "environment" as
1496  * vmstrnenv().  If an element is to be deleted, it's removed from
1497  * the first place it's found.  If it's to be set, it's set in the
1498  * place designated by the first element of the table vector.
1499  * Like setenv() returns 0 for success, non-zero on error.
1500  */
1501 int
1502 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1503 {
1504     const char *cp1;
1505     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1506     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1507     int nseg = 0, j;
1508     unsigned long int retsts, usermode = PSL$C_USER;
1509     struct itmlst_3 *ile, *ilist;
1510     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1511                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1512                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1513     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1514     $DESCRIPTOR(local,"_LOCAL");
1515
1516     if (!lnm) {
1517         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1518         return SS$_IVLOGNAM;
1519     }
1520
1521     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1522       *cp2 = _toupper(*cp1);
1523       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1524         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1525         return SS$_IVLOGNAM;
1526       }
1527     }
1528     lnmdsc.dsc$w_length = cp1 - lnm;
1529     if (!tabvec || !*tabvec) tabvec = env_tables;
1530
1531     if (!eqv) {  /* we're deleting n element */
1532       for (curtab = 0; tabvec[curtab]; curtab++) {
1533         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1534         int i;
1535           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1536             if ((cp1 = strchr(environ[i],'=')) &&
1537                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1538                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1539 #ifdef HAS_SETENV
1540               return setenv(lnm,"",1) ? vaxc$errno : 0;
1541             }
1542           }
1543           ivenv = 1; retsts = SS$_NOLOGNAM;
1544 #else
1545               if (ckWARN(WARN_INTERNAL))
1546                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1547               ivenv = 1; retsts = SS$_NOSUCHPGM;
1548               break;
1549             }
1550           }
1551 #endif
1552         }
1553         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1554                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1555           unsigned int symtype;
1556           if (tabvec[curtab]->dsc$w_length == 12 &&
1557               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1558               !str$case_blind_compare(&tmpdsc,&local))
1559             symtype = LIB$K_CLI_LOCAL_SYM;
1560           else symtype = LIB$K_CLI_GLOBAL_SYM;
1561           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1562           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1563           if (retsts == LIB$_NOSUCHSYM) continue;
1564           break;
1565         }
1566         else if (!ivlnm) {
1567           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1568           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1569           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1570           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1571           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1572         }
1573       }
1574     }
1575     else {  /* we're defining a value */
1576       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1577 #ifdef HAS_SETENV
1578         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1579 #else
1580         if (ckWARN(WARN_INTERNAL))
1581           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1582         retsts = SS$_NOSUCHPGM;
1583 #endif
1584       }
1585       else {
1586         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1587         eqvdsc.dsc$w_length  = strlen(eqv);
1588         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1589             !str$case_blind_compare(&tmpdsc,&clisym)) {
1590           unsigned int symtype;
1591           if (tabvec[0]->dsc$w_length == 12 &&
1592               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1593                !str$case_blind_compare(&tmpdsc,&local))
1594             symtype = LIB$K_CLI_LOCAL_SYM;
1595           else symtype = LIB$K_CLI_GLOBAL_SYM;
1596           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1597         }
1598         else {
1599           if (!*eqv) eqvdsc.dsc$w_length = 1;
1600           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1601
1602             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1603             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1604               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1605                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1606               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1607               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1608             }
1609
1610             Newx(ilist,nseg+1,struct itmlst_3);
1611             ile = ilist;
1612             if (!ile) {
1613               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1614               return SS$_INSFMEM;
1615             }
1616             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1617
1618             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1619               ile->itmcode = LNM$_STRING;
1620               ile->bufadr = c;
1621               if ((j+1) == nseg) {
1622                 ile->buflen = strlen(c);
1623                 /* in case we are truncating one that's too long */
1624                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1625               }
1626               else {
1627                 ile->buflen = LNM$C_NAMLENGTH;
1628               }
1629             }
1630
1631             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1632             Safefree (ilist);
1633           }
1634           else {
1635             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1636           }
1637         }
1638       }
1639     }
1640     if (!(retsts & 1)) {
1641       switch (retsts) {
1642         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1643         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1644           set_errno(EVMSERR); break;
1645         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1646         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1647           set_errno(EINVAL); break;
1648         case SS$_NOPRIV:
1649           set_errno(EACCES); break;
1650         default:
1651           _ckvmssts(retsts);
1652           set_errno(EVMSERR);
1653        }
1654        set_vaxc_errno(retsts);
1655        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1656     }
1657     else {
1658       /* We reset error values on success because Perl does an hv_fetch()
1659        * before each hv_store(), and if the thing we're setting didn't
1660        * previously exist, we've got a leftover error message.  (Of course,
1661        * this fails in the face of
1662        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1663        * in that the error reported in $! isn't spurious,
1664        * but it's right more often than not.)
1665        */
1666       set_errno(0); set_vaxc_errno(retsts);
1667       return 0;
1668     }
1669
1670 }  /* end of vmssetenv() */
1671 /*}}}*/
1672
1673 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1674 /* This has to be a function since there's a prototype for it in proto.h */
1675 void
1676 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1677 {
1678     if (lnm && *lnm) {
1679       int len = strlen(lnm);
1680       if  (len == 7) {
1681         char uplnm[8];
1682         int i;
1683         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1684         if (!strcmp(uplnm,"DEFAULT")) {
1685           if (eqv && *eqv) my_chdir(eqv);
1686           return;
1687         }
1688     }
1689 #ifndef RTL_USES_UTC
1690     if (len == 6 || len == 2) {
1691       char uplnm[7];
1692       int i;
1693       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1694       uplnm[len] = '\0';
1695       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1696       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1697     }
1698 #endif
1699   }
1700   (void) vmssetenv(lnm,eqv,NULL);
1701 }
1702 /*}}}*/
1703
1704 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1705 /*  vmssetuserlnm
1706  *  sets a user-mode logical in the process logical name table
1707  *  used for redirection of sys$error
1708  */
1709 void
1710 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1711 {
1712     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1713     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1714     unsigned long int iss, attr = LNM$M_CONFINE;
1715     unsigned char acmode = PSL$C_USER;
1716     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1717                                  {0, 0, 0, 0}};
1718     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1719     d_name.dsc$w_length = strlen(name);
1720
1721     lnmlst[0].buflen = strlen(eqv);
1722     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1723
1724     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1725     if (!(iss&1)) lib$signal(iss);
1726 }
1727 /*}}}*/
1728
1729
1730 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1731 /* my_crypt - VMS password hashing
1732  * my_crypt() provides an interface compatible with the Unix crypt()
1733  * C library function, and uses sys$hash_password() to perform VMS
1734  * password hashing.  The quadword hashed password value is returned
1735  * as a NUL-terminated 8 character string.  my_crypt() does not change
1736  * the case of its string arguments; in order to match the behavior
1737  * of LOGINOUT et al., alphabetic characters in both arguments must
1738  *  be upcased by the caller.
1739  *
1740  * - fix me to call ACM services when available
1741  */
1742 char *
1743 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1744 {
1745 #   ifndef UAI$C_PREFERRED_ALGORITHM
1746 #     define UAI$C_PREFERRED_ALGORITHM 127
1747 #   endif
1748     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1749     unsigned short int salt = 0;
1750     unsigned long int sts;
1751     struct const_dsc {
1752         unsigned short int dsc$w_length;
1753         unsigned char      dsc$b_type;
1754         unsigned char      dsc$b_class;
1755         const char *       dsc$a_pointer;
1756     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1757        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1758     struct itmlst_3 uailst[3] = {
1759         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1760         { sizeof salt, UAI$_SALT,    &salt, 0},
1761         { 0,           0,            NULL,  NULL}};
1762     static char hash[9];
1763
1764     usrdsc.dsc$w_length = strlen(usrname);
1765     usrdsc.dsc$a_pointer = usrname;
1766     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1767       switch (sts) {
1768         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1769           set_errno(EACCES);
1770           break;
1771         case RMS$_RNF:
1772           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1773           break;
1774         default:
1775           set_errno(EVMSERR);
1776       }
1777       set_vaxc_errno(sts);
1778       if (sts != RMS$_RNF) return NULL;
1779     }
1780
1781     txtdsc.dsc$w_length = strlen(textpasswd);
1782     txtdsc.dsc$a_pointer = textpasswd;
1783     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1784       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1785     }
1786
1787     return (char *) hash;
1788
1789 }  /* end of my_crypt() */
1790 /*}}}*/
1791
1792
1793 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1794 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1795 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1796
1797 /* fixup barenames that are directories for internal use.
1798  * There have been problems with the consistent handling of UNIX
1799  * style directory names when routines are presented with a name that
1800  * has no directory delimitors at all.  So this routine will eventually
1801  * fix the issue.
1802  */
1803 static char * fixup_bare_dirnames(const char * name)
1804 {
1805   if (decc_disable_to_vms_logname_translation) {
1806 /* fix me */
1807   }
1808   return NULL;
1809 }
1810
1811 /* 8.3, remove() is now broken on symbolic links */
1812 static int rms_erase(const char * vmsname);
1813
1814
1815 /* mp_do_kill_file
1816  * A little hack to get around a bug in some implemenation of remove()
1817  * that do not know how to delete a directory
1818  *
1819  * Delete any file to which user has control access, regardless of whether
1820  * delete access is explicitly allowed.
1821  * Limitations: User must have write access to parent directory.
1822  *              Does not block signals or ASTs; if interrupted in midstream
1823  *              may leave file with an altered ACL.
1824  * HANDLE WITH CARE!
1825  */
1826 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1827 static int
1828 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1829 {
1830     char *vmsname;
1831     char *rslt;
1832     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1833     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1834     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1835     struct myacedef {
1836       unsigned char myace$b_length;
1837       unsigned char myace$b_type;
1838       unsigned short int myace$w_flags;
1839       unsigned long int myace$l_access;
1840       unsigned long int myace$l_ident;
1841     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1842                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1843       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1844      struct itmlst_3
1845        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1846                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1847        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1848        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1849        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1850        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1851
1852     /* Expand the input spec using RMS, since the CRTL remove() and
1853      * system services won't do this by themselves, so we may miss
1854      * a file "hiding" behind a logical name or search list. */
1855     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1856     if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1857
1858     rslt = do_rmsexpand(name,
1859                         vmsname,
1860                         0,
1861                         NULL,
1862                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
1863                         NULL,
1864                         NULL);
1865     if (rslt == NULL) {
1866         PerlMem_free(vmsname);
1867         return -1;
1868       }
1869
1870     /* Erase the file */
1871     rmsts = rms_erase(vmsname);
1872
1873     /* Did it succeed */
1874     if ($VMS_STATUS_SUCCESS(rmsts)) {
1875         PerlMem_free(vmsname);
1876         return 0;
1877       }
1878
1879     /* If not, can changing protections help? */
1880     if (rmsts != RMS$_PRV) {
1881       set_vaxc_errno(rmsts);
1882       PerlMem_free(vmsname);
1883       return -1;
1884     }
1885
1886     /* No, so we get our own UIC to use as a rights identifier,
1887      * and the insert an ACE at the head of the ACL which allows us
1888      * to delete the file.
1889      */
1890     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1891     fildsc.dsc$w_length = strlen(vmsname);
1892     fildsc.dsc$a_pointer = vmsname;
1893     cxt = 0;
1894     newace.myace$l_ident = oldace.myace$l_ident;
1895     rmsts = -1;
1896     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1897       switch (aclsts) {
1898         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1899           set_errno(ENOENT); break;
1900         case RMS$_DIR:
1901           set_errno(ENOTDIR); break;
1902         case RMS$_DEV:
1903           set_errno(ENODEV); break;
1904         case RMS$_SYN: case SS$_INVFILFOROP:
1905           set_errno(EINVAL); break;
1906         case RMS$_PRV:
1907           set_errno(EACCES); break;
1908         default:
1909           _ckvmssts(aclsts);
1910       }
1911       set_vaxc_errno(aclsts);
1912       PerlMem_free(vmsname);
1913       return -1;
1914     }
1915     /* Grab any existing ACEs with this identifier in case we fail */
1916     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1917     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1918                     || fndsts == SS$_NOMOREACE ) {
1919       /* Add the new ACE . . . */
1920       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1921         goto yourroom;
1922
1923       rmsts = rms_erase(vmsname);
1924       if ($VMS_STATUS_SUCCESS(rmsts)) {
1925         rmsts = 0;
1926         }
1927         else {
1928         rmsts = -1;
1929         /* We blew it - dir with files in it, no write priv for
1930          * parent directory, etc.  Put things back the way they were. */
1931         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1932           goto yourroom;
1933         if (fndsts & 1) {
1934           addlst[0].bufadr = &oldace;
1935           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1936             goto yourroom;
1937         }
1938       }
1939     }
1940
1941     yourroom:
1942     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1943     /* We just deleted it, so of course it's not there.  Some versions of
1944      * VMS seem to return success on the unlock operation anyhow (after all
1945      * the unlock is successful), but others don't.
1946      */
1947     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1948     if (aclsts & 1) aclsts = fndsts;
1949     if (!(aclsts & 1)) {
1950       set_errno(EVMSERR);
1951       set_vaxc_errno(aclsts);
1952     }
1953
1954     PerlMem_free(vmsname);
1955     return rmsts;
1956
1957 }  /* end of kill_file() */
1958 /*}}}*/
1959
1960
1961 /*{{{int do_rmdir(char *name)*/
1962 int
1963 Perl_do_rmdir(pTHX_ const char *name)
1964 {
1965     char * dirfile;
1966     int retval;
1967     Stat_t st;
1968
1969     dirfile = PerlMem_malloc(VMS_MAXRSS + 1);
1970     if (dirfile == NULL)
1971         _ckvmssts(SS$_INSFMEM);
1972
1973     /* Force to a directory specification */
1974     if (do_fileify_dirspec(name, dirfile, 0, NULL) == NULL) {
1975         PerlMem_free(dirfile);
1976         return -1;
1977     }
1978     if (Perl_flex_lstat(aTHX_ dirfile, &st) || !S_ISDIR(st.st_mode)) {
1979         errno = ENOTDIR;
1980         retval = -1;
1981     }
1982     else
1983         retval = mp_do_kill_file(aTHX_ dirfile, 1);
1984
1985     PerlMem_free(dirfile);
1986     return retval;
1987
1988 }  /* end of do_rmdir */
1989 /*}}}*/
1990
1991 /* kill_file
1992  * Delete any file to which user has control access, regardless of whether
1993  * delete access is explicitly allowed.
1994  * Limitations: User must have write access to parent directory.
1995  *              Does not block signals or ASTs; if interrupted in midstream
1996  *              may leave file with an altered ACL.
1997  * HANDLE WITH CARE!
1998  */
1999 /*{{{int kill_file(char *name)*/
2000 int
2001 Perl_kill_file(pTHX_ const char *name)
2002 {
2003     char rspec[NAM$C_MAXRSS+1];
2004     char *tspec;
2005     Stat_t st;
2006     int rmsts;
2007
2008    /* Remove() is allowed to delete directories, according to the X/Open
2009     * specifications.
2010     * This may need special handling to work with the ACL hacks.
2011      */
2012    if ((flex_lstat(name, &st) == 0) && S_ISDIR(st.st_mode)) {
2013         rmsts = Perl_do_rmdir(aTHX_ name);
2014         return rmsts;
2015     }
2016
2017    rmsts = mp_do_kill_file(aTHX_ name, 0);
2018
2019     return rmsts;
2020
2021 }  /* end of kill_file() */
2022 /*}}}*/
2023
2024
2025 /*{{{int my_mkdir(char *,Mode_t)*/
2026 int
2027 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2028 {
2029   STRLEN dirlen = strlen(dir);
2030
2031   /* zero length string sometimes gives ACCVIO */
2032   if (dirlen == 0) return -1;
2033
2034   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2035    * null file name/type.  However, it's commonplace under Unix,
2036    * so we'll allow it for a gain in portability.
2037    */
2038   if (dir[dirlen-1] == '/') {
2039     char *newdir = savepvn(dir,dirlen-1);
2040     int ret = mkdir(newdir,mode);
2041     Safefree(newdir);
2042     return ret;
2043   }
2044   else return mkdir(dir,mode);
2045 }  /* end of my_mkdir */
2046 /*}}}*/
2047
2048 /*{{{int my_chdir(char *)*/
2049 int
2050 Perl_my_chdir(pTHX_ const char *dir)
2051 {
2052   STRLEN dirlen = strlen(dir);
2053
2054   /* zero length string sometimes gives ACCVIO */
2055   if (dirlen == 0) return -1;
2056   const char *dir1;
2057
2058   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2059    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2060    * so that existing scripts do not need to be changed.
2061    */
2062   dir1 = dir;
2063   while ((dirlen > 0) && (*dir1 == ' ')) {
2064     dir1++;
2065     dirlen--;
2066   }
2067
2068   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2069    * that implies
2070    * null file name/type.  However, it's commonplace under Unix,
2071    * so we'll allow it for a gain in portability.
2072    *
2073    * - Preview- '/' will be valid soon on VMS
2074    */
2075   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2076     char *newdir = savepvn(dir1,dirlen-1);
2077     int ret = chdir(newdir);
2078     Safefree(newdir);
2079     return ret;
2080   }
2081   else return chdir(dir1);
2082 }  /* end of my_chdir */
2083 /*}}}*/
2084
2085
2086 /*{{{int my_chmod(char *, mode_t)*/
2087 int
2088 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2089 {
2090   STRLEN speclen = strlen(file_spec);
2091
2092   /* zero length string sometimes gives ACCVIO */
2093   if (speclen == 0) return -1;
2094
2095   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2096    * that implies null file name/type.  However, it's commonplace under Unix,
2097    * so we'll allow it for a gain in portability.
2098    *
2099    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2100    * in VMS file.dir notation.
2101    */
2102   if ((speclen > 1) && (file_spec[speclen-1] == '/')) {
2103     char *vms_src, *vms_dir, *rslt;
2104     int ret = -1;
2105     errno = EIO;
2106
2107     /* First convert this to a VMS format specification */
2108     vms_src = PerlMem_malloc(VMS_MAXRSS);
2109     if (vms_src == NULL)
2110         _ckvmssts(SS$_INSFMEM);
2111
2112     rslt = do_tovmsspec(file_spec, vms_src, 0, NULL);
2113     if (rslt == NULL) {
2114         /* If we fail, then not a file specification */
2115         PerlMem_free(vms_src);
2116         errno = EIO;
2117         return -1;
2118     }
2119
2120     /* Now make it a directory spec so chmod is happy */
2121     vms_dir = PerlMem_malloc(VMS_MAXRSS + 1);
2122     if (vms_dir == NULL)
2123         _ckvmssts(SS$_INSFMEM);
2124     rslt = do_fileify_dirspec(vms_src, vms_dir, 0, NULL);
2125     PerlMem_free(vms_src);
2126
2127     /* Now do it */
2128     if (rslt != NULL) {
2129         ret = chmod(vms_dir, mode);
2130     } else {
2131         errno = EIO;
2132     }
2133     PerlMem_free(vms_dir);
2134     return ret;
2135   }
2136   else return chmod(file_spec, mode);
2137 }  /* end of my_chmod */
2138 /*}}}*/
2139
2140
2141 /*{{{FILE *my_tmpfile()*/
2142 FILE *
2143 my_tmpfile(void)
2144 {
2145   FILE *fp;
2146   char *cp;
2147
2148   if ((fp = tmpfile())) return fp;
2149
2150   cp = PerlMem_malloc(L_tmpnam+24);
2151   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2152
2153   if (decc_filename_unix_only == 0)
2154     strcpy(cp,"Sys$Scratch:");
2155   else
2156     strcpy(cp,"/tmp/");
2157   tmpnam(cp+strlen(cp));
2158   strcat(cp,".Perltmp");
2159   fp = fopen(cp,"w+","fop=dlt");
2160   PerlMem_free(cp);
2161   return fp;
2162 }
2163 /*}}}*/
2164
2165
2166 #ifndef HOMEGROWN_POSIX_SIGNALS
2167 /*
2168  * The C RTL's sigaction fails to check for invalid signal numbers so we
2169  * help it out a bit.  The docs are correct, but the actual routine doesn't
2170  * do what the docs say it will.
2171  */
2172 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2173 int
2174 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2175                    struct sigaction* oact)
2176 {
2177   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2178         SETERRNO(EINVAL, SS$_INVARG);
2179         return -1;
2180   }
2181   return sigaction(sig, act, oact);
2182 }
2183 /*}}}*/
2184 #endif
2185
2186 #ifdef KILL_BY_SIGPRC
2187 #include <errnodef.h>
2188
2189 /* We implement our own kill() using the undocumented system service
2190    sys$sigprc for one of two reasons:
2191
2192    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2193    target process to do a sys$exit, which usually can't be handled
2194    gracefully...certainly not by Perl and the %SIG{} mechanism.
2195
2196    2.) If the kill() in the CRTL can't be called from a signal
2197    handler without disappearing into the ether, i.e., the signal
2198    it purportedly sends is never trapped. Still true as of VMS 7.3.
2199
2200    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2201    in the target process rather than calling sys$exit.
2202
2203    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2204    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2205    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2206    with condition codes C$_SIG0+nsig*8, catching the exception on the
2207    target process and resignaling with appropriate arguments.
2208
2209    But we don't have that VMS 7.0+ exception handler, so if you
2210    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2211
2212    Also note that SIGTERM is listed in the docs as being "unimplemented",
2213    yet always seems to be signaled with a VMS condition code of 4 (and
2214    correctly handled for that code).  So we hardwire it in.
2215
2216    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2217    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2218    than signalling with an unrecognized (and unhandled by CRTL) code.
2219 */
2220
2221 #define _MY_SIG_MAX 28
2222
2223 static unsigned int
2224 Perl_sig_to_vmscondition_int(int sig)
2225 {
2226     static unsigned int sig_code[_MY_SIG_MAX+1] =
2227     {
2228         0,                  /*  0 ZERO     */
2229         SS$_HANGUP,         /*  1 SIGHUP   */
2230         SS$_CONTROLC,       /*  2 SIGINT   */
2231         SS$_CONTROLY,       /*  3 SIGQUIT  */
2232         SS$_RADRMOD,        /*  4 SIGILL   */
2233         SS$_BREAK,          /*  5 SIGTRAP  */
2234         SS$_OPCCUS,         /*  6 SIGABRT  */
2235         SS$_COMPAT,         /*  7 SIGEMT   */
2236 #ifdef __VAX
2237         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2238 #else
2239         SS$_HPARITH,        /*  8 SIGFPE AXP */
2240 #endif
2241         SS$_ABORT,          /*  9 SIGKILL  */
2242         SS$_ACCVIO,         /* 10 SIGBUS   */
2243         SS$_ACCVIO,         /* 11 SIGSEGV  */
2244         SS$_BADPARAM,       /* 12 SIGSYS   */
2245         SS$_NOMBX,          /* 13 SIGPIPE  */
2246         SS$_ASTFLT,         /* 14 SIGALRM  */
2247         4,                  /* 15 SIGTERM  */
2248         0,                  /* 16 SIGUSR1  */
2249         0,                  /* 17 SIGUSR2  */
2250         0,                  /* 18 */
2251         0,                  /* 19 */
2252         0,                  /* 20 SIGCHLD  */
2253         0,                  /* 21 SIGCONT  */
2254         0,                  /* 22 SIGSTOP  */
2255         0,                  /* 23 SIGTSTP  */
2256         0,                  /* 24 SIGTTIN  */
2257         0,                  /* 25 SIGTTOU  */
2258         0,                  /* 26 */
2259         0,                  /* 27 */
2260         0                   /* 28 SIGWINCH  */
2261     };
2262
2263 #if __VMS_VER >= 60200000
2264     static int initted = 0;
2265     if (!initted) {
2266         initted = 1;
2267         sig_code[16] = C$_SIGUSR1;
2268         sig_code[17] = C$_SIGUSR2;
2269 #if __CRTL_VER >= 70000000
2270         sig_code[20] = C$_SIGCHLD;
2271 #endif
2272 #if __CRTL_VER >= 70300000
2273         sig_code[28] = C$_SIGWINCH;
2274 #endif
2275     }
2276 #endif
2277
2278     if (sig < _SIG_MIN) return 0;
2279     if (sig > _MY_SIG_MAX) return 0;
2280     return sig_code[sig];
2281 }
2282
2283 unsigned int
2284 Perl_sig_to_vmscondition(int sig)
2285 {
2286 #ifdef SS$_DEBUG
2287     if (vms_debug_on_exception != 0)
2288         lib$signal(SS$_DEBUG);
2289 #endif
2290     return Perl_sig_to_vmscondition_int(sig);
2291 }
2292
2293
2294 int
2295 Perl_my_kill(int pid, int sig)
2296 {
2297     dTHX;
2298     int iss;
2299     unsigned int code;
2300     int sys$sigprc(unsigned int *pidadr,
2301                      struct dsc$descriptor_s *prcname,
2302                      unsigned int code);
2303
2304      /* sig 0 means validate the PID */
2305     /*------------------------------*/
2306     if (sig == 0) {
2307         const unsigned long int jpicode = JPI$_PID;
2308         pid_t ret_pid;
2309         int status;
2310         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2311         if ($VMS_STATUS_SUCCESS(status))
2312            return 0;
2313         switch (status) {
2314         case SS$_NOSUCHNODE:
2315         case SS$_UNREACHABLE:
2316         case SS$_NONEXPR:
2317            errno = ESRCH;
2318            break;
2319         case SS$_NOPRIV:
2320            errno = EPERM;
2321            break;
2322         default:
2323            errno = EVMSERR;
2324         }
2325         vaxc$errno=status;
2326         return -1;
2327     }
2328
2329     code = Perl_sig_to_vmscondition_int(sig);
2330
2331     if (!code) {
2332         SETERRNO(EINVAL, SS$_BADPARAM);
2333         return -1;
2334     }
2335
2336     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2337      * signals are to be sent to multiple processes.
2338      *  pid = 0 - all processes in group except ones that the system exempts
2339      *  pid = -1 - all processes except ones that the system exempts
2340      *  pid = -n - all processes in group (abs(n)) except ...
2341      * For now, just report as not supported.
2342      */
2343
2344     if (pid <= 0) {
2345         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2346         return -1;
2347     }
2348
2349     iss = sys$sigprc((unsigned int *)&pid,0,code);
2350     if (iss&1) return 0;
2351
2352     switch (iss) {
2353       case SS$_NOPRIV:
2354         set_errno(EPERM);  break;
2355       case SS$_NONEXPR:
2356       case SS$_NOSUCHNODE:
2357       case SS$_UNREACHABLE:
2358         set_errno(ESRCH);  break;
2359       case SS$_INSFMEM:
2360         set_errno(ENOMEM); break;
2361       default:
2362         _ckvmssts(iss);
2363         set_errno(EVMSERR);
2364     }
2365     set_vaxc_errno(iss);
2366
2367     return -1;
2368 }
2369 #endif
2370
2371 /* Routine to convert a VMS status code to a UNIX status code.
2372 ** More tricky than it appears because of conflicting conventions with
2373 ** existing code.
2374 **
2375 ** VMS status codes are a bit mask, with the least significant bit set for
2376 ** success.
2377 **
2378 ** Special UNIX status of EVMSERR indicates that no translation is currently
2379 ** available, and programs should check the VMS status code.
2380 **
2381 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2382 ** decoding.
2383 */
2384
2385 #ifndef C_FACILITY_NO
2386 #define C_FACILITY_NO 0x350000
2387 #endif
2388 #ifndef DCL_IVVERB
2389 #define DCL_IVVERB 0x38090
2390 #endif
2391
2392 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2393 {
2394 int facility;
2395 int fac_sp;
2396 int msg_no;
2397 int msg_status;
2398 int unix_status;
2399
2400   /* Assume the best or the worst */
2401   if (vms_status & STS$M_SUCCESS)
2402     unix_status = 0;
2403   else
2404     unix_status = EVMSERR;
2405
2406   msg_status = vms_status & ~STS$M_CONTROL;
2407
2408   facility = vms_status & STS$M_FAC_NO;
2409   fac_sp = vms_status & STS$M_FAC_SP;
2410   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2411
2412   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2413     switch(msg_no) {
2414     case SS$_NORMAL:
2415         unix_status = 0;
2416         break;
2417     case SS$_ACCVIO:
2418         unix_status = EFAULT;
2419         break;
2420     case SS$_DEVOFFLINE:
2421         unix_status = EBUSY;
2422         break;
2423     case SS$_CLEARED:
2424         unix_status = ENOTCONN;
2425         break;
2426     case SS$_IVCHAN:
2427     case SS$_IVLOGNAM:
2428     case SS$_BADPARAM:
2429     case SS$_IVLOGTAB:
2430     case SS$_NOLOGNAM:
2431     case SS$_NOLOGTAB:
2432     case SS$_INVFILFOROP:
2433     case SS$_INVARG:
2434     case SS$_NOSUCHID:
2435     case SS$_IVIDENT:
2436         unix_status = EINVAL;
2437         break;
2438     case SS$_UNSUPPORTED:
2439         unix_status = ENOTSUP;
2440         break;
2441     case SS$_FILACCERR:
2442     case SS$_NOGRPPRV:
2443     case SS$_NOSYSPRV:
2444         unix_status = EACCES;
2445         break;
2446     case SS$_DEVICEFULL:
2447         unix_status = ENOSPC;
2448         break;
2449     case SS$_NOSUCHDEV:
2450         unix_status = ENODEV;
2451         break;
2452     case SS$_NOSUCHFILE:
2453     case SS$_NOSUCHOBJECT:
2454         unix_status = ENOENT;
2455         break;
2456     case SS$_ABORT:                                 /* Fatal case */
2457     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2458     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2459         unix_status = EINTR;
2460         break;
2461     case SS$_BUFFEROVF:
2462         unix_status = E2BIG;
2463         break;
2464     case SS$_INSFMEM:
2465         unix_status = ENOMEM;
2466         break;
2467     case SS$_NOPRIV:
2468         unix_status = EPERM;
2469         break;
2470     case SS$_NOSUCHNODE:
2471     case SS$_UNREACHABLE:
2472         unix_status = ESRCH;
2473         break;
2474     case SS$_NONEXPR:
2475         unix_status = ECHILD;
2476         break;
2477     default:
2478         if ((facility == 0) && (msg_no < 8)) {
2479           /* These are not real VMS status codes so assume that they are
2480           ** already UNIX status codes
2481           */
2482           unix_status = msg_no;
2483           break;
2484         }
2485     }
2486   }
2487   else {
2488     /* Translate a POSIX exit code to a UNIX exit code */
2489     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2490         unix_status = (msg_no & 0x07F8) >> 3;
2491     }
2492     else {
2493
2494          /* Documented traditional behavior for handling VMS child exits */
2495         /*--------------------------------------------------------------*/
2496         if (child_flag != 0) {
2497
2498              /* Success / Informational return 0 */
2499             /*----------------------------------*/
2500             if (msg_no & STS$K_SUCCESS)
2501                 return 0;
2502
2503              /* Warning returns 1 */
2504             /*-------------------*/
2505             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2506                 return 1;
2507
2508              /* Everything else pass through the severity bits */
2509             /*------------------------------------------------*/
2510             return (msg_no & STS$M_SEVERITY);
2511         }
2512
2513          /* Normal VMS status to ERRNO mapping attempt */
2514         /*--------------------------------------------*/
2515         switch(msg_status) {
2516         /* case RMS$_EOF: */ /* End of File */
2517         case RMS$_FNF:  /* File Not Found */
2518         case RMS$_DNF:  /* Dir Not Found */
2519                 unix_status = ENOENT;
2520                 break;
2521         case RMS$_RNF:  /* Record Not Found */
2522                 unix_status = ESRCH;
2523                 break;
2524         case RMS$_DIR:
2525                 unix_status = ENOTDIR;
2526                 break;
2527         case RMS$_DEV:
2528                 unix_status = ENODEV;
2529                 break;
2530         case RMS$_IFI:
2531         case RMS$_FAC:
2532         case RMS$_ISI:
2533                 unix_status = EBADF;
2534                 break;
2535         case RMS$_FEX:
2536                 unix_status = EEXIST;
2537                 break;
2538         case RMS$_SYN:
2539         case RMS$_FNM:
2540         case LIB$_INVSTRDES:
2541         case LIB$_INVARG:
2542         case LIB$_NOSUCHSYM:
2543         case LIB$_INVSYMNAM:
2544         case DCL_IVVERB:
2545                 unix_status = EINVAL;
2546                 break;
2547         case CLI$_BUFOVF:
2548         case RMS$_RTB:
2549         case CLI$_TKNOVF:
2550         case CLI$_RSLOVF:
2551                 unix_status = E2BIG;
2552                 break;
2553         case RMS$_PRV:  /* No privilege */
2554         case RMS$_ACC:  /* ACP file access failed */
2555         case RMS$_WLK:  /* Device write locked */
2556                 unix_status = EACCES;
2557                 break;
2558         /* case RMS$_NMF: */  /* No more files */
2559         }
2560     }
2561   }
2562
2563   return unix_status;
2564 }
2565
2566 /* Try to guess at what VMS error status should go with a UNIX errno
2567  * value.  This is hard to do as there could be many possible VMS
2568  * error statuses that caused the errno value to be set.
2569  */
2570
2571 int Perl_unix_status_to_vms(int unix_status)
2572 {
2573 int test_unix_status;
2574
2575      /* Trivial cases first */
2576     /*---------------------*/
2577     if (unix_status == EVMSERR)
2578         return vaxc$errno;
2579
2580      /* Is vaxc$errno sane? */
2581     /*---------------------*/
2582     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2583     if (test_unix_status == unix_status)
2584         return vaxc$errno;
2585
2586      /* If way out of range, must be VMS code already */
2587     /*-----------------------------------------------*/
2588     if (unix_status > EVMSERR)
2589         return unix_status;
2590
2591      /* If out of range, punt */
2592     /*-----------------------*/
2593     if (unix_status > __ERRNO_MAX)
2594         return SS$_ABORT;
2595
2596
2597      /* Ok, now we have to do it the hard way. */
2598     /*----------------------------------------*/
2599     switch(unix_status) {
2600     case 0:     return SS$_NORMAL;
2601     case EPERM: return SS$_NOPRIV;
2602     case ENOENT: return SS$_NOSUCHOBJECT;
2603     case ESRCH: return SS$_UNREACHABLE;
2604     case EINTR: return SS$_ABORT;
2605     /* case EIO: */
2606     /* case ENXIO:  */
2607     case E2BIG: return SS$_BUFFEROVF;
2608     /* case ENOEXEC */
2609     case EBADF: return RMS$_IFI;
2610     case ECHILD: return SS$_NONEXPR;
2611     /* case EAGAIN */
2612     case ENOMEM: return SS$_INSFMEM;
2613     case EACCES: return SS$_FILACCERR;
2614     case EFAULT: return SS$_ACCVIO;
2615     /* case ENOTBLK */
2616     case EBUSY: return SS$_DEVOFFLINE;
2617     case EEXIST: return RMS$_FEX;
2618     /* case EXDEV */
2619     case ENODEV: return SS$_NOSUCHDEV;
2620     case ENOTDIR: return RMS$_DIR;
2621     /* case EISDIR */
2622     case EINVAL: return SS$_INVARG;
2623     /* case ENFILE */
2624     /* case EMFILE */
2625     /* case ENOTTY */
2626     /* case ETXTBSY */
2627     /* case EFBIG */
2628     case ENOSPC: return SS$_DEVICEFULL;
2629     case ESPIPE: return LIB$_INVARG;
2630     /* case EROFS: */
2631     /* case EMLINK: */
2632     /* case EPIPE: */
2633     /* case EDOM */
2634     case ERANGE: return LIB$_INVARG;
2635     /* case EWOULDBLOCK */
2636     /* case EINPROGRESS */
2637     /* case EALREADY */
2638     /* case ENOTSOCK */
2639     /* case EDESTADDRREQ */
2640     /* case EMSGSIZE */
2641     /* case EPROTOTYPE */
2642     /* case ENOPROTOOPT */
2643     /* case EPROTONOSUPPORT */
2644     /* case ESOCKTNOSUPPORT */
2645     /* case EOPNOTSUPP */
2646     /* case EPFNOSUPPORT */
2647     /* case EAFNOSUPPORT */
2648     /* case EADDRINUSE */
2649     /* case EADDRNOTAVAIL */
2650     /* case ENETDOWN */
2651     /* case ENETUNREACH */
2652     /* case ENETRESET */
2653     /* case ECONNABORTED */
2654     /* case ECONNRESET */
2655     /* case ENOBUFS */
2656     /* case EISCONN */
2657     case ENOTCONN: return SS$_CLEARED;
2658     /* case ESHUTDOWN */
2659     /* case ETOOMANYREFS */
2660     /* case ETIMEDOUT */
2661     /* case ECONNREFUSED */
2662     /* case ELOOP */
2663     /* case ENAMETOOLONG */
2664     /* case EHOSTDOWN */
2665     /* case EHOSTUNREACH */
2666     /* case ENOTEMPTY */
2667     /* case EPROCLIM */
2668     /* case EUSERS  */
2669     /* case EDQUOT  */
2670     /* case ENOMSG  */
2671     /* case EIDRM */
2672     /* case EALIGN */
2673     /* case ESTALE */
2674     /* case EREMOTE */
2675     /* case ENOLCK */
2676     /* case ENOSYS */
2677     /* case EFTYPE */
2678     /* case ECANCELED */
2679     /* case EFAIL */
2680     /* case EINPROG */
2681     case ENOTSUP:
2682         return SS$_UNSUPPORTED;
2683     /* case EDEADLK */
2684     /* case ENWAIT */
2685     /* case EILSEQ */
2686     /* case EBADCAT */
2687     /* case EBADMSG */
2688     /* case EABANDONED */
2689     default:
2690         return SS$_ABORT; /* punt */
2691     }
2692
2693   return SS$_ABORT; /* Should not get here */
2694 }
2695
2696
2697 /* default piping mailbox size */
2698 #define PERL_BUFSIZ        512
2699
2700
2701 static void
2702 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2703 {
2704   unsigned long int mbxbufsiz;
2705   static unsigned long int syssize = 0;
2706   unsigned long int dviitm = DVI$_DEVNAM;
2707   char csize[LNM$C_NAMLENGTH+1];
2708   int sts;
2709
2710   if (!syssize) {
2711     unsigned long syiitm = SYI$_MAXBUF;
2712     /*
2713      * Get the SYSGEN parameter MAXBUF
2714      *
2715      * If the logical 'PERL_MBX_SIZE' is defined
2716      * use the value of the logical instead of PERL_BUFSIZ, but
2717      * keep the size between 128 and MAXBUF.
2718      *
2719      */
2720     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2721   }
2722
2723   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2724       mbxbufsiz = atoi(csize);
2725   } else {
2726       mbxbufsiz = PERL_BUFSIZ;
2727   }
2728   if (mbxbufsiz < 128) mbxbufsiz = 128;
2729   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2730
2731   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2732
2733   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2734   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2735
2736 }  /* end of create_mbx() */
2737
2738
2739 /*{{{  my_popen and my_pclose*/
2740
2741 typedef struct _iosb           IOSB;
2742 typedef struct _iosb*         pIOSB;
2743 typedef struct _pipe           Pipe;
2744 typedef struct _pipe*         pPipe;
2745 typedef struct pipe_details    Info;
2746 typedef struct pipe_details*  pInfo;
2747 typedef struct _srqp            RQE;
2748 typedef struct _srqp*          pRQE;
2749 typedef struct _tochildbuf      CBuf;
2750 typedef struct _tochildbuf*    pCBuf;
2751
2752 struct _iosb {
2753     unsigned short status;
2754     unsigned short count;
2755     unsigned long  dvispec;
2756 };
2757
2758 #pragma member_alignment save
2759 #pragma nomember_alignment quadword
2760 struct _srqp {          /* VMS self-relative queue entry */
2761     unsigned long qptr[2];
2762 };
2763 #pragma member_alignment restore
2764 static RQE  RQE_ZERO = {0,0};
2765
2766 struct _tochildbuf {
2767     RQE             q;
2768     int             eof;
2769     unsigned short  size;
2770     char            *buf;
2771 };
2772
2773 struct _pipe {
2774     RQE            free;
2775     RQE            wait;
2776     int            fd_out;
2777     unsigned short chan_in;
2778     unsigned short chan_out;
2779     char          *buf;
2780     unsigned int   bufsize;
2781     IOSB           iosb;
2782     IOSB           iosb2;
2783     int           *pipe_done;
2784     int            retry;
2785     int            type;
2786     int            shut_on_empty;
2787     int            need_wake;
2788     pPipe         *home;
2789     pInfo          info;
2790     pCBuf          curr;
2791     pCBuf          curr2;
2792 #if defined(PERL_IMPLICIT_CONTEXT)
2793     void            *thx;           /* Either a thread or an interpreter */
2794                                     /* pointer, depending on how we're built */
2795 #endif
2796 };
2797
2798
2799 struct pipe_details
2800 {
2801     pInfo           next;
2802     PerlIO *fp;  /* file pointer to pipe mailbox */
2803     int useFILE; /* using stdio, not perlio */
2804     int pid;   /* PID of subprocess */
2805     int mode;  /* == 'r' if pipe open for reading */
2806     int done;  /* subprocess has completed */
2807     int waiting; /* waiting for completion/closure */
2808     int             closing;        /* my_pclose is closing this pipe */
2809     unsigned long   completion;     /* termination status of subprocess */
2810     pPipe           in;             /* pipe in to sub */
2811     pPipe           out;            /* pipe out of sub */
2812     pPipe           err;            /* pipe of sub's sys$error */
2813     int             in_done;        /* true when in pipe finished */
2814     int             out_done;
2815     int             err_done;
2816     unsigned short  xchan;          /* channel to debug xterm */
2817     unsigned short  xchan_valid;    /* channel is assigned */
2818 };
2819
2820 struct exit_control_block
2821 {
2822     struct exit_control_block *flink;
2823     unsigned long int   (*exit_routine)();
2824     unsigned long int arg_count;
2825     unsigned long int *status_address;
2826     unsigned long int exit_status;
2827 };
2828
2829 typedef struct _closed_pipes    Xpipe;
2830 typedef struct _closed_pipes*  pXpipe;
2831
2832 struct _closed_pipes {
2833     int             pid;            /* PID of subprocess */
2834     unsigned long   completion;     /* termination status of subprocess */
2835 };
2836 #define NKEEPCLOSED 50
2837 static Xpipe closed_list[NKEEPCLOSED];
2838 static int   closed_index = 0;
2839 static int   closed_num = 0;
2840
2841 #define RETRY_DELAY     "0 ::0.20"
2842 #define MAX_RETRY              50
2843
2844 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2845 static unsigned long mypid;
2846 static unsigned long delaytime[2];
2847
2848 static pInfo open_pipes = NULL;
2849 static $DESCRIPTOR(nl_desc, "NL:");
2850
2851 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2852
2853
2854
2855 static unsigned long int
2856 pipe_exit_routine(pTHX)
2857 {
2858     pInfo info;
2859     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2860     int sts, did_stuff, need_eof, j;
2861
2862    /*
2863     * Flush any pending i/o, but since we are in process run-down, be
2864     * careful about referencing PerlIO structures that may already have
2865     * been deallocated.  We may not even have an interpreter anymore.
2866     */
2867     info = open_pipes;
2868     while (info) {
2869         if (info->fp) {
2870            if (!info->useFILE
2871 #if defined(USE_ITHREADS)
2872              && my_perl
2873 #endif
2874              && PL_perlio_fd_refcnt)
2875                PerlIO_flush(info->fp);
2876            else
2877                fflush((FILE *)info->fp);
2878         }
2879         info = info->next;
2880     }
2881
2882     /*
2883      next we try sending an EOF...ignore if doesn't work, make sure we
2884      don't hang
2885     */
2886     did_stuff = 0;
2887     info = open_pipes;
2888
2889     while (info) {
2890       int need_eof;
2891       _ckvmssts_noperl(sys$setast(0));
2892       if (info->in && !info->in->shut_on_empty) {
2893         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2894                           0, 0, 0, 0, 0, 0));
2895         info->waiting = 1;
2896         did_stuff = 1;
2897       }
2898       _ckvmssts_noperl(sys$setast(1));
2899       info = info->next;
2900     }
2901
2902     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2903
2904     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2905         int nwait = 0;
2906
2907         info = open_pipes;
2908         while (info) {
2909           _ckvmssts_noperl(sys$setast(0));
2910           if (info->waiting && info->done)
2911                 info->waiting = 0;
2912           nwait += info->waiting;
2913           _ckvmssts_noperl(sys$setast(1));
2914           info = info->next;
2915         }
2916         if (!nwait) break;
2917         sleep(1);
2918     }
2919
2920     did_stuff = 0;
2921     info = open_pipes;
2922     while (info) {
2923       _ckvmssts_noperl(sys$setast(0));
2924       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2925         sts = sys$forcex(&info->pid,0,&abort);
2926         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2927         did_stuff = 1;
2928       }
2929       _ckvmssts_noperl(sys$setast(1));
2930       info = info->next;
2931     }
2932
2933     /* again, wait for effect */
2934
2935     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2936         int nwait = 0;
2937
2938         info = open_pipes;
2939         while (info) {
2940           _ckvmssts_noperl(sys$setast(0));
2941           if (info->waiting && info->done)
2942                 info->waiting = 0;
2943           nwait += info->waiting;
2944           _ckvmssts_noperl(sys$setast(1));
2945           info = info->next;
2946         }
2947         if (!nwait) break;
2948         sleep(1);
2949     }
2950
2951     info = open_pipes;
2952     while (info) {
2953       _ckvmssts_noperl(sys$setast(0));
2954       if (!info->done) {  /* We tried to be nice . . . */
2955         sts = sys$delprc(&info->pid,0);
2956         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2957         info->done = 1;  /* sys$delprc is as done as we're going to get. */
2958       }
2959       _ckvmssts_noperl(sys$setast(1));
2960       info = info->next;
2961     }
2962
2963     while(open_pipes) {
2964       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2965       else if (!(sts & 1)) retsts = sts;
2966     }
2967     return retsts;
2968 }
2969
2970 static struct exit_control_block pipe_exitblock =
2971        {(struct exit_control_block *) 0,
2972         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2973
2974 static void pipe_mbxtofd_ast(pPipe p);
2975 static void pipe_tochild1_ast(pPipe p);
2976 static void pipe_tochild2_ast(pPipe p);
2977
2978 static void
2979 popen_completion_ast(pInfo info)
2980 {
2981   pInfo i = open_pipes;
2982   int iss;
2983   int sts;
2984   pXpipe x;
2985
2986   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2987   closed_list[closed_index].pid = info->pid;
2988   closed_list[closed_index].completion = info->completion;
2989   closed_index++;
2990   if (closed_index == NKEEPCLOSED)
2991     closed_index = 0;
2992   closed_num++;
2993
2994   while (i) {
2995     if (i == info) break;
2996     i = i->next;
2997   }
2998   if (!i) return;       /* unlinked, probably freed too */
2999
3000   info->done = TRUE;
3001
3002 /*
3003     Writing to subprocess ...
3004             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3005
3006             chan_out may be waiting for "done" flag, or hung waiting
3007             for i/o completion to child...cancel the i/o.  This will
3008             put it into "snarf mode" (done but no EOF yet) that discards
3009             input.
3010
3011     Output from subprocess (stdout, stderr) needs to be flushed and
3012     shut down.   We try sending an EOF, but if the mbx is full the pipe
3013     routine should still catch the "shut_on_empty" flag, telling it to
3014     use immediate-style reads so that "mbx empty" -> EOF.
3015
3016
3017 */
3018   if (info->in && !info->in_done) {               /* only for mode=w */
3019         if (info->in->shut_on_empty && info->in->need_wake) {
3020             info->in->need_wake = FALSE;
3021             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3022         } else {
3023             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3024         }
3025   }
3026
3027   if (info->out && !info->out_done) {             /* were we also piping output? */
3028       info->out->shut_on_empty = TRUE;
3029       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3030       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3031       _ckvmssts_noperl(iss);
3032   }
3033
3034   if (info->err && !info->err_done) {        /* we were piping stderr */
3035         info->err->shut_on_empty = TRUE;
3036         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3037         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3038         _ckvmssts_noperl(iss);
3039   }
3040   _ckvmssts_noperl(sys$setef(pipe_ef));
3041
3042 }
3043
3044 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3045 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3046
3047 /*
3048     we actually differ from vmstrnenv since we use this to
3049     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3050     are pointing to the same thing
3051 */
3052
3053 static unsigned short
3054 popen_translate(pTHX_ char *logical, char *result)
3055 {
3056     int iss;
3057     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3058     $DESCRIPTOR(d_log,"");
3059     struct _il3 {
3060         unsigned short length;
3061         unsigned short code;
3062         char *         buffer_addr;
3063         unsigned short *retlenaddr;
3064     } itmlst[2];
3065     unsigned short l, ifi;
3066
3067     d_log.dsc$a_pointer = logical;
3068     d_log.dsc$w_length  = strlen(logical);
3069
3070     itmlst[0].code = LNM$_STRING;
3071     itmlst[0].length = 255;
3072     itmlst[0].buffer_addr = result;
3073     itmlst[0].retlenaddr = &l;
3074
3075     itmlst[1].code = 0;
3076     itmlst[1].length = 0;
3077     itmlst[1].buffer_addr = 0;
3078     itmlst[1].retlenaddr = 0;
3079
3080     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3081     if (iss == SS$_NOLOGNAM) {
3082         iss = SS$_NORMAL;
3083         l = 0;
3084     }
3085     if (!(iss&1)) lib$signal(iss);
3086     result[l] = '\0';
3087 /*
3088     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
3089     strip it off and return the ifi, if any
3090 */
3091     ifi  = 0;
3092     if (result[0] == 0x1b && result[1] == 0x00) {
3093         memmove(&ifi,result+2,2);
3094         strcpy(result,result+4);
3095     }
3096     return ifi;     /* this is the RMS internal file id */
3097 }
3098
3099 static void pipe_infromchild_ast(pPipe p);
3100
3101 /*
3102     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3103     inside an AST routine without worrying about reentrancy and which Perl
3104     memory allocator is being used.
3105
3106     We read data and queue up the buffers, then spit them out one at a
3107     time to the output mailbox when the output mailbox is ready for one.
3108
3109 */
3110 #define INITIAL_TOCHILDQUEUE  2
3111
3112 static pPipe
3113 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3114 {
3115     pPipe p;
3116     pCBuf b;
3117     char mbx1[64], mbx2[64];
3118     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3119                                       DSC$K_CLASS_S, mbx1},
3120                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3121                                       DSC$K_CLASS_S, mbx2};
3122     unsigned int dviitm = DVI$_DEVBUFSIZ;
3123     int j, n;
3124
3125     n = sizeof(Pipe);
3126     _ckvmssts(lib$get_vm(&n, &p));
3127
3128     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3129     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3130     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3131
3132     p->buf           = 0;
3133     p->shut_on_empty = FALSE;
3134     p->need_wake     = FALSE;
3135     p->type          = 0;
3136     p->retry         = 0;
3137     p->iosb.status   = SS$_NORMAL;
3138     p->iosb2.status  = SS$_NORMAL;
3139     p->free          = RQE_ZERO;
3140     p->wait          = RQE_ZERO;
3141     p->curr          = 0;
3142     p->curr2         = 0;
3143     p->info          = 0;
3144 #ifdef PERL_IMPLICIT_CONTEXT
3145     p->thx           = aTHX;
3146 #endif
3147
3148     n = sizeof(CBuf) + p->bufsize;
3149
3150     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3151         _ckvmssts(lib$get_vm(&n, &b));
3152         b->buf = (char *) b + sizeof(CBuf);
3153         _ckvmssts(lib$insqhi(b, &p->free));
3154     }
3155
3156     pipe_tochild2_ast(p);
3157     pipe_tochild1_ast(p);
3158     strcpy(wmbx, mbx1);
3159     strcpy(rmbx, mbx2);
3160     return p;
3161 }
3162
3163 /*  reads the MBX Perl is writing, and queues */
3164
3165 static void
3166 pipe_tochild1_ast(pPipe p)
3167 {
3168     pCBuf b = p->curr;
3169     int iss = p->iosb.status;
3170     int eof = (iss == SS$_ENDOFFILE);
3171     int sts;
3172 #ifdef PERL_IMPLICIT_CONTEXT
3173     pTHX = p->thx;
3174 #endif
3175
3176     if (p->retry) {
3177         if (eof) {
3178             p->shut_on_empty = TRUE;
3179             b->eof     = TRUE;
3180             _ckvmssts(sys$dassgn(p->chan_in));
3181         } else  {
3182             _ckvmssts(iss);
3183         }
3184
3185         b->eof  = eof;
3186         b->size = p->iosb.count;
3187         _ckvmssts(sts = lib$insqhi(b, &p->wait));
3188         if (p->need_wake) {
3189             p->need_wake = FALSE;
3190             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3191         }
3192     } else {
3193         p->retry = 1;   /* initial call */
3194     }
3195
3196     if (eof) {                  /* flush the free queue, return when done */
3197         int n = sizeof(CBuf) + p->bufsize;
3198         while (1) {
3199             iss = lib$remqti(&p->free, &b);
3200             if (iss == LIB$_QUEWASEMP) return;
3201             _ckvmssts(iss);
3202             _ckvmssts(lib$free_vm(&n, &b));
3203         }
3204     }
3205
3206     iss = lib$remqti(&p->free, &b);
3207     if (iss == LIB$_QUEWASEMP) {
3208         int n = sizeof(CBuf) + p->bufsize;
3209         _ckvmssts(lib$get_vm(&n, &b));
3210         b->buf = (char *) b + sizeof(CBuf);
3211     } else {
3212        _ckvmssts(iss);
3213     }
3214
3215     p->curr = b;
3216     iss = sys$qio(0,p->chan_in,
3217              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3218              &p->iosb,
3219              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3220     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3221     _ckvmssts(iss);
3222 }
3223
3224
3225 /* writes queued buffers to output, waits for each to complete before
3226    doing the next */
3227
3228 static void
3229 pipe_tochild2_ast(pPipe p)
3230 {
3231     pCBuf b = p->curr2;
3232     int iss = p->iosb2.status;
3233     int n = sizeof(CBuf) + p->bufsize;
3234     int done = (p->info && p->info->done) ||
3235               iss == SS$_CANCEL || iss == SS$_ABORT;
3236 #if defined(PERL_IMPLICIT_CONTEXT)
3237     pTHX = p->thx;
3238 #endif
3239
3240     do {
3241         if (p->type) {         /* type=1 has old buffer, dispose */
3242             if (p->shut_on_empty) {
3243                 _ckvmssts(lib$free_vm(&n, &b));
3244             } else {
3245                 _ckvmssts(lib$insqhi(b, &p->free));
3246             }
3247             p->type = 0;
3248         }
3249
3250         iss = lib$remqti(&p->wait, &b);
3251         if (iss == LIB$_QUEWASEMP) {
3252             if (p->shut_on_empty) {
3253                 if (done) {
3254                     _ckvmssts(sys$dassgn(p->chan_out));
3255                     *p->pipe_done = TRUE;
3256                     _ckvmssts(sys$setef(pipe_ef));
3257                 } else {
3258                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3259                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3260                 }
3261                 return;
3262             }
3263             p->need_wake = TRUE;
3264             return;
3265         }
3266         _ckvmssts(iss);
3267         p->type = 1;
3268     } while (done);
3269
3270
3271     p->curr2 = b;
3272     if (b->eof) {
3273         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3274             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3275     } else {
3276         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3277             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3278     }
3279
3280     return;
3281
3282 }
3283
3284
3285 static pPipe
3286 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3287 {
3288     pPipe p;
3289     char mbx1[64], mbx2[64];
3290     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3291                                       DSC$K_CLASS_S, mbx1},
3292                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3293                                       DSC$K_CLASS_S, mbx2};
3294     unsigned int dviitm = DVI$_DEVBUFSIZ;
3295
3296     int n = sizeof(Pipe);
3297     _ckvmssts(lib$get_vm(&n, &p));
3298     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3299     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3300
3301     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3302     n = p->bufsize * sizeof(char);
3303     _ckvmssts(lib$get_vm(&n, &p->buf));
3304     p->shut_on_empty = FALSE;
3305     p->info   = 0;
3306     p->type   = 0;
3307     p->iosb.status = SS$_NORMAL;
3308 #if defined(PERL_IMPLICIT_CONTEXT)
3309     p->thx = aTHX;
3310 #endif
3311     pipe_infromchild_ast(p);
3312
3313     strcpy(wmbx, mbx1);
3314     strcpy(rmbx, mbx2);
3315     return p;
3316 }
3317
3318 static void
3319 pipe_infromchild_ast(pPipe p)
3320 {
3321     int iss = p->iosb.status;
3322     int eof = (iss == SS$_ENDOFFILE);
3323     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3324     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3325 #if defined(PERL_IMPLICIT_CONTEXT)
3326     pTHX = p->thx;
3327 #endif
3328
3329     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3330         _ckvmssts(sys$dassgn(p->chan_out));
3331         p->chan_out = 0;
3332     }
3333
3334     /* read completed:
3335             input shutdown if EOF from self (done or shut_on_empty)
3336             output shutdown if closing flag set (my_pclose)
3337             send data/eof from child or eof from self
3338             otherwise, re-read (snarf of data from child)
3339     */
3340
3341     if (p->type == 1) {
3342         p->type = 0;
3343         if (myeof && p->chan_in) {                  /* input shutdown */
3344             _ckvmssts(sys$dassgn(p->chan_in));
3345             p->chan_in = 0;
3346         }
3347
3348         if (p->chan_out) {
3349             if (myeof || kideof) {      /* pass EOF to parent */
3350                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3351                               pipe_infromchild_ast, p,
3352                               0, 0, 0, 0, 0, 0));
3353                 return;
3354             } else if (eof) {       /* eat EOF --- fall through to read*/
3355
3356             } else {                /* transmit data */
3357                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3358                               pipe_infromchild_ast,p,
3359                               p->buf, p->iosb.count, 0, 0, 0, 0));
3360                 return;
3361             }
3362         }
3363     }
3364
3365     /*  everything shut? flag as done */
3366
3367     if (!p->chan_in && !p->chan_out) {
3368         *p->pipe_done = TRUE;
3369         _ckvmssts(sys$setef(pipe_ef));
3370         return;
3371     }
3372
3373     /* write completed (or read, if snarfing from child)
3374             if still have input active,
3375                queue read...immediate mode if shut_on_empty so we get EOF if empty
3376             otherwise,
3377                check if Perl reading, generate EOFs as needed
3378     */
3379
3380     if (p->type == 0) {
3381         p->type = 1;
3382         if (p->chan_in) {
3383             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3384                           pipe_infromchild_ast,p,
3385                           p->buf, p->bufsize, 0, 0, 0, 0);
3386             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3387             _ckvmssts(iss);
3388         } else {           /* send EOFs for extra reads */
3389             p->iosb.status = SS$_ENDOFFILE;
3390             p->iosb.dvispec = 0;
3391             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3392                       0, 0, 0,
3393                       pipe_infromchild_ast, p, 0, 0, 0, 0));
3394         }
3395     }
3396 }
3397
3398 static pPipe
3399 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3400 {
3401     pPipe p;
3402     char mbx[64];
3403     unsigned long dviitm = DVI$_DEVBUFSIZ;
3404     struct stat s;
3405     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3406                                       DSC$K_CLASS_S, mbx};
3407     int n = sizeof(Pipe);
3408
3409     /* things like terminals and mbx's don't need this filter */
3410     if (fd && fstat(fd,&s) == 0) {
3411         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3412         char device[65];
3413         unsigned short dev_len;
3414         struct dsc$descriptor_s d_dev;
3415         char * cptr;
3416         struct item_list_3 items[3];
3417         int status;
3418         unsigned short dvi_iosb[4];
3419
3420         cptr = getname(fd, out, 1);
3421         if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3422         d_dev.dsc$a_pointer = out;
3423         d_dev.dsc$w_length = strlen(out);
3424         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3425         d_dev.dsc$b_class = DSC$K_CLASS_S;
3426
3427         items[0].len = 4;
3428         items[0].code = DVI$_DEVCHAR;
3429         items[0].bufadr = &devchar;
3430         items[0].retadr = NULL;
3431         items[1].len = 64;
3432         items[1].code = DVI$_FULLDEVNAM;
3433         items[1].bufadr = device;
3434         items[1].retadr = &dev_len;
3435         items[2].len = 0;
3436         items[2].code = 0;
3437
3438         status = sys$getdviw
3439                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3440         _ckvmssts(status);
3441         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3442             device[dev_len] = 0;
3443
3444             if (!(devchar & DEV$M_DIR)) {
3445                 strcpy(out, device);
3446                 return 0;
3447             }
3448         }
3449     }
3450
3451     _ckvmssts(lib$get_vm(&n, &p));
3452     p->fd_out = dup(fd);
3453     create_mbx(aTHX_ &p->chan_in, &d_mbx);
3454     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3455     n = (p->bufsize+1) * sizeof(char);
3456     _ckvmssts(lib$get_vm(&n, &p->buf));
3457     p->shut_on_empty = FALSE;
3458     p->retry = 0;
3459     p->info  = 0;
3460     strcpy(out, mbx);
3461
3462     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3463                   pipe_mbxtofd_ast, p,
3464                   p->buf, p->bufsize, 0, 0, 0, 0));
3465
3466     return p;
3467 }
3468
3469 static void
3470 pipe_mbxtofd_ast(pPipe p)
3471 {
3472     int iss = p->iosb.status;
3473     int done = p->info->done;
3474     int iss2;
3475     int eof = (iss == SS$_ENDOFFILE);
3476     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3477     int err = !(iss&1) && !eof;
3478 #if defined(PERL_IMPLICIT_CONTEXT)
3479     pTHX = p->thx;
3480 #endif
3481
3482     if (done && myeof) {               /* end piping */
3483         close(p->fd_out);
3484         sys$dassgn(p->chan_in);
3485         *p->pipe_done = TRUE;
3486         _ckvmssts(sys$setef(pipe_ef));
3487         return;
3488     }
3489
3490     if (!err && !eof) {             /* good data to send to file */
3491         p->buf[p->iosb.count] = '\n';
3492         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3493         if (iss2 < 0) {
3494             p->retry++;
3495             if (p->retry < MAX_RETRY) {
3496                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3497                 return;
3498             }
3499         }
3500         p->retry = 0;
3501     } else if (err) {
3502         _ckvmssts(iss);
3503     }
3504
3505
3506     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3507           pipe_mbxtofd_ast, p,
3508           p->buf, p->bufsize, 0, 0, 0, 0);
3509     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3510     _ckvmssts(iss);
3511 }
3512
3513
3514 typedef struct _pipeloc     PLOC;
3515 typedef struct _pipeloc*   pPLOC;
3516
3517 struct _pipeloc {
3518     pPLOC   next;
3519     char    dir[NAM$C_MAXRSS+1];
3520 };
3521 static pPLOC  head_PLOC = 0;
3522
3523 void
3524 free_pipelocs(pTHX_ void *head)
3525 {
3526     pPLOC p, pnext;
3527     pPLOC *pHead = (pPLOC *)head;
3528
3529     p = *pHead;
3530     while (p) {
3531         pnext = p->next;
3532         PerlMem_free(p);
3533         p = pnext;
3534     }
3535     *pHead = 0;
3536 }
3537
3538 static void
3539 store_pipelocs(pTHX)
3540 {
3541     int    i;
3542     pPLOC  p;
3543     AV    *av = 0;
3544     SV    *dirsv;
3545     GV    *gv;
3546     char  *dir, *x;
3547     char  *unixdir;
3548     char  temp[NAM$C_MAXRSS+1];
3549     STRLEN n_a;
3550
3551     if (head_PLOC)
3552         free_pipelocs(aTHX_ &head_PLOC);
3553
3554 /*  the . directory from @INC comes last */
3555
3556     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3557     if (p == NULL) _ckvmssts(SS$_INSFMEM);
3558     p->next = head_PLOC;
3559     head_PLOC = p;
3560     strcpy(p->dir,"./");
3561
3562 /*  get the directory from $^X */
3563
3564     unixdir = PerlMem_malloc(VMS_MAXRSS);
3565     if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3566
3567 #ifdef PERL_IMPLICIT_CONTEXT
3568     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3569 #else
3570     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3571 #endif
3572         strcpy(temp, PL_origargv[0]);
3573         x = strrchr(temp,']');
3574         if (x == NULL) {
3575         x = strrchr(temp,'>');
3576           if (x == NULL) {
3577             /* It could be a UNIX path */
3578             x = strrchr(temp,'/');
3579           }
3580         }
3581         if (x)
3582           x[1] = '\0';
3583         else {
3584           /* Got a bare name, so use default directory */
3585           temp[0] = '.';
3586           temp[1] = '\0';
3587         }
3588
3589         if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
3590             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3591             if (p == NULL) _ckvmssts(SS$_INSFMEM);
3592             p->next = head_PLOC;
3593             head_PLOC = p;
3594             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3595             p->dir[NAM$C_MAXRSS] = '\0';
3596         }
3597     }
3598
3599 /*  reverse order of @INC entries, skip "." since entered above */
3600
3601 #ifdef PERL_IMPLICIT_CONTEXT
3602     if (aTHX)
3603 #endif
3604     if (PL_incgv) av = GvAVn(PL_incgv);
3605
3606     for (i = 0; av && i <= AvFILL(av); i++) {
3607         dirsv = *av_fetch(av,i,TRUE);
3608
3609         if (SvROK(dirsv)) continue;
3610         dir = SvPVx(dirsv,n_a);
3611         if (strcmp(dir,".") == 0) continue;
3612         if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
3613             continue;
3614
3615         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3616         p->next = head_PLOC;
3617         head_PLOC = p;
3618         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3619         p->dir[NAM$C_MAXRSS] = '\0';
3620     }
3621
3622 /* most likely spot (ARCHLIB) put first in the list */
3623
3624 #ifdef ARCHLIB_EXP
3625     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
3626         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3627         if (p == NULL) _ckvmssts(SS$_INSFMEM);
3628         p->next = head_PLOC;
3629         head_PLOC = p;
3630         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3631         p->dir[NAM$C_MAXRSS] = '\0';
3632     }
3633 #endif
3634     PerlMem_free(unixdir);
3635 }
3636
3637 static I32
3638 Perl_cando_by_name_int
3639    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3640 #if !defined(PERL_IMPLICIT_CONTEXT)
3641 #define cando_by_name_int               Perl_cando_by_name_int
3642 #else
3643 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3644 #endif
3645
3646 static char *
3647 find_vmspipe(pTHX)
3648 {
3649     static int   vmspipe_file_status = 0;
3650     static char  vmspipe_file[NAM$C_MAXRSS+1];
3651
3652     /* already found? Check and use ... need read+execute permission */
3653
3654     if (vmspipe_file_status == 1) {
3655         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3656          && cando_by_name_int
3657            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3658             return vmspipe_file;
3659         }
3660         vmspipe_file_status = 0;
3661     }
3662
3663     /* scan through stored @INC, $^X */
3664
3665     if (vmspipe_file_status == 0) {
3666         char file[NAM$C_MAXRSS+1];
3667         pPLOC  p = head_PLOC;
3668
3669         while (p) {
3670             char * exp_res;
3671             int dirlen;
3672             strcpy(file, p->dir);
3673             dirlen = strlen(file);
3674             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3675             file[NAM$C_MAXRSS] = '\0';
3676             p = p->next;
3677
3678             exp_res = do_rmsexpand
3679                 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3680             if (!exp_res) continue;
3681
3682             if (cando_by_name_int
3683                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3684              && cando_by_name_int
3685                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3686                 vmspipe_file_status = 1;
3687                 return vmspipe_file;
3688             }
3689         }
3690         vmspipe_file_status = -1;   /* failed, use tempfiles */
3691     }
3692
3693     return 0;
3694 }
3695
3696 static FILE *
3697 vmspipe_tempfile(pTHX)
3698 {
3699     char file[NAM$C_MAXRSS+1];
3700     FILE *fp;
3701     static int index = 0;
3702     Stat_t s0, s1;
3703     int cmp_result;
3704
3705     /* create a tempfile */
3706
3707     /* we can't go from   W, shr=get to  R, shr=get without
3708        an intermediate vulnerable state, so don't bother trying...
3709
3710        and lib$spawn doesn't shr=put, so have to close the write
3711
3712        So... match up the creation date/time and the FID to
3713        make sure we're dealing with the same file
3714
3715     */
3716
3717     index++;
3718     if (!decc_filename_unix_only) {
3719       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3720       fp = fopen(file,"w");
3721       if (!fp) {
3722         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3723         fp = fopen(file,"w");
3724         if (!fp) {
3725             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3726             fp = fopen(file,"w");
3727         }
3728       }
3729      }
3730      else {
3731       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3732       fp = fopen(file,"w");
3733       if (!fp) {
3734         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3735         fp = fopen(file,"w");
3736         if (!fp) {
3737           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3738           fp = fopen(file,"w");
3739         }
3740       }
3741     }
3742     if (!fp) return 0;  /* we're hosed */
3743
3744     fprintf(fp,"$! 'f$verify(0)'\n");
3745     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3746     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3747     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3748     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3749     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3750     fprintf(fp,"$ perl_del    = \"delete\"\n");
3751     fprintf(fp,"$ pif         = \"if\"\n");
3752     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3753     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3754     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3755     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3756     fprintf(fp,"$!  --- build command line to get max possible length\n");
3757     fprintf(fp,"$c=perl_popen_cmd0\n");
3758     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3759     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3760     fprintf(fp,"$x=perl_popen_cmd3\n");
3761     fprintf(fp,"$c=c+x\n");
3762     fprintf(fp,"$ perl_on\n");
3763     fprintf(fp,"$ 'c'\n");
3764     fprintf(fp,"$ perl_status = $STATUS\n");
3765     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3766     fprintf(fp,"$ perl_exit 'perl_status'\n");
3767     fsync(fileno(fp));
3768
3769     fgetname(fp, file, 1);
3770     fstat(fileno(fp), (struct stat *)&s0);
3771     fclose(fp);
3772
3773     if (decc_filename_unix_only)
3774         do_tounixspec(file, file, 0, NULL);
3775     fp = fopen(file,"r","shr=get");
3776     if (!fp) return 0;
3777     fstat(fileno(fp), (struct stat *)&s1);
3778
3779     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3780     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3781         fclose(fp);
3782         return 0;
3783     }
3784
3785     return fp;
3786 }
3787
3788
3789 static int vms_is_syscommand_xterm(void)
3790 {
3791     const static struct dsc$descriptor_s syscommand_dsc =
3792       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3793
3794     const static struct dsc$descriptor_s decwdisplay_dsc =
3795       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3796
3797     struct item_list_3 items[2];
3798     unsigned short dvi_iosb[4];
3799     unsigned long devchar;
3800     unsigned long devclass;
3801     int status;
3802
3803     /* Very simple check to guess if sys$command is a decterm? */
3804     /* First see if the DECW$DISPLAY: device exists */
3805     items[0].len = 4;
3806     items[0].code = DVI$_DEVCHAR;
3807     items[0].bufadr = &devchar;
3808     items[0].retadr = NULL;
3809     items[1].len = 0;
3810     items[1].code = 0;
3811
3812     status = sys$getdviw
3813         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3814
3815     if ($VMS_STATUS_SUCCESS(status)) {
3816         status = dvi_iosb[0];
3817     }
3818
3819     if (!$VMS_STATUS_SUCCESS(status)) {
3820         SETERRNO(EVMSERR, status);
3821         return -1;
3822     }
3823
3824     /* If it does, then for now assume that we are on a workstation */
3825     /* Now verify that SYS$COMMAND is a terminal */
3826     /* for creating the debugger DECTerm */
3827
3828     items[0].len = 4;
3829     items[0].code = DVI$_DEVCLASS;
3830     items[0].bufadr = &devclass;
3831     items[0].retadr = NULL;
3832     items[1].len = 0;
3833     items[1].code = 0;
3834
3835     status = sys$getdviw
3836         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3837
3838     if ($VMS_STATUS_SUCCESS(status)) {
3839         status = dvi_iosb[0];
3840     }
3841
3842     if (!$VMS_STATUS_SUCCESS(status)) {
3843         SETERRNO(EVMSERR, status);
3844         return -1;
3845     }
3846     else {
3847         if (devclass == DC$_TERM) {
3848             return 0;
3849         }
3850     }
3851     return -1;
3852 }
3853
3854 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3855 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3856 {
3857     int status;
3858     int ret_stat;
3859     char * ret_char;
3860     char device_name[65];
3861     unsigned short device_name_len;
3862     struct dsc$descriptor_s customization_dsc;
3863     struct dsc$descriptor_s device_name_dsc;
3864     const char * cptr;
3865     char * tptr;
3866     char customization[200];
3867     char title[40];
3868     pInfo info = NULL;
3869     char mbx1[64];
3870     unsigned short p_chan;
3871     int n;
3872     unsigned short iosb[4];
3873     struct item_list_3 items[2];
3874     const char * cust_str =
3875         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3876     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3877                                           DSC$K_CLASS_S, mbx1};
3878
3879      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3880     /*---------------------------------------*/
3881     VAXC$ESTABLISH((__vms_handler)LIB$SIG_TO_RET);
3882
3883
3884     /* Make sure that this is from the Perl debugger */
3885     ret_char = strstr(cmd," xterm ");
3886     if (ret_char == NULL)
3887         return NULL;
3888     cptr = ret_char + 7;
3889     ret_char = strstr(cmd,"tty");
3890     if (ret_char == NULL)
3891         return NULL;
3892     ret_char = strstr(cmd,"sleep");
3893     if (ret_char == NULL)
3894         return NULL;
3895
3896     if (decw_term_port == 0) {
3897         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3898         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3899         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3900
3901         status = LIB$FIND_IMAGE_SYMBOL
3902                                (&filename1_dsc,
3903                                 &decw_term_port_dsc,
3904                                 (void *)&decw_term_port,
3905                                 NULL,
3906                                 0);
3907
3908         /* Try again with the other image name */
3909         if (!$VMS_STATUS_SUCCESS(status)) {
3910
3911             status = LIB$FIND_IMAGE_SYMBOL
3912                                (&filename2_dsc,
3913                                 &decw_term_port_dsc,
3914                                 (void *)&decw_term_port,
3915                                 NULL,
3916                                 0);
3917
3918         }
3919
3920     }
3921
3922
3923     /* No decw$term_port, give it up */
3924     if (!$VMS_STATUS_SUCCESS(status))
3925         return NULL;
3926
3927     /* Are we on a workstation? */
3928     /* to do: capture the rows / columns and pass their properties */
3929     ret_stat = vms_is_syscommand_xterm();
3930     if (ret_stat < 0)
3931         return NULL;
3932
3933     /* Make the title: */
3934     ret_char = strstr(cptr,"-title");
3935     if (ret_char != NULL) {
3936         while ((*cptr != 0) && (*cptr != '\"')) {
3937             cptr++;
3938         }
3939         if (*cptr == '\"')
3940             cptr++;
3941         n = 0;
3942         while ((*cptr != 0) && (*cptr != '\"')) {
3943             title[n] = *cptr;
3944             n++;
3945             if (n == 39) {
3946                 title[39] == 0;
3947                 break;
3948             }
3949             cptr++;
3950         }
3951         title[n] = 0;
3952     }
3953     else {
3954             /* Default title */
3955             strcpy(title,"Perl Debug DECTerm");
3956     }
3957     sprintf(customization, cust_str, title);
3958
3959     customization_dsc.dsc$a_pointer = customization;
3960     customization_dsc.dsc$w_length = strlen(customization);
3961     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3962     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3963
3964     device_name_dsc.dsc$a_pointer = device_name;
3965     device_name_dsc.dsc$w_length = sizeof device_name -1;
3966     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3967     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3968
3969     device_name_len = 0;
3970
3971     /* Try to create the window */
3972      status = (*decw_term_port)
3973        (NULL,
3974         NULL,
3975         &customization_dsc,
3976         &device_name_dsc,
3977         &device_name_len,
3978         NULL,
3979         NULL,
3980         NULL);
3981     if (!$VMS_STATUS_SUCCESS(status)) {
3982         SETERRNO(EVMSERR, status);
3983         return NULL;
3984     }
3985
3986     device_name[device_name_len] = '\0';
3987
3988     /* Need to set this up to look like a pipe for cleanup */
3989     n = sizeof(Info);
3990     status = lib$get_vm(&n, &info);
3991     if (!$VMS_STATUS_SUCCESS(status)) {
3992         SETERRNO(ENOMEM, status);
3993         return NULL;
3994     }
3995
3996     info->mode = *mode;
3997     info->done = FALSE;
3998     info->completion = 0;
3999     info->closing    = FALSE;
4000     info->in         = 0;
4001     info->out        = 0;
4002     info->err        = 0;
4003     info->fp         = Nullfp;
4004     info->useFILE    = 0;
4005     info->waiting    = 0;
4006     info->in_done    = TRUE;
4007     info->out_done   = TRUE;
4008     info->err_done   = TRUE;
4009
4010     /* Assign a channel on this so that it will persist, and not login */
4011     /* We stash this channel in the info structure for reference. */
4012     /* The created xterm self destructs when the last channel is removed */
4013     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4014     /* So leave this assigned. */
4015     device_name_dsc.dsc$w_length = device_name_len;
4016     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4017     if (!$VMS_STATUS_SUCCESS(status)) {
4018         SETERRNO(EVMSERR, status);
4019         return NULL;
4020     }
4021     info->xchan_valid = 1;
4022
4023     /* Now create a mailbox to be read by the application */
4024
4025     create_mbx(aTHX_ &p_chan, &d_mbx1);
4026
4027     /* write the name of the created terminal to the mailbox */
4028     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4029             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4030
4031     if (!$VMS_STATUS_SUCCESS(status)) {
4032         SETERRNO(EVMSERR, status);
4033         return NULL;
4034     }
4035
4036     info->fp  = PerlIO_open(mbx1, mode);
4037
4038     /* Done with this channel */
4039     sys$dassgn(p_chan);
4040
4041     /* If any errors, then clean up */
4042     if (!info->fp) {
4043         n = sizeof(Info);
4044         _ckvmssts(lib$free_vm(&n, &info));
4045         return NULL;
4046         }
4047
4048     /* All done */
4049     return info->fp;
4050 }
4051
4052 static PerlIO *
4053 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4054 {
4055     static int handler_set_up = FALSE;
4056     unsigned long int sts, flags = CLI$M_NOWAIT;
4057     /* The use of a GLOBAL table (as was done previously) rendered
4058      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4059      * environment.  Hence we've switched to LOCAL symbol table.
4060      */
4061     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4062     int j, wait = 0, n;
4063     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4064     char *in, *out, *err, mbx[512];
4065     FILE *tpipe = 0;
4066     char tfilebuf[NAM$C_MAXRSS+1];
4067     pInfo info = NULL;
4068     char cmd_sym_name[20];
4069     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4070                                       DSC$K_CLASS_S, symbol};
4071     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4072                                       DSC$K_CLASS_S, 0};
4073     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4074                                       DSC$K_CLASS_S, cmd_sym_name};
4075     struct dsc$descriptor_s *vmscmd;
4076     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4077     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4078     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4079
4080     /* Check here for Xterm create request.  This means looking for
4081      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4082      *  is possible to create an xterm.
4083      */
4084     if (*in_mode == 'r') {
4085         PerlIO * xterm_fd;
4086
4087         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4088         if (xterm_fd != Nullfp)
4089             return xterm_fd;
4090     }
4091
4092     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4093
4094     /* once-per-program initialization...
4095        note that the SETAST calls and the dual test of pipe_ef
4096        makes sure that only the FIRST thread through here does
4097        the initialization...all other threads wait until it's
4098        done.
4099
4100        Yeah, uglier than a pthread call, it's got all the stuff inline
4101        rather than in a separate routine.
4102     */
4103
4104     if (!pipe_ef) {
4105         _ckvmssts(sys$setast(0));
4106         if (!pipe_ef) {
4107             unsigned long int pidcode = JPI$_PID;
4108             $DESCRIPTOR(d_delay, RETRY_DELAY);
4109             _ckvmssts(lib$get_ef(&pipe_ef));
4110             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4111             _ckvmssts(sys$bintim(&d_delay, delaytime));
4112         }
4113         if (!handler_set_up) {
4114           _ckvmssts(sys$dclexh(&pipe_exitblock));
4115           handler_set_up = TRUE;
4116         }
4117         _ckvmssts(sys$setast(1));
4118     }
4119
4120     /* see if we can find a VMSPIPE.COM */
4121
4122     tfilebuf[0] = '@';
4123     vmspipe = find_vmspipe(aTHX);
4124     if (vmspipe) {
4125         strcpy(tfilebuf+1,vmspipe);
4126     } else {        /* uh, oh...we're in tempfile hell */
4127         tpipe = vmspipe_tempfile(aTHX);
4128         if (!tpipe) {       /* a fish popular in Boston */
4129             if (ckWARN(WARN_PIPE)) {
4130                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4131             }
4132         return Nullfp;
4133         }
4134         fgetname(tpipe,tfilebuf+1,1);
4135     }
4136     vmspipedsc.dsc$a_pointer = tfilebuf;
4137     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4138
4139     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4140     if (!(sts & 1)) {
4141       switch (sts) {
4142         case RMS$_FNF:  case RMS$_DNF:
4143           set_errno(ENOENT); break;
4144         case RMS$_DIR:
4145           set_errno(ENOTDIR); break;
4146         case RMS$_DEV:
4147           set_errno(ENODEV); break;
4148         case RMS$_PRV:
4149           set_errno(EACCES); break;
4150         case RMS$_SYN:
4151           set_errno(EINVAL); break;
4152         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4153           set_errno(E2BIG); break;
4154         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4155           _ckvmssts(sts); /* fall through */
4156         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4157           set_errno(EVMSERR);
4158       }
4159       set_vaxc_errno(sts);
4160       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4161         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4162       }
4163       *psts = sts;
4164       return Nullfp;
4165     }
4166     n = sizeof(Info);
4167     _ckvmssts(lib$get_vm(&n, &info));
4168
4169     strcpy(mode,in_mode);
4170     info->mode = *mode;
4171     info->done = FALSE;
4172     info->completion = 0;
4173     info->closing    = FALSE;
4174     info->in         = 0;
4175     info->out        = 0;
4176     info->err        = 0;
4177     info->fp         = Nullfp;
4178     info->useFILE    = 0;
4179     info->waiting    = 0;
4180     info->in_done    = TRUE;
4181     info->out_done   = TRUE;
4182     info->err_done   = TRUE;
4183     info->xchan      = 0;
4184     info->xchan_valid = 0;
4185
4186     in = PerlMem_malloc(VMS_MAXRSS);
4187     if (in == NULL) _ckvmssts(SS$_INSFMEM);
4188     out = PerlMem_malloc(VMS_MAXRSS);
4189     if (out == NULL) _ckvmssts(SS$_INSFMEM);
4190     err = PerlMem_malloc(VMS_MAXRSS);
4191     if (err == NULL) _ckvmssts(SS$_INSFMEM);
4192
4193     in[0] = out[0] = err[0] = '\0';
4194
4195     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4196         info->useFILE = 1;
4197         strcpy(p,p+1);
4198     }
4199     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4200         wait = 1;
4201         strcpy(p,p+1);
4202     }
4203
4204     if (*mode == 'r') {             /* piping from subroutine */
4205
4206         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4207         if (info->out) {
4208             info->out->pipe_done = &info->out_done;
4209             info->out_done = FALSE;
4210             info->out->info = info;
4211         }
4212         if (!info->useFILE) {
4213             info->fp  = PerlIO_open(mbx, mode);
4214         } else {
4215             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4216             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4217         }
4218
4219         if (!info->fp && info->out) {
4220             sys$cancel(info->out->chan_out);
4221
4222             while (!info->out_done) {
4223                 int done;
4224                 _ckvmssts(sys$setast(0));
4225                 done = info->out_done;
4226                 if (!done) _ckvmssts(sys$clref(pipe_ef));
4227                 _ckvmssts(sys$setast(1));
4228                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4229             }
4230
4231             if (info->out->buf) {
4232                 n = info->out->bufsize * sizeof(char);
4233                 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4234             }
4235             n = sizeof(Pipe);
4236             _ckvmssts(lib$free_vm(&n, &info->out));
4237             n = sizeof(Info);
4238             _ckvmssts(lib$free_vm(&n, &info));
4239             *psts = RMS$_FNF;
4240             return Nullfp;
4241         }
4242
4243         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4244         if (info->err) {
4245             info->err->pipe_done = &info->err_done;
4246             info->err_done = FALSE;
4247             info->err->info = info;
4248         }
4249
4250     } else if (*mode == 'w') {      /* piping to subroutine */
4251
4252         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4253         if (info->out) {
4254             info->out->pipe_done = &info->out_done;
4255             info->out_done = FALSE;
4256             info->out->info = info;
4257         }
4258
4259         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4260         if (info->err) {
4261             info->err->pipe_done = &info->err_done;
4262             info->err_done = FALSE;
4263             info->err->info = info;
4264         }
4265
4266         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4267         if (!info->useFILE) {
4268             info->fp  = PerlIO_open(mbx, mode);
4269         } else {
4270             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4271             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4272         }
4273
4274         if (info->in) {
4275             info->in->pipe_done = &info->in_done;
4276             info->in_done = FALSE;
4277             info->in->info = info;
4278         }
4279
4280         /* error cleanup */
4281         if (!info->fp && info->in) {
4282             info->done = TRUE;
4283             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4284                               0, 0, 0, 0, 0, 0, 0, 0));
4285
4286             while (!info->in_done) {
4287                 int done;
4288                 _ckvmssts(sys$setast(0));
4289                 done = info->in_done;
4290                 if (!done) _ckvmssts(sys$clref(pipe_ef));
4291                 _ckvmssts(sys$setast(1));
4292                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4293             }
4294
4295             if (info->in->buf) {
4296                 n = info->in->bufsize * sizeof(char);
4297                 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4298             }
4299             n = sizeof(Pipe);
4300             _ckvmssts(lib$free_vm(&n, &info->in));
4301             n = sizeof(Info);
4302             _ckvmssts(lib$free_vm(&n, &info));
4303             *psts = RMS$_FNF;
4304             return Nullfp;
4305         }
4306
4307
4308     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4309         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4310         if (info->out) {
4311             info->out->pipe_done = &info->out_done;
4312             info->out_done = FALSE;
4313             info->out->info = info;
4314         }
4315
4316         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4317         if (info->err) {
4318             info->err->pipe_done = &info->err_done;
4319             info->err_done = FALSE;
4320             info->err->info = info;
4321         }
4322     }
4323
4324     symbol[MAX_DCL_SYMBOL] = '\0';
4325
4326     strncpy(symbol, in, MAX_DCL_SYMBOL);
4327     d_symbol.dsc$w_length = strlen(symbol);
4328     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4329
4330     strncpy(symbol, err, MAX_DCL_SYMBOL);
4331     d_symbol.dsc$w_length = strlen(symbol);
4332     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4333
4334     strncpy(symbol, out, MAX_DCL_SYMBOL);
4335     d_symbol.dsc$w_length = strlen(symbol);
4336     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4337
4338     /* Done with the names for the pipes */
4339     PerlMem_free(err);
4340     PerlMem_free(out);
4341     PerlMem_free(in);
4342
4343     p = vmscmd->dsc$a_pointer;
4344     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4345     if (*p == '$') p++;                         /* remove leading $ */
4346     while (*p == ' ' || *p == '\t') p++;
4347
4348     for (j = 0; j < 4; j++) {
4349         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4350         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4351
4352     strncpy(symbol, p, MAX_DCL_SYMBOL);
4353     d_symbol.dsc$w_length = strlen(symbol);
4354     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4355
4356         if (strlen(p) > MAX_DCL_SYMBOL) {
4357             p += MAX_DCL_SYMBOL;
4358         } else {
4359             p += strlen(p);
4360         }
4361     }
4362     _ckvmssts(sys$setast(0));
4363     info->next=open_pipes;  /* prepend to list */
4364     open_pipes=info;
4365     _ckvmssts(sys$setast(1));
4366     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4367      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4368      * have SYS$COMMAND if we need it.
4369      */
4370     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4371                       0, &info->pid, &info->completion,
4372                       0, popen_completion_ast,info,0,0,0));
4373
4374     /* if we were using a tempfile, close it now */
4375
4376     if (tpipe) fclose(tpipe);
4377
4378     /* once the subprocess is spawned, it has copied the symbols and
4379        we can get rid of ours */
4380
4381     for (j = 0; j < 4; j++) {
4382         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4383         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4384     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4385     }
4386     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
4387     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4388     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4389     vms_execfree(vmscmd);
4390
4391 #ifdef PERL_IMPLICIT_CONTEXT
4392     if (aTHX)
4393 #endif
4394     PL_forkprocess = info->pid;
4395
4396     if (wait) {
4397          int done = 0;
4398          while (!done) {
4399              _ckvmssts(sys$setast(0));
4400              done = info->done;
4401              if (!done) _ckvmssts(sys$clref(pipe_ef));
4402              _ckvmssts(sys$setast(1));
4403              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4404          }
4405         *psts = info->completion;
4406 /* Caller thinks it is open and tries to close it. */
4407 /* This causes some problems, as it changes the error status */
4408 /*        my_pclose(info->fp); */
4409     } else {
4410         *psts = SS$_NORMAL;
4411     }
4412     return info->fp;
4413 }  /* end of safe_popen */
4414
4415
4416 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4417 PerlIO *
4418 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4419 {
4420     int sts;
4421     TAINT_ENV();
4422     TAINT_PROPER("popen");
4423     PERL_FLUSHALL_FOR_CHILD;
4424     return safe_popen(aTHX_ cmd,mode,&sts);
4425 }
4426
4427 /*}}}*/
4428
4429 /*{{{  I32 my_pclose(PerlIO *fp)*/
4430 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4431 {
4432     pInfo info, last = NULL;
4433     unsigned long int retsts;
4434     int done, iss, n;
4435     int status;
4436
4437     for (info = open_pipes; info != NULL; last = info, info = info->next)
4438         if (info->fp == fp) break;
4439
4440     if (info == NULL) {  /* no such pipe open */
4441       set_errno(ECHILD); /* quoth POSIX */
4442       set_vaxc_errno(SS$_NONEXPR);
4443       return -1;
4444     }
4445
4446     /* If we were writing to a subprocess, insure that someone reading from
4447      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4448      * produce an EOF record in the mailbox.
4449      *
4450      *  well, at least sometimes it *does*, so we have to watch out for
4451      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4452      */
4453      if (info->fp) {
4454         if (!info->useFILE
4455 #if defined(USE_ITHREADS)
4456           && my_perl
4457 #endif
4458           && PL_perlio_fd_refcnt)
4459             PerlIO_flush(info->fp);
4460         else
4461             fflush((FILE *)info->fp);
4462     }
4463
4464     _ckvmssts(sys$setast(0));
4465      info->closing = TRUE;
4466      done = info->done && info->in_done && info->out_done && info->err_done;
4467      /* hanging on write to Perl's input? cancel it */
4468      if (info->mode == 'r' && info->out && !info->out_done) {
4469         if (info->out->chan_out) {
4470             _ckvmssts(sys$cancel(info->out->chan_out));
4471             if (!info->out->chan_in) {   /* EOF generation, need AST */
4472                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4473             }
4474         }
4475      }
4476      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4477          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4478                            0, 0, 0, 0, 0, 0));
4479     _ckvmssts(sys$setast(1));
4480     if (info->fp) {
4481      if (!info->useFILE
4482 #if defined(USE_ITHREADS)
4483          && my_perl
4484 #endif
4485          && PL_perlio_fd_refcnt)
4486         PerlIO_close(info->fp);
4487      else
4488         fclose((FILE *)info->fp);
4489     }
4490      /*
4491         we have to wait until subprocess completes, but ALSO wait until all
4492         the i/o completes...otherwise we'll be freeing the "info" structure
4493         that the i/o ASTs could still be using...
4494      */
4495
4496      while (!done) {
4497          _ckvmssts(sys$setast(0));
4498          done = info->done && info->in_done && info->out_done && info->err_done;
4499          if (!done) _ckvmssts(sys$clref(pipe_ef));
4500          _ckvmssts(sys$setast(1));
4501          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4502      }
4503      retsts = info->completion;
4504
4505     /* remove from list of open pipes */
4506     _ckvmssts(sys$setast(0));
4507     if (last) last->next = info->next;
4508     else open_pipes = info->next;
4509     _ckvmssts(sys$setast(1));
4510
4511     /* free buffers and structures */
4512
4513     if (info->in) {
4514         if (info->in->buf) {
4515             n = info->in->bufsize * sizeof(char);
4516             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4517         }
4518         n = sizeof(Pipe);
4519         _ckvmssts(lib$free_vm(&n, &info->in));
4520     }
4521     if (info->out) {
4522         if (info->out->buf) {
4523             n = info->out->bufsize * sizeof(char);
4524             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4525         }
4526         n = sizeof(Pipe);
4527         _ckvmssts(lib$free_vm(&n, &info->out));
4528     }
4529     if (info->err) {
4530         if (info->err->buf) {
4531             n = info->err->bufsize * sizeof(char);
4532             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4533         }
4534         n = sizeof(Pipe);
4535         _ckvmssts(lib$free_vm(&n, &info->err));
4536     }
4537     n = sizeof(Info);
4538     _ckvmssts(lib$free_vm(&n, &info));
4539
4540     return retsts;
4541
4542 }  /* end of my_pclose() */
4543
4544 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4545   /* Roll our own prototype because we want this regardless of whether
4546    * _VMS_WAIT is defined.
4547    */
4548   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4549 #endif
4550 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4551    created with popen(); otherwise partially emulate waitpid() unless
4552    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4553    Also check processes not considered by the CRTL waitpid().
4554  */
4555 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4556 Pid_t
4557 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4558 {
4559     pInfo info;
4560     int done;
4561     int sts;
4562     int j;
4563
4564     if (statusp) *statusp = 0;
4565
4566     for (info = open_pipes; info != NULL; info = info->next)
4567         if (info->pid == pid) break;
4568
4569     if (info != NULL) {  /* we know about this child */
4570       while (!info->done) {
4571           _ckvmssts(sys$setast(0));
4572           done = info->done;
4573           if (!done) _ckvmssts(sys$clref(pipe_ef));
4574           _ckvmssts(sys$setast(1));
4575           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4576       }
4577
4578       if (statusp) *statusp = info->completion;
4579       return pid;
4580     }
4581
4582     /* child that already terminated? */
4583
4584     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4585         if (closed_list[j].pid == pid) {
4586             if (statusp) *statusp = closed_list[j].completion;
4587             return pid;
4588         }
4589     }
4590
4591     /* fall through if this child is not one of our own pipe children */
4592
4593 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4594
4595       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4596        * in 7.2 did we get a version that fills in the VMS completion
4597        * status as Perl has always tried to do.
4598        */
4599
4600       sts = __vms_waitpid( pid, statusp, flags );
4601
4602       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4603          return sts;
4604
4605       /* If the real waitpid tells us the child does not exist, we
4606        * fall through here to implement waiting for a child that
4607        * was created by some means other than exec() (say, spawned
4608        * from DCL) or to wait for a process that is not a subprocess
4609        * of the current process.
4610        */
4611
4612 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4613
4614     {
4615       $DESCRIPTOR(intdsc,"0 00:00:01");
4616       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4617       unsigned long int pidcode = JPI$_PID, mypid;
4618       unsigned long int interval[2];
4619       unsigned int jpi_iosb[2];
4620       struct itmlst_3 jpilist[2] = {
4621           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4622           {                      0,         0,                 0, 0}
4623       };
4624
4625       if (pid <= 0) {
4626         /* Sorry folks, we don't presently implement rooting around for
4627            the first child we can find, and we definitely don't want to
4628            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4629          */
4630         set_errno(ENOTSUP);
4631         return -1;
4632       }
4633
4634       /* Get the owner of the child so I can warn if it's not mine. If the
4635        * process doesn't exist or I don't have the privs to look at it,
4636        * I can go home early.
4637        */
4638       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4639       if (sts & 1) sts = jpi_iosb[0];
4640       if (!(sts & 1)) {
4641         switch (sts) {
4642             case SS$_NONEXPR:
4643                 set_errno(ECHILD);
4644                 break;
4645             case SS$_NOPRIV:
4646                 set_errno(EACCES);
4647                 break;
4648             default:
4649                 _ckvmssts(sts);
4650         }
4651         set_vaxc_errno(sts);
4652         return -1;
4653       }
4654
4655       if (ckWARN(WARN_EXEC)) {
4656         /* remind folks they are asking for non-standard waitpid behavior */
4657         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4658         if (ownerpid != mypid)
4659           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4660                       "waitpid: process %x is not a child of process %x",
4661                       pid,mypid);
4662       }
4663
4664       /* simply check on it once a second until it's not there anymore. */
4665
4666       _ckvmssts(sys$bintim(&intdsc,interval));
4667       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4668             _ckvmssts(sys$schdwk(0,0,interval,0));
4669             _ckvmssts(sys$hiber());
4670       }
4671       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4672
4673       _ckvmssts(sts);
4674       return pid;
4675     }
4676 }  /* end of waitpid() */
4677 /*}}}*/
4678 /*}}}*/
4679 /*}}}*/
4680
4681 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4682 char *
4683 my_gconvert(double val, int ndig, int trail, char *buf)
4684 {
4685   static char __gcvtbuf[DBL_DIG+1];
4686   char *loc;
4687
4688   loc = buf ? buf : __gcvtbuf;
4689
4690 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4691   if (val < 1) {
4692     sprintf(loc,"%.*g",ndig,val);
4693     return loc;
4694   }
4695 #endif
4696
4697   if (val) {
4698     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4699     return gcvt(val,ndig,loc);
4700   }
4701   else {
4702     loc[0] = '0'; loc[1] = '\0';
4703     return loc;
4704   }
4705
4706 }
4707 /*}}}*/
4708
4709 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4710 static int rms_free_search_context(struct FAB * fab)
4711 {
4712 struct NAM * nam;
4713
4714     nam = fab->fab$l_nam;
4715     nam->nam$b_nop |= NAM$M_SYNCHK;
4716     nam->nam$l_rlf = NULL;
4717     fab->fab$b_dns = 0;
4718     return sys$parse(fab, NULL, NULL);
4719 }
4720
4721 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4722 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4723 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4724 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4725 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4726 #define rms_nam_esll(nam) nam.nam$b_esl
4727 #define rms_nam_esl(nam) nam.nam$b_esl
4728 #define rms_nam_name(nam) nam.nam$l_name
4729 #define rms_nam_namel(nam) nam.nam$l_name
4730 #define rms_nam_type(nam) nam.nam$l_type
4731 #define rms_nam_typel(nam) nam.nam$l_type
4732 #define rms_nam_ver(nam) nam.nam$l_ver
4733 #define rms_nam_verl(nam) nam.nam$l_ver
4734 #define rms_nam_rsll(nam) nam.nam$b_rsl
4735 #define rms_nam_rsl(nam) nam.nam$b_rsl
4736 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4737 #define rms_set_fna(fab, nam, name, size) \
4738         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4739 #define rms_get_fna(fab, nam) fab.fab$l_fna
4740 #define rms_set_dna(fab, nam, name, size) \
4741         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4742 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4743 #define rms_set_esa(fab, nam, name, size) \
4744         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4745 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4746         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4747 #define rms_set_rsa(nam, name, size) \
4748         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4749 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4750         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4751 #define rms_nam_name_type_l_size(nam) \
4752         (nam.nam$b_name + nam.nam$b_type)
4753 #else
4754 static int rms_free_search_context(struct FAB * fab)
4755 {
4756 struct NAML * nam;
4757
4758     nam = fab->fab$l_naml;
4759     nam->naml$b_nop |= NAM$M_SYNCHK;
4760     nam->naml$l_rlf = NULL;
4761     nam->naml$l_long_defname_size = 0;
4762
4763     fab->fab$b_dns = 0;
4764     return sys$parse(fab, NULL, NULL);
4765 }
4766
4767 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4768 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4769 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4770 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4771 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4772 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4773 #define rms_nam_esl(nam) nam.naml$b_esl
4774 #define rms_nam_name(nam) nam.naml$l_name
4775 #define rms_nam_namel(nam) nam.naml$l_long_name
4776 #define rms_nam_type(nam) nam.naml$l_type
4777 #define rms_nam_typel(nam) nam.naml$l_long_type
4778 #define rms_nam_ver(nam) nam.naml$l_ver
4779 #define rms_nam_verl(nam) nam.naml$l_long_ver
4780 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4781 #define rms_nam_rsl(nam) nam.naml$b_rsl
4782 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4783 #define rms_set_fna(fab, nam, name, size) \
4784         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4785         nam.naml$l_long_filename_size = size; \
4786         nam.naml$l_long_filename = name;}
4787 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4788 #define rms_set_dna(fab, nam, name, size) \
4789         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4790         nam.naml$l_long_defname_size = size; \
4791         nam.naml$l_long_defname = name; }
4792 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4793 #define rms_set_esa(fab, nam, name, size) \
4794         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4795         nam.naml$l_long_expand_alloc = size; \
4796         nam.naml$l_long_expand = name; }
4797 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4798         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4799         nam.naml$l_long_expand = l_name; \
4800         nam.naml$l_long_expand_alloc = l_size; }
4801 #define rms_set_rsa(nam, name, size) \
4802         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4803         nam.naml$l_long_result = name; \
4804         nam.naml$l_long_result_alloc = size; }
4805 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4806         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4807         nam.naml$l_long_result = l_name; \
4808         nam.naml$l_long_result_alloc = l_size; }
4809 #define rms_nam_name_type_l_size(nam) \
4810         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4811 #endif
4812
4813
4814 /* rms_erase
4815  * The CRTL for 8.3 and later can create symbolic links in any mode,
4816  * however in 8.3 the unlink/remove/delete routines will only properly handle
4817  * them if one of the PCP modes is active.
4818  */
4819 static int rms_erase(const char * vmsname)
4820 {
4821   int status;
4822   struct FAB myfab = cc$rms_fab;
4823   rms_setup_nam(mynam);
4824
4825   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4826   rms_bind_fab_nam(myfab, mynam);
4827
4828   /* Are we removing all versions? */
4829   if (vms_unlink_all_versions == 1) {
4830     const char * defspec = ";*";
4831     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4832   }
4833
4834 #ifdef NAML$M_OPEN_SPECIAL
4835   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4836 #endif
4837
4838   status = SYS$ERASE(&myfab, 0, 0);
4839
4840   return status;
4841 }
4842
4843
4844 static int
4845 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4846                     const struct dsc$descriptor_s * vms_dst_dsc,
4847                     unsigned long flags)
4848 {
4849     /*  VMS and UNIX handle file permissions differently and the
4850      * the same ACL trick may be needed for renaming files,
4851      * especially if they are directories.
4852      */
4853
4854    /* todo: get kill_file and rename to share common code */
4855    /* I can not find online documentation for $change_acl
4856     * it appears to be replaced by $set_security some time ago */
4857
4858 const unsigned int access_mode = 0;
4859 $DESCRIPTOR(obj_file_dsc,"FILE");
4860 char *vmsname;
4861 char *rslt;
4862 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
4863 int aclsts, fndsts, rnsts = -1;
4864 unsigned int ctx = 0;
4865 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4866 struct dsc$descriptor_s * clean_dsc;
4867
4868 struct myacedef {
4869     unsigned char myace$b_length;
4870     unsigned char myace$b_type;
4871     unsigned short int myace$w_flags;
4872     unsigned long int myace$l_access;
4873     unsigned long int myace$l_ident;
4874 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
4875              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
4876              0},
4877              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
4878
4879 struct item_list_3
4880         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
4881                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
4882                       {0,0,0,0}},
4883         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
4884         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
4885                      {0,0,0,0}};
4886
4887
4888     /* Expand the input spec using RMS, since we do not want to put
4889      * ACLs on the target of a symbolic link */
4890     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
4891     if (vmsname == NULL)
4892         return SS$_INSFMEM;
4893
4894     rslt = do_rmsexpand(vms_src_dsc->dsc$a_pointer,
4895                         vmsname,
4896                         0,
4897                         NULL,
4898                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
4899                         NULL,
4900                         NULL);
4901     if (rslt == NULL) {
4902         PerlMem_free(vmsname);
4903         return SS$_INSFMEM;
4904     }
4905
4906     /* So we get our own UIC to use as a rights identifier,
4907      * and the insert an ACE at the head of the ACL which allows us
4908      * to delete the file.
4909      */
4910     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
4911
4912     fildsc.dsc$w_length = strlen(vmsname);
4913     fildsc.dsc$a_pointer = vmsname;
4914     ctx = 0;
4915     newace.myace$l_ident = oldace.myace$l_ident;
4916     rnsts = SS$_ABORT;
4917
4918     /* Grab any existing ACEs with this identifier in case we fail */
4919     clean_dsc = &fildsc;
4920     aclsts = fndsts = sys$get_security(&obj_file_dsc,
4921                                &fildsc,
4922                                NULL,
4923                                OSS$M_WLOCK,
4924                                findlst,
4925                                &ctx,
4926                                &access_mode);
4927
4928     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
4929         /* Add the new ACE . . . */
4930
4931         /* if the sys$get_security succeeded, then ctx is valid, and the
4932          * object/file descriptors will be ignored.  But otherwise they
4933          * are needed
4934          */
4935         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
4936                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
4937         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4938             set_errno(EVMSERR);
4939             set_vaxc_errno(aclsts);
4940             PerlMem_free(vmsname);
4941             return aclsts;
4942         }
4943
4944         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
4945                                 NULL, NULL,
4946                                 &flags,
4947                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
4948
4949         if ($VMS_STATUS_SUCCESS(rnsts)) {
4950             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
4951         }
4952
4953         /* Put things back the way they were. */
4954         ctx = 0;
4955         aclsts = sys$get_security(&obj_file_dsc,
4956                                   clean_dsc,
4957                                   NULL,
4958                                   OSS$M_WLOCK,
4959                                   findlst,
4960                                   &ctx,
4961                                   &access_mode);
4962
4963         if ($VMS_STATUS_SUCCESS(aclsts)) {
4964         int sec_flags;
4965
4966             sec_flags = 0;
4967             if (!$VMS_STATUS_SUCCESS(fndsts))
4968                 sec_flags = OSS$M_RELCTX;
4969
4970             /* Get rid of the new ACE */
4971             aclsts = sys$set_security(NULL, NULL, NULL,
4972                                   sec_flags, dellst, &ctx, &access_mode);
4973
4974             /* If there was an old ACE, put it back */
4975             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
4976                 addlst[0].bufadr = &oldace;
4977                 aclsts = sys$set_security(NULL, NULL, NULL,
4978                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
4979                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4980                     set_errno(EVMSERR);
4981                     set_vaxc_errno(aclsts);
4982                     rnsts = aclsts;
4983                 }
4984             } else {
4985             int aclsts2;
4986
4987                 /* Try to clear the lock on the ACL list */
4988                 aclsts2 = sys$set_security(NULL, NULL, NULL,
4989                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
4990
4991                 /* Rename errors are most important */
4992                 if (!$VMS_STATUS_SUCCESS(rnsts))
4993                     aclsts = rnsts;
4994                 set_errno(EVMSERR);
4995                 set_vaxc_errno(aclsts);
4996                 rnsts = aclsts;
4997             }
4998         }
4999         else {
5000             if (aclsts != SS$_ACLEMPTY)
5001                 rnsts = aclsts;
5002         }
5003     }
5004     else
5005         rnsts = fndsts;
5006
5007     PerlMem_free(vmsname);
5008     return rnsts;
5009 }
5010
5011
5012 /*{{{int rename(const char *, const char * */
5013 /* Not exactly what X/Open says to do, but doing it absolutely right
5014  * and efficiently would require a lot more work.  This should be close
5015  * enough to pass all but the most strict X/Open compliance test.
5016  */
5017 int
5018 Perl_rename(pTHX_ const char *src, const char * dst)
5019 {
5020 int retval;
5021 int pre_delete = 0;
5022 int src_sts;
5023 int dst_sts;
5024 Stat_t src_st;
5025 Stat_t dst_st;
5026
5027     /* Validate the source file */
5028     src_sts = flex_lstat(src, &src_st);
5029     if (src_sts != 0) {
5030
5031         /* No source file or other problem */
5032         return src_sts;
5033     }
5034
5035     dst_sts = flex_lstat(dst, &dst_st);
5036     if (dst_sts == 0) {
5037
5038         if (dst_st.st_dev != src_st.st_dev) {
5039             /* Must be on the same device */
5040             errno = EXDEV;
5041             return -1;
5042         }
5043
5044         /* VMS_INO_T_COMPARE is true if the inodes are different
5045          * to match the output of memcmp
5046          */
5047
5048         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5049             /* That was easy, the files are the same! */
5050             return 0;
5051         }
5052
5053         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5054             /* If source is a directory, so must be dest */
5055                 errno = EISDIR;
5056                 return -1;
5057         }
5058
5059     }
5060
5061
5062     if ((dst_sts == 0) &&
5063         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5064
5065         /* We have issues here if vms_unlink_all_versions is set
5066          * If the destination exists, and is not a directory, then
5067          * we must delete in advance.
5068          *
5069          * If the src is a directory, then we must always pre-delete
5070          * the destination.
5071          *
5072          * If we successfully delete the dst in advance, and the rename fails
5073          * X/Open requires that errno be EIO.
5074          *
5075          */
5076
5077         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5078             int d_sts;
5079             d_sts = mp_do_kill_file(aTHX_ dst, S_ISDIR(dst_st.st_mode));
5080             if (d_sts != 0)
5081                 return d_sts;
5082
5083             /* We killed the destination, so only errno now is EIO */
5084             pre_delete = 1;
5085         }
5086     }
5087
5088     /* Originally the idea was to call the CRTL rename() and only
5089      * try the lib$rename_file if it failed.
5090      * It turns out that there are too many variants in what the
5091      * the CRTL rename might do, so only use lib$rename_file
5092      */
5093     retval = -1;
5094
5095     {
5096         /* Is the source and dest both in VMS format */
5097         /* if the source is a directory, then need to fileify */
5098         /*  and dest must be a directory or non-existant. */
5099
5100         char * vms_src;
5101         char * vms_dst;
5102         int sts;
5103         char * ret_str;
5104         unsigned long flags;
5105         struct dsc$descriptor_s old_file_dsc;
5106         struct dsc$descriptor_s new_file_dsc;
5107
5108         /* We need to modify the src and dst depending
5109          * on if one or more of them are directories.
5110          */
5111
5112         vms_src = PerlMem_malloc(VMS_MAXRSS);
5113         if (vms_src == NULL)
5114             _ckvmssts(SS$_INSFMEM);
5115
5116         /* Source is always a VMS format file */
5117         ret_str = do_tovmsspec(src, vms_src, 0, NULL);
5118         if (ret_str == NULL) {
5119             PerlMem_free(vms_src);
5120             errno = EIO;
5121             return -1;
5122         }
5123
5124         vms_dst = PerlMem_malloc(VMS_MAXRSS);
5125         if (vms_dst == NULL)
5126             _ckvmssts(SS$_INSFMEM);
5127
5128         if (S_ISDIR(src_st.st_mode)) {
5129         char * ret_str;
5130         char * vms_dir_file;
5131
5132             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5133             if (vms_dir_file == NULL)
5134                 _ckvmssts(SS$_INSFMEM);
5135
5136             /* The source must be a file specification */
5137             ret_str = do_fileify_dirspec(vms_src, vms_dir_file, 0, NULL);
5138             if (ret_str == NULL) {
5139                 PerlMem_free(vms_src);
5140                 PerlMem_free(vms_dst);
5141                 PerlMem_free(vms_dir_file);
5142                 errno = EIO;
5143                 return -1;
5144             }
5145             PerlMem_free(vms_src);
5146             vms_src = vms_dir_file;
5147
5148             /* If the dest is a directory, we must remove it
5149             if (dst_sts == 0) {
5150                 int d_sts;
5151                 d_sts = mp_do_kill_file(aTHX_ dst, 1);
5152                 if (d_sts != 0) {
5153                     PerlMem_free(vms_src);
5154                     PerlMem_free(vms_dst);
5155                     errno = EIO;
5156                     return sts;
5157                 }
5158
5159                 pre_delete = 1;
5160             }
5161
5162            /* The dest must be a VMS file specification */
5163            ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
5164            if (ret_str == NULL) {
5165                 PerlMem_free(vms_src);
5166                 PerlMem_free(vms_dst);
5167                 errno = EIO;
5168                 return -1;
5169            }
5170
5171             /* The source must be a file specification */
5172             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5173             if (vms_dir_file == NULL)
5174                 _ckvmssts(SS$_INSFMEM);
5175
5176             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5177             if (ret_str == NULL) {
5178                 PerlMem_free(vms_src);
5179                 PerlMem_free(vms_dst);
5180                 PerlMem_free(vms_dir_file);
5181                 errno = EIO;
5182                 return -1;
5183             }
5184             PerlMem_free(vms_dst);
5185             vms_dst = vms_dir_file;
5186
5187         } else {
5188             /* File to file or file to new dir */
5189
5190             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5191                 /* VMS pathify a dir target */
5192                 ret_str = do_tovmspath(dst, vms_dst, 0, NULL);
5193                 if (ret_str == NULL) {
5194                     PerlMem_free(vms_src);
5195                     PerlMem_free(vms_dst);
5196                     errno = EIO;
5197                     return -1;
5198                 }
5199             } else {
5200
5201                 /* fileify a target VMS file specification */
5202                 ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
5203                 if (ret_str == NULL) {
5204                     PerlMem_free(vms_src);
5205                     PerlMem_free(vms_dst);
5206                     errno = EIO;
5207                     return -1;
5208                 }
5209             }
5210         }
5211
5212         old_file_dsc.dsc$a_pointer = vms_src;
5213         old_file_dsc.dsc$w_length = strlen(vms_src);
5214         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5215         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5216
5217         new_file_dsc.dsc$a_pointer = vms_dst;
5218         new_file_dsc.dsc$w_length = strlen(vms_dst);
5219         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5220         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5221
5222         flags = 0;
5223 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5224         flags |= 2; /* LIB$M_FIL_LONG_NAMES */
5225 #endif
5226
5227         sts = lib$rename_file(&old_file_dsc,
5228                               &new_file_dsc,
5229                               NULL, NULL,
5230                               &flags,
5231                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5232         if (!$VMS_STATUS_SUCCESS(sts)) {
5233
5234            /* We could have failed because VMS style permissions do not
5235             * permit renames that UNIX will allow.  Just like the hack
5236             * in for kill_file.
5237             */
5238            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5239         }
5240
5241         PerlMem_free(vms_src);
5242         PerlMem_free(vms_dst);
5243         if (!$VMS_STATUS_SUCCESS(sts)) {
5244             errno = EIO;
5245             return -1;
5246         }
5247         retval = 0;
5248     }
5249
5250     if (vms_unlink_all_versions) {
5251         /* Now get rid of any previous versions of the source file that
5252          * might still exist
5253          */
5254         int save_errno;
5255         save_errno = errno;
5256         src_sts = mp_do_kill_file(aTHX_ src, S_ISDIR(src_st.st_mode));
5257         errno = save_errno;
5258     }
5259
5260     /* We deleted the destination, so must force the error to be EIO */
5261     if ((retval != 0) && (pre_delete != 0))
5262         errno = EIO;
5263
5264     return retval;
5265 }
5266 /*}}}*/
5267
5268
5269 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5270 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5271  * to expand file specification.  Allows for a single default file
5272  * specification and a simple mask of options.  If outbuf is non-NULL,
5273  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5274  * the resultant file specification is placed.  If outbuf is NULL, the
5275  * resultant file specification is placed into a static buffer.
5276  * The third argument, if non-NULL, is taken to be a default file
5277  * specification string.  The fourth argument is unused at present.
5278  * rmesexpand() returns the address of the resultant string if
5279  * successful, and NULL on error.
5280  *
5281  * New functionality for previously unused opts value:
5282  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5283  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5284  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5285  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5286  */
5287 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5288
5289 static char *
5290 mp_do_rmsexpand
5291    (pTHX_ const char *filespec,
5292     char *outbuf,
5293     int ts,
5294     const char *defspec,
5295     unsigned opts,
5296     int * fs_utf8,
5297     int * dfs_utf8)
5298 {
5299   static char __rmsexpand_retbuf[VMS_MAXRSS];
5300   char * vmsfspec, *tmpfspec;
5301   char * esa, *cp, *out = NULL;
5302   char * tbuf;
5303   char * esal = NULL;
5304   char * outbufl;
5305   struct FAB myfab = cc$rms_fab;
5306   rms_setup_nam(mynam);
5307   STRLEN speclen;
5308   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5309   int sts;
5310
5311   /* temp hack until UTF8 is actually implemented */
5312   if (fs_utf8 != NULL)
5313     *fs_utf8 = 0;
5314
5315   if (!filespec || !*filespec) {
5316     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5317     return NULL;
5318   }
5319   if (!outbuf) {
5320     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
5321     else    outbuf = __rmsexpand_retbuf;
5322   }
5323
5324   vmsfspec = NULL;
5325   tmpfspec = NULL;
5326   outbufl = NULL;
5327
5328   isunix = 0;
5329   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5330     isunix = is_unix_filespec(filespec);
5331     if (isunix) {
5332       vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5333       if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
5334       if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
5335         PerlMem_free(vmsfspec);
5336         if (out)
5337            Safefree(out);
5338         return NULL;
5339       }
5340       filespec = vmsfspec;
5341
5342       /* Unless we are forcing to VMS format, a UNIX input means
5343        * UNIX output, and that requires long names to be used
5344        */
5345       if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5346         opts |= PERL_RMSEXPAND_M_LONG;
5347       else {
5348         isunix = 0;
5349       }
5350     }
5351   }
5352
5353   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
5354   rms_bind_fab_nam(myfab, mynam);
5355
5356   if (defspec && *defspec) {
5357     int t_isunix;
5358     t_isunix = is_unix_filespec(defspec);
5359     if (t_isunix) {
5360       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5361       if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5362       if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
5363         PerlMem_free(tmpfspec);
5364         if (vmsfspec != NULL)
5365             PerlMem_free(vmsfspec);
5366         if (out)
5367            Safefree(out);
5368         return NULL;
5369       }
5370       defspec = tmpfspec;
5371     }
5372     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
5373   }
5374
5375   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5376   if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5377 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5378   esal = PerlMem_malloc(VMS_MAXRSS);
5379   if (esal == NULL) _ckvmssts(SS$_INSFMEM);
5380 #endif
5381   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5382
5383   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5384     rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
5385   }
5386   else {
5387 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5388     outbufl = PerlMem_malloc(VMS_MAXRSS);
5389     if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
5390     rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5391 #else
5392     rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
5393 #endif
5394   }
5395
5396 #ifdef NAM$M_NO_SHORT_UPCASE
5397   if (decc_efs_case_preserve)
5398     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5399 #endif
5400
5401    /* We may not want to follow symbolic links */
5402 #ifdef NAML$M_OPEN_SPECIAL
5403   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5404     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5405 #endif
5406
5407   /* First attempt to parse as an existing file */
5408   retsts = sys$parse(&myfab,0,0);
5409   if (!(retsts & STS$K_SUCCESS)) {
5410
5411     /* Could not find the file, try as syntax only if error is not fatal */
5412     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5413     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
5414       retsts = sys$parse(&myfab,0,0);
5415       if (retsts & STS$K_SUCCESS) goto expanded;
5416     }
5417
5418      /* Still could not parse the file specification */
5419     /*----------------------------------------------*/
5420     sts = rms_free_search_context(&myfab); /* Free search context */
5421     if (out) Safefree(out);
5422     if (tmpfspec != NULL)
5423         PerlMem_free(tmpfspec);
5424     if (vmsfspec != NULL)
5425         PerlMem_free(vmsfspec);
5426     if (outbufl != NULL)
5427         PerlMem_free(outbufl);
5428     PerlMem_free(esa);
5429     if (esal != NULL)
5430         PerlMem_free(esal);
5431     set_vaxc_errno(retsts);
5432     if      (retsts == RMS$_PRV) set_errno(EACCES);
5433     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5434     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5435     else                         set_errno(EVMSERR);
5436     return NULL;
5437   }
5438   retsts = sys$search(&myfab,0,0);
5439   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5440     sts = rms_free_search_context(&myfab); /* Free search context */
5441     if (out) Safefree(out);
5442     if (tmpfspec != NULL)
5443         PerlMem_free(tmpfspec);
5444     if (vmsfspec != NULL)
5445         PerlMem_free(vmsfspec);
5446     if (outbufl != NULL)
5447         PerlMem_free(outbufl);
5448     PerlMem_free(esa);
5449     if (esal != NULL)
5450         PerlMem_free(esal);
5451     set_vaxc_errno(retsts);
5452     if      (retsts == RMS$_PRV) set_errno(EACCES);
5453     else                         set_errno(EVMSERR);
5454     return NULL;
5455   }
5456
5457   /* If the input filespec contained any lowercase characters,
5458    * downcase the result for compatibility with Unix-minded code. */
5459   expanded:
5460   if (!decc_efs_case_preserve) {
5461     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5462       if (islower(*tbuf)) { haslower = 1; break; }
5463   }
5464
5465    /* Is a long or a short name expected */
5466   /*------------------------------------*/
5467   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5468     if (rms_nam_rsll(mynam)) {
5469         tbuf = outbuf;
5470         speclen = rms_nam_rsll(mynam);
5471     }
5472     else {
5473         tbuf = esal; /* Not esa */
5474         speclen = rms_nam_esll(mynam);
5475     }
5476   }
5477   else {
5478     if (rms_nam_rsl(mynam)) {
5479         tbuf = outbuf;
5480         speclen = rms_nam_rsl(mynam);
5481     }
5482     else {
5483         tbuf = esa; /* Not esal */
5484         speclen = rms_nam_esl(mynam);
5485     }
5486   }
5487   tbuf[speclen] = '\0';
5488
5489   /* Trim off null fields added by $PARSE
5490    * If type > 1 char, must have been specified in original or default spec
5491    * (not true for version; $SEARCH may have added version of existing file).
5492    */
5493   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5494   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5495     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5496              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5497   }
5498   else {
5499     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5500              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5501   }
5502   if (trimver || trimtype) {
5503     if (defspec && *defspec) {
5504       char *defesal = NULL;
5505       defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5506       if (defesal != NULL) {
5507         struct FAB deffab = cc$rms_fab;
5508         rms_setup_nam(defnam);
5509
5510         rms_bind_fab_nam(deffab, defnam);
5511
5512         /* Cast ok */
5513         rms_set_fna
5514             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5515
5516         rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
5517
5518         rms_clear_nam_nop(defnam);
5519         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5520 #ifdef NAM$M_NO_SHORT_UPCASE
5521         if (decc_efs_case_preserve)
5522           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5523 #endif
5524 #ifdef NAML$M_OPEN_SPECIAL
5525         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5526           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5527 #endif
5528         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5529           if (trimver) {
5530              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5531           }
5532           if (trimtype) {
5533             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5534           }
5535         }
5536         PerlMem_free(defesal);
5537       }
5538     }
5539     if (trimver) {
5540       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5541         if (*(rms_nam_verl(mynam)) != '\"')
5542           speclen = rms_nam_verl(mynam) - tbuf;
5543       }
5544       else {
5545         if (*(rms_nam_ver(mynam)) != '\"')
5546           speclen = rms_nam_ver(mynam) - tbuf;
5547       }
5548     }
5549     if (trimtype) {
5550       /* If we didn't already trim version, copy down */
5551       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5552         if (speclen > rms_nam_verl(mynam) - tbuf)
5553           memmove
5554            (rms_nam_typel(mynam),
5555             rms_nam_verl(mynam),
5556             speclen - (rms_nam_verl(mynam) - tbuf));
5557           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5558       }
5559       else {
5560         if (speclen > rms_nam_ver(mynam) - tbuf)
5561           memmove
5562            (rms_nam_type(mynam),
5563             rms_nam_ver(mynam),
5564             speclen - (rms_nam_ver(mynam) - tbuf));
5565           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5566       }
5567     }
5568   }
5569
5570    /* Done with these copies of the input files */
5571   /*-------------------------------------------*/
5572   if (vmsfspec != NULL)
5573         PerlMem_free(vmsfspec);
5574   if (tmpfspec != NULL)
5575         PerlMem_free(tmpfspec);
5576
5577   /* If we just had a directory spec on input, $PARSE "helpfully"
5578    * adds an empty name and type for us */
5579   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5580     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5581         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5582         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5583       speclen = rms_nam_namel(mynam) - tbuf;
5584   }
5585   else {
5586     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5587         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5588         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5589       speclen = rms_nam_name(mynam) - tbuf;
5590   }
5591
5592   /* Posix format specifications must have matching quotes */
5593   if (speclen < (VMS_MAXRSS - 1)) {
5594     if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
5595       if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
5596         tbuf[speclen] = '\"';
5597         speclen++;
5598       }
5599     }
5600   }
5601   tbuf[speclen] = '\0';
5602   if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
5603
5604   /* Have we been working with an expanded, but not resultant, spec? */
5605   /* Also, convert back to Unix syntax if necessary. */
5606
5607   if (!rms_nam_rsll(mynam)) {
5608     if (isunix) {
5609       if (do_tounixspec(tbuf, outbuf ,0 , fs_utf8) == NULL) {
5610         if (out) Safefree(out);
5611         if (esal != NULL)
5612             PerlMem_free(esal);
5613         PerlMem_free(esa);
5614         if (outbufl != NULL)
5615             PerlMem_free(outbufl);
5616         return NULL;
5617       }
5618     }
5619     else strcpy(outbuf, tbuf);
5620   }
5621   else if (isunix) {
5622     tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5623     if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5624     if (do_tounixspec(outbuf,tmpfspec,0,fs_utf8) == NULL) {
5625         if (out) Safefree(out);
5626         PerlMem_free(esa);
5627         if (esal != NULL)
5628             PerlMem_free(esal);
5629         PerlMem_free(tmpfspec);
5630         if (outbufl != NULL)
5631             PerlMem_free(outbufl);
5632         return NULL;
5633     }
5634     strcpy(outbuf,tmpfspec);
5635     PerlMem_free(tmpfspec);
5636   }
5637
5638   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5639   sts = rms_free_search_context(&myfab); /* Free search context */
5640   PerlMem_free(esa);
5641   if (esal != NULL)
5642      PerlMem_free(esal);
5643   if (outbufl != NULL)
5644      PerlMem_free(outbufl);
5645   return outbuf;
5646 }
5647 /*}}}*/
5648 /* External entry points */
5649 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5650 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5651 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5652 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5653 char *Perl_rmsexpand_utf8
5654   (pTHX_ const char *spec, char *buf, const char *def,
5655    unsigned opt, int * fs_utf8, int * dfs_utf8)
5656 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5657 char *Perl_rmsexpand_utf8_ts
5658   (pTHX_ const char *spec, char *buf, const char *def,
5659    unsigned opt, int * fs_utf8, int * dfs_utf8)
5660 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5661
5662
5663 /*
5664 ** The following routines are provided to make life easier when
5665 ** converting among VMS-style and Unix-style directory specifications.
5666 ** All will take input specifications in either VMS or Unix syntax. On
5667 ** failure, all return NULL.  If successful, the routines listed below
5668 ** return a pointer to a buffer containing the appropriately
5669 ** reformatted spec (and, therefore, subsequent calls to that routine
5670 ** will clobber the result), while the routines of the same names with
5671 ** a _ts suffix appended will return a pointer to a mallocd string
5672 ** containing the appropriately reformatted spec.
5673 ** In all cases, only explicit syntax is altered; no check is made that
5674 ** the resulting string is valid or that the directory in question
5675 ** actually exists.
5676 **
5677 **   fileify_dirspec() - convert a directory spec into the name of the
5678 **     directory file (i.e. what you can stat() to see if it's a dir).
5679 **     The style (VMS or Unix) of the result is the same as the style
5680 **     of the parameter passed in.
5681 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5682 **     what you prepend to a filename to indicate what directory it's in).
5683 **     The style (VMS or Unix) of the result is the same as the style
5684 **     of the parameter passed in.
5685 **   tounixpath() - convert a directory spec into a Unix-style path.
5686 **   tovmspath() - convert a directory spec into a VMS-style path.
5687 **   tounixspec() - convert any file spec into a Unix-style file spec.
5688 **   tovmsspec() - convert any file spec into a VMS-style spec.
5689 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5690 **
5691 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5692 ** Permission is given to distribute this code as part of the Perl
5693 ** standard distribution under the terms of the GNU General Public
5694 ** License or the Perl Artistic License.  Copies of each may be
5695 ** found in the Perl standard distribution.
5696  */
5697
5698 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5699 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
5700 {
5701     static char __fileify_retbuf[VMS_MAXRSS];
5702     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5703     char *retspec, *cp1, *cp2, *lastdir;
5704     char *trndir, *vmsdir;
5705     unsigned short int trnlnm_iter_count;
5706     int sts;
5707     if (utf8_fl != NULL)
5708         *utf8_fl = 0;
5709
5710     if (!dir || !*dir) {
5711       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5712     }
5713     dirlen = strlen(dir);
5714     while (dirlen && dir[dirlen-1] == '/') --dirlen;
5715     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5716       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5717         dir = "/sys$disk";
5718         dirlen = 9;
5719       }
5720       else
5721         dirlen = 1;
5722     }
5723     if (dirlen > (VMS_MAXRSS - 1)) {
5724       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5725       return NULL;
5726     }
5727     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
5728     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5729     if (!strpbrk(dir+1,"/]>:")  &&
5730         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5731       strcpy(trndir,*dir == '/' ? dir + 1: dir);
5732       trnlnm_iter_count = 0;
5733       while (!strpbrk(trndir,"/]>:") && my_trnlnm(trndir,trndir,0)) {
5734         trnlnm_iter_count++;
5735         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5736       }
5737       dirlen = strlen(trndir);
5738     }
5739     else {
5740       strncpy(trndir,dir,dirlen);
5741       trndir[dirlen] = '\0';
5742     }
5743
5744     /* At this point we are done with *dir and use *trndir which is a
5745      * copy that can be modified.  *dir must not be modified.
5746      */
5747
5748     /* If we were handed a rooted logical name or spec, treat it like a
5749      * simple directory, so that
5750      *    $ Define myroot dev:[dir.]
5751      *    ... do_fileify_dirspec("myroot",buf,1) ...
5752      * does something useful.
5753      */
5754     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5755       trndir[--dirlen] = '\0';
5756       trndir[dirlen-1] = ']';
5757     }
5758     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5759       trndir[--dirlen] = '\0';
5760       trndir[dirlen-1] = '>';
5761     }
5762
5763     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5764       /* If we've got an explicit filename, we can just shuffle the string. */
5765       if (*(cp1+1)) hasfilename = 1;
5766       /* Similarly, we can just back up a level if we've got multiple levels
5767          of explicit directories in a VMS spec which ends with directories. */
5768       else {
5769         for (cp2 = cp1; cp2 > trndir; cp2--) {
5770           if (*cp2 == '.') {
5771             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5772 /* fix-me, can not scan EFS file specs backward like this */
5773               *cp2 = *cp1; *cp1 = '\0';
5774               hasfilename = 1;
5775               break;
5776             }
5777           }
5778           if (*cp2 == '[' || *cp2 == '<') break;
5779         }
5780       }
5781     }
5782
5783     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
5784     if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
5785     cp1 = strpbrk(trndir,"]:>");
5786     if (hasfilename || !cp1) { /* Unix-style path or filename */
5787       if (trndir[0] == '.') {
5788         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5789           PerlMem_free(trndir);
5790           PerlMem_free(vmsdir);
5791           return do_fileify_dirspec("[]",buf,ts,NULL);
5792         }
5793         else if (trndir[1] == '.' &&
5794                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5795           PerlMem_free(trndir);
5796           PerlMem_free(vmsdir);
5797           return do_fileify_dirspec("[-]",buf,ts,NULL);
5798         }
5799       }
5800       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
5801         dirlen -= 1;                 /* to last element */
5802         lastdir = strrchr(trndir,'/');
5803       }
5804       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
5805         /* If we have "/." or "/..", VMSify it and let the VMS code
5806          * below expand it, rather than repeating the code to handle
5807          * relative components of a filespec here */
5808         do {
5809           if (*(cp1+2) == '.') cp1++;
5810           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
5811             char * ret_chr;
5812             if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5813                 PerlMem_free(trndir);
5814                 PerlMem_free(vmsdir);
5815                 return NULL;
5816             }
5817             if (strchr(vmsdir,'/') != NULL) {
5818               /* If do_tovmsspec() returned it, it must have VMS syntax
5819                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
5820                * the time to check this here only so we avoid a recursion
5821                * loop; otherwise, gigo.
5822                */
5823               PerlMem_free(trndir);
5824               PerlMem_free(vmsdir);
5825               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
5826               return NULL;
5827             }
5828             if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5829                 PerlMem_free(trndir);
5830                 PerlMem_free(vmsdir);
5831                 return NULL;
5832             }
5833             ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5834             PerlMem_free(trndir);
5835             PerlMem_free(vmsdir);
5836             return ret_chr;
5837           }
5838           cp1++;
5839         } while ((cp1 = strstr(cp1,"/.")) != NULL);
5840         lastdir = strrchr(trndir,'/');
5841       }
5842       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5843         char * ret_chr;
5844         /* Ditto for specs that end in an MFD -- let the VMS code
5845          * figure out whether it's a real device or a rooted logical. */
5846
5847         /* This should not happen any more.  Allowing the fake /000000
5848          * in a UNIX pathname causes all sorts of problems when trying
5849          * to run in UNIX emulation.  So the VMS to UNIX conversions
5850          * now remove the fake /000000 directories.
5851          */
5852
5853         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5854         if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5855             PerlMem_free(trndir);
5856             PerlMem_free(vmsdir);
5857             return NULL;
5858         }
5859         if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5860             PerlMem_free(trndir);
5861             PerlMem_free(vmsdir);
5862             return NULL;
5863         }
5864         ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5865         PerlMem_free(trndir);
5866         PerlMem_free(vmsdir);
5867         return ret_chr;
5868       }
5869       else {
5870
5871         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5872              !(lastdir = cp1 = strrchr(trndir,']')) &&
5873              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5874         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
5875           int ver; char *cp3;
5876
5877           /* For EFS or ODS-5 look for the last dot */
5878           if (decc_efs_charset) {
5879               cp2 = strrchr(cp1,'.');
5880           }
5881           if (vms_process_case_tolerant) {
5882               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5883                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5884                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5885                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5886                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5887                             (ver || *cp3)))))) {
5888                   PerlMem_free(trndir);
5889                   PerlMem_free(vmsdir);
5890                   set_errno(ENOTDIR);
5891                   set_vaxc_errno(RMS$_DIR);
5892                   return NULL;
5893               }
5894           }
5895           else {
5896               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5897                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5898                   !*(cp2+3) || *(cp2+3) != 'R' ||
5899                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5900                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5901                             (ver || *cp3)))))) {
5902                  PerlMem_free(trndir);
5903                  PerlMem_free(vmsdir);
5904                  set_errno(ENOTDIR);
5905                  set_vaxc_errno(RMS$_DIR);
5906                  return NULL;
5907               }
5908           }
5909           dirlen = cp2 - trndir;
5910         }
5911       }
5912
5913       retlen = dirlen + 6;
5914       if (buf) retspec = buf;
5915       else if (ts) Newx(retspec,retlen+1,char);
5916       else retspec = __fileify_retbuf;
5917       memcpy(retspec,trndir,dirlen);
5918       retspec[dirlen] = '\0';
5919
5920       /* We've picked up everything up to the directory file name.
5921          Now just add the type and version, and we're set. */
5922       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5923         strcat(retspec,".dir;1");
5924       else
5925         strcat(retspec,".DIR;1");
5926       PerlMem_free(trndir);
5927       PerlMem_free(vmsdir);
5928       return retspec;
5929     }
5930     else {  /* VMS-style directory spec */
5931
5932       char *esa, term, *cp;
5933       unsigned long int sts, cmplen, haslower = 0;
5934       unsigned int nam_fnb;
5935       char * nam_type;
5936       struct FAB dirfab = cc$rms_fab;
5937       rms_setup_nam(savnam);
5938       rms_setup_nam(dirnam);
5939
5940       esa = PerlMem_malloc(VMS_MAXRSS + 1);
5941       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5942       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5943       rms_bind_fab_nam(dirfab, dirnam);
5944       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5945       rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
5946 #ifdef NAM$M_NO_SHORT_UPCASE
5947       if (decc_efs_case_preserve)
5948         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5949 #endif
5950
5951       for (cp = trndir; *cp; cp++)
5952         if (islower(*cp)) { haslower = 1; break; }
5953       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5954         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5955           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5956           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5957         }
5958         if (!sts) {
5959           PerlMem_free(esa);
5960           PerlMem_free(trndir);
5961           PerlMem_free(vmsdir);
5962           set_errno(EVMSERR);
5963           set_vaxc_errno(dirfab.fab$l_sts);
5964           return NULL;
5965         }
5966       }
5967       else {
5968         savnam = dirnam;
5969         /* Does the file really exist? */
5970         if (sys$search(&dirfab)& STS$K_SUCCESS) {
5971           /* Yes; fake the fnb bits so we'll check type below */
5972         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
5973         }
5974         else { /* No; just work with potential name */
5975           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
5976           else {
5977             int fab_sts;
5978             fab_sts = dirfab.fab$l_sts;
5979             sts = rms_free_search_context(&dirfab);
5980             PerlMem_free(esa);
5981             PerlMem_free(trndir);
5982             PerlMem_free(vmsdir);
5983             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
5984             return NULL;
5985           }
5986         }
5987       }
5988       esa[rms_nam_esll(dirnam)] = '\0';
5989       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
5990         cp1 = strchr(esa,']');
5991         if (!cp1) cp1 = strchr(esa,'>');
5992         if (cp1) {  /* Should always be true */
5993           rms_nam_esll(dirnam) -= cp1 - esa - 1;
5994           memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
5995         }
5996       }
5997       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5998         /* Yep; check version while we're at it, if it's there. */
5999         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6000         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6001           /* Something other than .DIR[;1].  Bzzt. */
6002           sts = rms_free_search_context(&dirfab);
6003           PerlMem_free(esa);
6004           PerlMem_free(trndir);
6005           PerlMem_free(vmsdir);
6006           set_errno(ENOTDIR);
6007           set_vaxc_errno(RMS$_DIR);
6008           return NULL;
6009         }
6010       }
6011
6012       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6013         /* They provided at least the name; we added the type, if necessary, */
6014         if (buf) retspec = buf;                            /* in sys$parse() */
6015         else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
6016         else retspec = __fileify_retbuf;
6017         strcpy(retspec,esa);
6018         sts = rms_free_search_context(&dirfab);
6019         PerlMem_free(trndir);
6020         PerlMem_free(esa);
6021         PerlMem_free(vmsdir);
6022         return retspec;
6023       }
6024       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6025         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6026         *cp1 = '\0';
6027         rms_nam_esll(dirnam) -= 9;
6028       }
6029       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
6030       if (cp1 == NULL) { /* should never happen */
6031         sts = rms_free_search_context(&dirfab);
6032         PerlMem_free(trndir);
6033         PerlMem_free(esa);
6034         PerlMem_free(vmsdir);
6035         return NULL;
6036       }
6037       term = *cp1;
6038       *cp1 = '\0';
6039       retlen = strlen(esa);
6040       cp1 = strrchr(esa,'.');
6041       /* ODS-5 directory specifications can have extra "." in them. */
6042       /* Fix-me, can not scan EFS file specifications backwards */
6043       while (cp1 != NULL) {
6044         if ((cp1-1 == esa) || (*(cp1-1) != '^'))
6045           break;
6046         else {
6047            cp1--;
6048            while ((cp1 > esa) && (*cp1 != '.'))
6049              cp1--;
6050         }
6051         if (cp1 == esa)
6052           cp1 = NULL;
6053       }
6054
6055       if ((cp1) != NULL) {
6056         /* There's more than one directory in the path.  Just roll back. */
6057         *cp1 = term;
6058         if (buf) retspec = buf;
6059         else if (ts) Newx(retspec,retlen+7,char);
6060         else retspec = __fileify_retbuf;
6061         strcpy(retspec,esa);
6062       }
6063       else {
6064         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6065           /* Go back and expand rooted logical name */
6066           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6067 #ifdef NAM$M_NO_SHORT_UPCASE
6068           if (decc_efs_case_preserve)
6069             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6070 #endif
6071           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6072             sts = rms_free_search_context(&dirfab);
6073             PerlMem_free(esa);
6074             PerlMem_free(trndir);
6075             PerlMem_free(vmsdir);
6076             set_errno(EVMSERR);
6077             set_vaxc_errno(dirfab.fab$l_sts);
6078             return NULL;
6079           }
6080           retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
6081           if (buf) retspec = buf;
6082           else if (ts) Newx(retspec,retlen+16,char);
6083           else retspec = __fileify_retbuf;
6084           cp1 = strstr(esa,"][");
6085           if (!cp1) cp1 = strstr(esa,"]<");
6086           dirlen = cp1 - esa;
6087           memcpy(retspec,esa,dirlen);
6088           if (!strncmp(cp1+2,"000000]",7)) {
6089             retspec[dirlen-1] = '\0';
6090             /* fix-me Not full ODS-5, just extra dots in directories for now */
6091             cp1 = retspec + dirlen - 1;
6092             while (cp1 > retspec)
6093             {
6094               if (*cp1 == '[')
6095                 break;
6096               if (*cp1 == '.') {
6097                 if (*(cp1-1) != '^')
6098                   break;
6099               }
6100               cp1--;
6101             }
6102             if (*cp1 == '.') *cp1 = ']';
6103             else {
6104               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6105               memmove(cp1+1,"000000]",7);
6106             }
6107           }
6108           else {
6109             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
6110             retspec[retlen] = '\0';
6111             /* Convert last '.' to ']' */
6112             cp1 = retspec+retlen-1;
6113             while (*cp != '[') {
6114               cp1--;
6115               if (*cp1 == '.') {
6116                 /* Do not trip on extra dots in ODS-5 directories */
6117                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
6118                 break;
6119               }
6120             }
6121             if (*cp1 == '.') *cp1 = ']';
6122             else {
6123               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6124               memmove(cp1+1,"000000]",7);
6125             }
6126           }
6127         }
6128         else {  /* This is a top-level dir.  Add the MFD to the path. */
6129           if (buf) retspec = buf;
6130           else if (ts) Newx(retspec,retlen+16,char);
6131           else retspec = __fileify_retbuf;
6132           cp1 = esa;
6133           cp2 = retspec;
6134           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6135           strcpy(cp2,":[000000]");
6136           cp1 += 2;
6137           strcpy(cp2+9,cp1);
6138         }
6139       }
6140       sts = rms_free_search_context(&dirfab);
6141       /* We've set up the string up through the filename.  Add the
6142          type and version, and we're done. */
6143       strcat(retspec,".DIR;1");
6144
6145       /* $PARSE may have upcased filespec, so convert output to lower
6146        * case if input contained any lowercase characters. */
6147       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
6148       PerlMem_free(trndir);
6149       PerlMem_free(esa);
6150       PerlMem_free(vmsdir);
6151       return retspec;
6152     }
6153 }  /* end of do_fileify_dirspec() */
6154 /*}}}*/
6155 /* External entry points */
6156 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6157 { return do_fileify_dirspec(dir,buf,0,NULL); }
6158 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6159 { return do_fileify_dirspec(dir,buf,1,NULL); }
6160 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6161 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6162 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6163 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6164
6165 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6166 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6167 {
6168     static char __pathify_retbuf[VMS_MAXRSS];
6169     unsigned long int retlen;
6170     char *retpath, *cp1, *cp2, *trndir;
6171     unsigned short int trnlnm_iter_count;
6172     STRLEN trnlen;
6173     int sts;
6174     if (utf8_fl != NULL)
6175         *utf8_fl = 0;
6176
6177     if (!dir || !*dir) {
6178       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6179     }
6180
6181     trndir = PerlMem_malloc(VMS_MAXRSS);
6182     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
6183     if (*dir) strcpy(trndir,dir);
6184     else getcwd(trndir,VMS_MAXRSS - 1);
6185
6186     trnlnm_iter_count = 0;
6187     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6188            && my_trnlnm(trndir,trndir,0)) {
6189       trnlnm_iter_count++;
6190       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6191       trnlen = strlen(trndir);
6192
6193       /* Trap simple rooted lnms, and return lnm:[000000] */
6194       if (!strcmp(trndir+trnlen-2,".]")) {
6195         if (buf) retpath = buf;
6196         else if (ts) Newx(retpath,strlen(dir)+10,char);
6197         else retpath = __pathify_retbuf;
6198         strcpy(retpath,dir);
6199         strcat(retpath,":[000000]");
6200         PerlMem_free(trndir);
6201         return retpath;
6202       }
6203     }
6204
6205     /* At this point we do not work with *dir, but the copy in
6206      * *trndir that is modifiable.
6207      */
6208
6209     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
6210       if (*trndir == '.' && (*(trndir+1) == '\0' ||
6211                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
6212         retlen = 2 + (*(trndir+1) != '\0');
6213       else {
6214         if ( !(cp1 = strrchr(trndir,'/')) &&
6215              !(cp1 = strrchr(trndir,']')) &&
6216              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
6217         if ((cp2 = strchr(cp1,'.')) != NULL &&
6218             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
6219              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
6220               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
6221               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
6222           int ver; char *cp3;
6223
6224           /* For EFS or ODS-5 look for the last dot */
6225           if (decc_efs_charset) {
6226             cp2 = strrchr(cp1,'.');
6227           }
6228           if (vms_process_case_tolerant) {
6229               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
6230                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
6231                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6232                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6233                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6234                             (ver || *cp3)))))) {
6235                 PerlMem_free(trndir);
6236                 set_errno(ENOTDIR);
6237                 set_vaxc_errno(RMS$_DIR);
6238                 return NULL;
6239               }
6240           }
6241           else {
6242               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
6243                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
6244                   !*(cp2+3) || *(cp2+3) != 'R' ||
6245                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6246                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6247                             (ver || *cp3)))))) {
6248                 PerlMem_free(trndir);
6249                 set_errno(ENOTDIR);
6250                 set_vaxc_errno(RMS$_DIR);
6251                 return NULL;
6252               }
6253           }
6254           retlen = cp2 - trndir + 1;
6255         }
6256         else {  /* No file type present.  Treat the filename as a directory. */
6257           retlen = strlen(trndir) + 1;
6258         }
6259       }
6260       if (buf) retpath = buf;
6261       else if (ts) Newx(retpath,retlen+1,char);
6262       else retpath = __pathify_retbuf;
6263       strncpy(retpath, trndir, retlen-1);
6264       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
6265         retpath[retlen-1] = '/';      /* with '/', add it. */
6266         retpath[retlen] = '\0';
6267       }
6268       else retpath[retlen-1] = '\0';
6269     }
6270     else {  /* VMS-style directory spec */
6271       char *esa, *cp;
6272       unsigned long int sts, cmplen, haslower;
6273       struct FAB dirfab = cc$rms_fab;
6274       int dirlen;
6275       rms_setup_nam(savnam);
6276       rms_setup_nam(dirnam);
6277
6278       /* If we've got an explicit filename, we can just shuffle the string. */
6279       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
6280              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
6281         if ((cp2 = strchr(cp1,'.')) != NULL) {
6282           int ver; char *cp3;
6283           if (vms_process_case_tolerant) {
6284               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
6285                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
6286                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6287                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6288                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6289                             (ver || *cp3)))))) {
6290                PerlMem_free(trndir);
6291                set_errno(ENOTDIR);
6292                set_vaxc_errno(RMS$_DIR);
6293                return NULL;
6294              }
6295           }
6296           else {
6297               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
6298                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
6299                   !*(cp2+3) || *(cp2+3) != 'R' ||
6300                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6301                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6302                             (ver || *cp3)))))) {
6303                PerlMem_free(trndir);
6304                set_errno(ENOTDIR);
6305                set_vaxc_errno(RMS$_DIR);
6306                return NULL;
6307              }
6308           }
6309         }
6310         else {  /* No file type, so just draw name into directory part */
6311           for (cp2 = cp1; *cp2; cp2++) ;
6312         }
6313         *cp2 = *cp1;
6314         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
6315         *cp1 = '.';
6316         /* We've now got a VMS 'path'; fall through */
6317       }
6318
6319       dirlen = strlen(trndir);
6320       if (trndir[dirlen-1] == ']' ||
6321           trndir[dirlen-1] == '>' ||
6322           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
6323         if (buf) retpath = buf;
6324         else if (ts) Newx(retpath,strlen(trndir)+1,char);
6325         else retpath = __pathify_retbuf;
6326         strcpy(retpath,trndir);
6327         PerlMem_free(trndir);
6328         return retpath;
6329       }
6330       rms_set_fna(dirfab, dirnam, trndir, dirlen);
6331       esa = PerlMem_malloc(VMS_MAXRSS);
6332       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
6333       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6334       rms_bind_fab_nam(dirfab, dirnam);
6335       rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
6336 #ifdef NAM$M_NO_SHORT_UPCASE
6337       if (decc_efs_case_preserve)
6338           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6339 #endif
6340
6341       for (cp = trndir; *cp; cp++)
6342         if (islower(*cp)) { haslower = 1; break; }
6343
6344       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
6345         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
6346           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6347           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
6348         }
6349         if (!sts) {
6350           PerlMem_free(trndir);
6351           PerlMem_free(esa);
6352           set_errno(EVMSERR);
6353           set_vaxc_errno(dirfab.fab$l_sts);
6354           return NULL;
6355         }
6356       }
6357       else {
6358         savnam = dirnam;
6359         /* Does the file really exist? */
6360         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
6361           if (dirfab.fab$l_sts != RMS$_FNF) {
6362             int sts1;
6363             sts1 = rms_free_search_context(&dirfab);
6364             PerlMem_free(trndir);
6365             PerlMem_free(esa);
6366             set_errno(EVMSERR);
6367             set_vaxc_errno(dirfab.fab$l_sts);
6368             return NULL;
6369           }
6370           dirnam = savnam; /* No; just work with potential name */
6371         }
6372       }
6373       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6374         /* Yep; check version while we're at it, if it's there. */
6375         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6376         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
6377           int sts2;
6378           /* Something other than .DIR[;1].  Bzzt. */
6379           sts2 = rms_free_search_context(&dirfab);
6380           PerlMem_free(trndir);
6381           PerlMem_free(esa);
6382           set_errno(ENOTDIR);
6383           set_vaxc_errno(RMS$_DIR);
6384           return NULL;
6385         }
6386       }
6387       /* OK, the type was fine.  Now pull any file name into the
6388          directory path. */
6389       if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
6390       else {
6391         cp1 = strrchr(esa,'>');
6392         *(rms_nam_typel(dirnam)) = '>';
6393       }
6394       *cp1 = '.';
6395       *(rms_nam_typel(dirnam) + 1) = '\0';
6396       retlen = (rms_nam_typel(dirnam)) - esa + 2;
6397       if (buf) retpath = buf;
6398       else if (ts) Newx(retpath,retlen,char);
6399       else retpath = __pathify_retbuf;
6400       strcpy(retpath,esa);
6401       PerlMem_free(esa);
6402       sts = rms_free_search_context(&dirfab);
6403       /* $PARSE may have upcased filespec, so convert output to lower
6404        * case if input contained any lowercase characters. */
6405       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
6406     }
6407
6408     PerlMem_free(trndir);
6409     return retpath;
6410 }  /* end of do_pathify_dirspec() */
6411 /*}}}*/
6412 /* External entry points */
6413 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6414 { return do_pathify_dirspec(dir,buf,0,NULL); }
6415 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6416 { return do_pathify_dirspec(dir,buf,1,NULL); }
6417 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6418 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6419 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6420 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
6421
6422 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
6423 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
6424 {
6425   static char __tounixspec_retbuf[VMS_MAXRSS];
6426   char *dirend, *rslt, *cp1, *cp3, *tmp;
6427   const char *cp2;
6428   int devlen, dirlen, retlen = VMS_MAXRSS;
6429   int expand = 1; /* guarantee room for leading and trailing slashes */
6430   unsigned short int trnlnm_iter_count;
6431   int cmp_rslt;
6432   if (utf8_fl != NULL)
6433     *utf8_fl = 0;
6434
6435   if (spec == NULL) return NULL;
6436   if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
6437   if (buf) rslt = buf;
6438   else if (ts) {
6439     Newx(rslt, VMS_MAXRSS, char);
6440   }
6441   else rslt = __tounixspec_retbuf;
6442
6443   /* New VMS specific format needs translation
6444    * glob passes filenames with trailing '\n' and expects this preserved.
6445    */
6446   if (decc_posix_compliant_pathnames) {
6447     if (strncmp(spec, "\"^UP^", 5) == 0) {
6448       char * uspec;
6449       char *tunix;
6450       int tunix_len;
6451       int nl_flag;
6452
6453       tunix = PerlMem_malloc(VMS_MAXRSS);
6454       if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
6455       strcpy(tunix, spec);
6456       tunix_len = strlen(tunix);
6457       nl_flag = 0;
6458       if (tunix[tunix_len - 1] == '\n') {
6459         tunix[tunix_len - 1] = '\"';
6460         tunix[tunix_len] = '\0';
6461         tunix_len--;
6462         nl_flag = 1;
6463       }
6464       uspec = decc$translate_vms(tunix);
6465       PerlMem_free(tunix);
6466       if ((int)uspec > 0) {
6467         strcpy(rslt,uspec);
6468         if (nl_flag) {
6469           strcat(rslt,"\n");
6470         }
6471         else {
6472           /* If we can not translate it, makemaker wants as-is */
6473           strcpy(rslt, spec);
6474         }
6475         return rslt;
6476       }
6477     }
6478   }
6479
6480   cmp_rslt = 0; /* Presume VMS */
6481   cp1 = strchr(spec, '/');
6482   if (cp1 == NULL)
6483     cmp_rslt = 0;
6484
6485     /* Look for EFS ^/ */
6486     if (decc_efs_charset) {
6487       while (cp1 != NULL) {
6488         cp2 = cp1 - 1;
6489         if (*cp2 != '^') {
6490           /* Found illegal VMS, assume UNIX */
6491           cmp_rslt = 1;
6492           break;
6493         }
6494       cp1++;
6495       cp1 = strchr(cp1, '/');
6496     }
6497   }
6498
6499   /* Look for "." and ".." */
6500   if (decc_filename_unix_report) {
6501     if (spec[0] == '.') {
6502       if ((spec[1] == '\0') || (spec[1] == '\n')) {
6503         cmp_rslt = 1;
6504       }
6505       else {
6506         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
6507           cmp_rslt = 1;
6508         }
6509       }
6510     }
6511   }
6512   /* This is already UNIX or at least nothing VMS understands */
6513   if (cmp_rslt) {
6514     strcpy(rslt,spec);
6515     return rslt;
6516   }
6517
6518   cp1 = rslt;
6519   cp2 = spec;
6520   dirend = strrchr(spec,']');
6521   if (dirend == NULL) dirend = strrchr(spec,'>');
6522   if (dirend == NULL) dirend = strchr(spec,':');
6523   if (dirend == NULL) {
6524     strcpy(rslt,spec);
6525     return rslt;
6526   }
6527
6528   /* Special case 1 - sys$posix_root = / */
6529 #if __CRTL_VER >= 70000000
6530   if (!decc_disable_posix_root) {
6531     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6532       *cp1 = '/';
6533       cp1++;
6534       cp2 = cp2 + 15;
6535       }
6536   }
6537 #endif
6538
6539   /* Special case 2 - Convert NLA0: to /dev/null */
6540 #if __CRTL_VER < 70000000
6541   cmp_rslt = strncmp(spec,"NLA0:", 5);
6542   if (cmp_rslt != 0)
6543      cmp_rslt = strncmp(spec,"nla0:", 5);
6544 #else
6545   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6546 #endif
6547   if (cmp_rslt == 0) {
6548     strcpy(rslt, "/dev/null");
6549     cp1 = cp1 + 9;
6550     cp2 = cp2 + 5;
6551     if (spec[6] != '\0') {
6552       cp1[9] == '/';
6553       cp1++;
6554       cp2++;
6555     }
6556   }
6557
6558    /* Also handle special case "SYS$SCRATCH:" */
6559 #if __CRTL_VER < 70000000
6560   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
6561   if (cmp_rslt != 0)
6562      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
6563 #else
6564   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6565 #endif
6566   tmp = PerlMem_malloc(VMS_MAXRSS);
6567   if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
6568   if (cmp_rslt == 0) {
6569   int islnm;
6570
6571     islnm = my_trnlnm(tmp, "TMP", 0);
6572     if (!islnm) {
6573       strcpy(rslt, "/tmp");
6574       cp1 = cp1 + 4;
6575       cp2 = cp2 + 12;
6576       if (spec[12] != '\0') {
6577         cp1[4] == '/';
6578         cp1++;
6579         cp2++;
6580       }
6581     }
6582   }
6583
6584   if (*cp2 != '[' && *cp2 != '<') {
6585     *(cp1++) = '/';
6586   }
6587   else {  /* the VMS spec begins with directories */
6588     cp2++;
6589     if (*cp2 == ']' || *cp2 == '>') {
6590       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
6591       PerlMem_free(tmp);
6592       return rslt;
6593     }
6594     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
6595       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
6596         if (ts) Safefree(rslt);
6597         PerlMem_free(tmp);
6598         return NULL;
6599       }
6600       trnlnm_iter_count = 0;
6601       do {
6602         cp3 = tmp;
6603         while (*cp3 != ':' && *cp3) cp3++;
6604         *(cp3++) = '\0';
6605         if (strchr(cp3,']') != NULL) break;
6606         trnlnm_iter_count++;
6607         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
6608       } while (vmstrnenv(tmp,tmp,0,fildev,0));
6609       if (ts && !buf &&
6610           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
6611         retlen = devlen + dirlen;
6612         Renew(rslt,retlen+1+2*expand,char);
6613         cp1 = rslt;
6614       }
6615       cp3 = tmp;
6616       *(cp1++) = '/';
6617       while (*cp3) {
6618         *(cp1++) = *(cp3++);
6619         if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
6620             PerlMem_free(tmp);
6621             return NULL; /* No room */
6622         }
6623       }
6624       *(cp1++) = '/';
6625     }
6626     if ((*cp2 == '^')) {
6627         /* EFS file escape, pass the next character as is */
6628         /* Fix me: HEX encoding for Unicode not implemented */
6629         cp2++;
6630     }
6631     else if ( *cp2 == '.') {
6632       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
6633         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6634         cp2 += 3;
6635       }
6636       else cp2++;
6637     }
6638   }
6639   PerlMem_free(tmp);
6640   for (; cp2 <= dirend; cp2++) {
6641     if ((*cp2 == '^')) {
6642         /* EFS file escape, pass the next character as is */
6643         /* Fix me: HEX encoding for Unicode not implemented */
6644         *(cp1++) = *(++cp2);
6645         /* An escaped dot stays as is -- don't convert to slash */
6646         if (*cp2 == '.') cp2++;
6647     }
6648     if (*cp2 == ':') {
6649       *(cp1++) = '/';
6650       if (*(cp2+1) == '[') cp2++;
6651     }
6652     else if (*cp2 == ']' || *cp2 == '>') {
6653       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6654     }
6655     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
6656       *(cp1++) = '/';
6657       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6658         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6659                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6660         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6661             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6662       }
6663       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6664         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6665         cp2 += 2;
6666       }
6667     }
6668     else if (*cp2 == '-') {
6669       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6670         while (*cp2 == '-') {
6671           cp2++;
6672           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6673         }
6674         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
6675           if (ts) Safefree(rslt);                        /* filespecs like */
6676           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
6677           return NULL;
6678         }
6679       }
6680       else *(cp1++) = *cp2;
6681     }
6682     else *(cp1++) = *cp2;
6683   }
6684   while (*cp2) {
6685     if ((*cp2 == '^') && (*(cp2+1) == '.')) cp2++;  /* '^.' --> '.' */
6686     *(cp1++) = *(cp2++);
6687   }
6688   *cp1 = '\0';
6689
6690   /* This still leaves /000000/ when working with a
6691    * VMS device root or concealed root.
6692    */
6693   {
6694   int ulen;
6695   char * zeros;
6696
6697       ulen = strlen(rslt);
6698
6699       /* Get rid of "000000/ in rooted filespecs */
6700       if (ulen > 7) {
6701         zeros = strstr(rslt, "/000000/");
6702         if (zeros != NULL) {
6703           int mlen;
6704           mlen = ulen - (zeros - rslt) - 7;
6705           memmove(zeros, &zeros[7], mlen);
6706           ulen = ulen - 7;
6707           rslt[ulen] = '\0';
6708         }
6709       }
6710   }
6711
6712   return rslt;
6713
6714 }  /* end of do_tounixspec() */
6715 /*}}}*/
6716 /* External entry points */
6717 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
6718   { return do_tounixspec(spec,buf,0, NULL); }
6719 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
6720   { return do_tounixspec(spec,buf,1, NULL); }
6721 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
6722   { return do_tounixspec(spec,buf,0, utf8_fl); }
6723 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
6724   { return do_tounixspec(spec,buf,1, utf8_fl); }
6725
6726 #if __CRTL_VER >= 70200000 && !defined(__VAX)
6727
6728 /*
6729  This procedure is used to identify if a path is based in either
6730  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
6731  it returns the OpenVMS format directory for it.
6732
6733  It is expecting specifications of only '/' or '/xxxx/'
6734
6735  If a posix root does not exist, or 'xxxx' is not a directory
6736  in the posix root, it returns a failure.
6737
6738  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
6739
6740  It is used only internally by posix_to_vmsspec_hardway().
6741  */
6742
6743 static int posix_root_to_vms
6744   (char *vmspath, int vmspath_len,
6745    const char *unixpath,
6746    const int * utf8_fl) {
6747 int sts;
6748 struct FAB myfab = cc$rms_fab;
6749 struct NAML mynam = cc$rms_naml;
6750 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6751  struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6752 char *esa;
6753 char *vms_delim;
6754 int dir_flag;
6755 int unixlen;
6756
6757     dir_flag = 0;
6758     unixlen = strlen(unixpath);
6759     if (unixlen == 0) {
6760       vmspath[0] = '\0';
6761       return RMS$_FNF;
6762     }
6763
6764 #if __CRTL_VER >= 80200000
6765   /* If not a posix spec already, convert it */
6766   if (decc_posix_compliant_pathnames) {
6767     if (strncmp(unixpath,"\"^UP^",5) != 0) {
6768       sprintf(vmspath,"\"^UP^%s\"",unixpath);
6769     }
6770     else {
6771       /* This is already a VMS specification, no conversion */
6772       unixlen--;
6773       strncpy(vmspath,unixpath, vmspath_len);
6774     }
6775   }
6776   else
6777 #endif
6778   {
6779   int path_len;
6780   int i,j;
6781
6782      /* Check to see if this is under the POSIX root */
6783      if (decc_disable_posix_root) {
6784         return RMS$_FNF;
6785      }
6786
6787      /* Skip leading / */
6788      if (unixpath[0] == '/') {
6789         unixpath++;
6790         unixlen--;
6791      }
6792
6793
6794      strcpy(vmspath,"SYS$POSIX_ROOT:");
6795
6796      /* If this is only the / , or blank, then... */
6797      if (unixpath[0] == '\0') {
6798         /* by definition, this is the answer */
6799         return SS$_NORMAL;
6800      }
6801
6802      /* Need to look up a directory */
6803      vmspath[15] = '[';
6804      vmspath[16] = '\0';
6805
6806      /* Copy and add '^' escape characters as needed */
6807      j = 16;
6808      i = 0;
6809      while (unixpath[i] != 0) {
6810      int k;
6811
6812         j += copy_expand_unix_filename_escape
6813             (&vmspath[j], &unixpath[i], &k, utf8_fl);
6814         i += k;
6815      }
6816
6817      path_len = strlen(vmspath);
6818      if (vmspath[path_len - 1] == '/')
6819         path_len--;
6820      vmspath[path_len] = ']';
6821      path_len++;
6822      vmspath[path_len] = '\0';
6823
6824   }
6825   vmspath[vmspath_len] = 0;
6826   if (unixpath[unixlen - 1] == '/')
6827   dir_flag = 1;
6828   esa = PerlMem_malloc(VMS_MAXRSS);
6829   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6830   myfab.fab$l_fna = vmspath;
6831   myfab.fab$b_fns = strlen(vmspath);
6832   myfab.fab$l_naml = &mynam;
6833   mynam.naml$l_esa = NULL;
6834   mynam.naml$b_ess = 0;
6835   mynam.naml$l_long_expand = esa;
6836   mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
6837   mynam.naml$l_rsa = NULL;
6838   mynam.naml$b_rss = 0;
6839   if (decc_efs_case_preserve)
6840     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6841 #ifdef NAML$M_OPEN_SPECIAL
6842   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6843 #endif
6844
6845   /* Set up the remaining naml fields */
6846   sts = sys$parse(&myfab);
6847
6848   /* It failed! Try again as a UNIX filespec */
6849   if (!(sts & 1)) {
6850     PerlMem_free(esa);
6851     return sts;
6852   }
6853
6854    /* get the Device ID and the FID */
6855    sts = sys$search(&myfab);
6856    /* on any failure, returned the POSIX ^UP^ filespec */
6857    if (!(sts & 1)) {
6858       PerlMem_free(esa);
6859       return sts;
6860    }
6861    specdsc.dsc$a_pointer = vmspath;
6862    specdsc.dsc$w_length = vmspath_len;
6863
6864    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6865    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6866    sts = lib$fid_to_name
6867       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6868
6869   /* on any failure, returned the POSIX ^UP^ filespec */
6870   if (!(sts & 1)) {
6871      /* This can happen if user does not have permission to read directories */
6872      if (strncmp(unixpath,"\"^UP^",5) != 0)
6873        sprintf(vmspath,"\"^UP^%s\"",unixpath);
6874      else
6875        strcpy(vmspath, unixpath);
6876   }
6877   else {
6878     vmspath[specdsc.dsc$w_length] = 0;
6879
6880     /* Are we expecting a directory? */
6881     if (dir_flag != 0) {
6882     int i;
6883     char *eptr;
6884
6885       eptr = NULL;
6886
6887       i = specdsc.dsc$w_length - 1;
6888       while (i > 0) {
6889       int zercnt;
6890         zercnt = 0;
6891         /* Version must be '1' */
6892         if (vmspath[i--] != '1')
6893           break;
6894         /* Version delimiter is one of ".;" */
6895         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6896           break;
6897         i--;
6898         if (vmspath[i--] != 'R')
6899           break;
6900         if (vmspath[i--] != 'I')
6901           break;
6902         if (vmspath[i--] != 'D')
6903           break;
6904         if (vmspath[i--] != '.')
6905           break;
6906         eptr = &vmspath[i+1];
6907         while (i > 0) {
6908           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
6909             if (vmspath[i-1] != '^') {
6910               if (zercnt != 6) {
6911                 *eptr = vmspath[i];
6912                 eptr[1] = '\0';
6913                 vmspath[i] = '.';
6914                 break;
6915               }
6916               else {
6917                 /* Get rid of 6 imaginary zero directory filename */
6918                 vmspath[i+1] = '\0';
6919               }
6920             }
6921           }
6922           if (vmspath[i] == '0')
6923             zercnt++;
6924           else
6925             zercnt = 10;
6926           i--;
6927         }
6928         break;
6929       }
6930     }
6931   }
6932   PerlMem_free(esa);
6933   return sts;
6934 }
6935
6936 /* /dev/mumble needs to be handled special.
6937    /dev/null becomes NLA0:, And there is the potential for other stuff
6938    like /dev/tty which may need to be mapped to something.
6939 */
6940
6941 static int
6942 slash_dev_special_to_vms
6943    (const char * unixptr,
6944     char * vmspath,
6945     int vmspath_len)
6946 {
6947 char * nextslash;
6948 int len;
6949 int cmp;
6950 int islnm;
6951
6952     unixptr += 4;
6953     nextslash = strchr(unixptr, '/');
6954     len = strlen(unixptr);
6955     if (nextslash != NULL)
6956         len = nextslash - unixptr;
6957     cmp = strncmp("null", unixptr, 5);
6958     if (cmp == 0) {
6959         if (vmspath_len >= 6) {
6960             strcpy(vmspath, "_NLA0:");
6961             return SS$_NORMAL;
6962         }
6963     }
6964 }
6965
6966
6967 /* The built in routines do not understand perl's special needs, so
6968     doing a manual conversion from UNIX to VMS
6969
6970     If the utf8_fl is not null and points to a non-zero value, then
6971     treat 8 bit characters as UTF-8.
6972
6973     The sequence starting with '$(' and ending with ')' will be passed
6974     through with out interpretation instead of being escaped.
6975
6976   */
6977 static int posix_to_vmsspec_hardway
6978   (char *vmspath, int vmspath_len,
6979    const char *unixpath,
6980    int dir_flag,
6981    int * utf8_fl) {
6982
6983 char *esa;
6984 const char *unixptr;
6985 const char *unixend;
6986 char *vmsptr;
6987 const char *lastslash;
6988 const char *lastdot;
6989 int unixlen;
6990 int vmslen;
6991 int dir_start;
6992 int dir_dot;
6993 int quoted;
6994 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6995 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6996
6997   if (utf8_fl != NULL)
6998     *utf8_fl = 0;
6999
7000   unixptr = unixpath;
7001   dir_dot = 0;
7002
7003   /* Ignore leading "/" characters */
7004   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7005     unixptr++;
7006   }
7007   unixlen = strlen(unixptr);
7008
7009   /* Do nothing with blank paths */
7010   if (unixlen == 0) {
7011     vmspath[0] = '\0';
7012     return SS$_NORMAL;
7013   }
7014
7015   quoted = 0;
7016   /* This could have a "^UP^ on the front */
7017   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7018     quoted = 1;
7019     unixptr+= 5;
7020     unixlen-= 5;
7021   }
7022
7023   lastslash = strrchr(unixptr,'/');
7024   lastdot = strrchr(unixptr,'.');
7025   unixend = strrchr(unixptr,'\"');
7026   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7027     unixend = unixptr + unixlen;
7028   }
7029
7030   /* last dot is last dot or past end of string */
7031   if (lastdot == NULL)
7032     lastdot = unixptr + unixlen;
7033
7034   /* if no directories, set last slash to beginning of string */
7035   if (lastslash == NULL) {
7036     lastslash = unixptr;
7037   }
7038   else {
7039     /* Watch out for trailing "." after last slash, still a directory */
7040     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7041       lastslash = unixptr + unixlen;
7042     }
7043
7044     /* Watch out for traiing ".." after last slash, still a directory */
7045     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7046       lastslash = unixptr + unixlen;
7047     }
7048
7049     /* dots in directories are aways escaped */
7050     if (lastdot < lastslash)
7051       lastdot = unixptr + unixlen;
7052   }
7053
7054   /* if (unixptr < lastslash) then we are in a directory */
7055
7056   dir_start = 0;
7057
7058   vmsptr = vmspath;
7059   vmslen = 0;
7060
7061   /* Start with the UNIX path */
7062   if (*unixptr != '/') {
7063     /* relative paths */
7064
7065     /* If allowing logical names on relative pathnames, then handle here */
7066     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7067         !decc_posix_compliant_pathnames) {
7068     char * nextslash;
7069     int seg_len;
7070     char * trn;
7071     int islnm;
7072
7073         /* Find the next slash */
7074         nextslash = strchr(unixptr,'/');
7075
7076         esa = PerlMem_malloc(vmspath_len);
7077         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7078
7079         trn = PerlMem_malloc(VMS_MAXRSS);
7080         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7081
7082         if (nextslash != NULL) {
7083
7084             seg_len = nextslash - unixptr;
7085             strncpy(esa, unixptr, seg_len);
7086             esa[seg_len] = 0;
7087         }
7088         else {
7089             strcpy(esa, unixptr);
7090             seg_len = strlen(unixptr);
7091         }
7092         /* trnlnm(section) */
7093         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7094
7095         if (islnm) {
7096             /* Now fix up the directory */
7097
7098             /* Split up the path to find the components */
7099             sts = vms_split_path
7100                   (trn,
7101                    &v_spec,
7102                    &v_len,
7103                    &r_spec,
7104                    &r_len,
7105                    &d_spec,
7106                    &d_len,
7107                    &n_spec,
7108                    &n_len,
7109                    &e_spec,
7110                    &e_len,
7111                    &vs_spec,
7112                    &vs_len);
7113
7114             while (sts == 0) {
7115             char * strt;
7116             int cmp;
7117
7118                 /* A logical name must be a directory  or the full
7119                    specification.  It is only a full specification if
7120                    it is the only component */
7121                 if ((unixptr[seg_len] == '\0') ||
7122                     (unixptr[seg_len+1] == '\0')) {
7123
7124                     /* Is a directory being required? */
7125                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7126                         /* Not a logical name */
7127                         break;
7128                     }
7129
7130
7131                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7132                         /* This must be a directory */
7133                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7134                             strcpy(vmsptr, esa);
7135                             vmslen=strlen(vmsptr);
7136                             vmsptr[vmslen] = ':';
7137                             vmslen++;
7138                             vmsptr[vmslen] = '\0';
7139                             return SS$_NORMAL;
7140                         }
7141                     }
7142
7143                 }
7144
7145
7146                 /* must be dev/directory - ignore version */
7147                 if ((n_len + e_len) != 0)
7148                     break;
7149
7150                 /* transfer the volume */
7151                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7152                     strncpy(vmsptr, v_spec, v_len);
7153                     vmsptr += v_len;
7154                     vmsptr[0] = '\0';
7155                     vmslen += v_len;
7156                 }
7157
7158                 /* unroot the rooted directory */
7159                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7160                     r_spec[0] = '[';
7161                     r_spec[r_len - 1] = ']';
7162
7163                     /* This should not be there, but nothing is perfect */
7164                     if (r_len > 9) {
7165                         cmp = strcmp(&r_spec[1], "000000.");
7166                         if (cmp == 0) {
7167                             r_spec += 7;
7168                             r_spec[7] = '[';
7169                             r_len -= 7;
7170                             if (r_len == 2)
7171                                 r_len = 0;
7172                         }
7173                     }
7174                     if (r_len > 0) {
7175                         strncpy(vmsptr, r_spec, r_len);
7176                         vmsptr += r_len;
7177                         vmslen += r_len;
7178                         vmsptr[0] = '\0';
7179                     }
7180                 }
7181                 /* Bring over the directory. */
7182                 if ((d_len > 0) &&
7183                     ((d_len + vmslen) < vmspath_len)) {
7184                     d_spec[0] = '[';
7185                     d_spec[d_len - 1] = ']';
7186                     if (d_len > 9) {
7187                         cmp = strcmp(&d_spec[1], "000000.");
7188                         if (cmp == 0) {
7189                             d_spec += 7;
7190                             d_spec[7] = '[';
7191                             d_len -= 7;
7192                             if (d_len == 2)
7193                                 d_len = 0;
7194                         }
7195                     }
7196
7197                     if (r_len > 0) {
7198                         /* Remove the redundant root */
7199                         if (r_len > 0) {
7200                             /* remove the ][ */
7201                             vmsptr--;
7202                             vmslen--;
7203                             d_spec++;
7204                             d_len--;
7205                         }
7206                         strncpy(vmsptr, d_spec, d_len);
7207                             vmsptr += d_len;
7208                             vmslen += d_len;
7209                             vmsptr[0] = '\0';
7210                     }
7211                 }
7212                 break;
7213             }
7214         }
7215
7216         PerlMem_free(esa);
7217         PerlMem_free(trn);
7218     }
7219
7220     if (lastslash > unixptr) {
7221     int dotdir_seen;
7222
7223       /* skip leading ./ */
7224       dotdir_seen = 0;
7225       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7226         dotdir_seen = 1;
7227         unixptr++;
7228         unixptr++;
7229       }
7230
7231       /* Are we still in a directory? */
7232       if (unixptr <= lastslash) {
7233         *vmsptr++ = '[';
7234         vmslen = 1;
7235         dir_start = 1;
7236
7237         /* if not backing up, then it is relative forward. */
7238         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7239               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7240           *vmsptr++ = '.';
7241           vmslen++;
7242           dir_dot = 1;
7243           }
7244        }
7245        else {
7246          if (dotdir_seen) {
7247            /* Perl wants an empty directory here to tell the difference
7248             * between a DCL commmand and a filename
7249             */
7250           *vmsptr++ = '[';
7251           *vmsptr++ = ']';
7252           vmslen = 2;
7253         }
7254       }
7255     }
7256     else {
7257       /* Handle two special files . and .. */
7258       if (unixptr[0] == '.') {
7259         if (&unixptr[1] == unixend) {
7260           *vmsptr++ = '[';
7261           *vmsptr++ = ']';
7262           vmslen += 2;
7263           *vmsptr++ = '\0';
7264           return SS$_NORMAL;
7265         }
7266         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7267           *vmsptr++ = '[';
7268           *vmsptr++ = '-';
7269           *vmsptr++ = ']';
7270           vmslen += 3;
7271           *vmsptr++ = '\0';
7272           return SS$_NORMAL;
7273         }
7274       }
7275     }
7276   }
7277   else {        /* Absolute PATH handling */
7278   int sts;
7279   char * nextslash;
7280   int seg_len;
7281     /* Need to find out where root is */
7282
7283     /* In theory, this procedure should never get an absolute POSIX pathname
7284      * that can not be found on the POSIX root.
7285      * In practice, that can not be relied on, and things will show up
7286      * here that are a VMS device name or concealed logical name instead.
7287      * So to make things work, this procedure must be tolerant.
7288      */
7289     esa = PerlMem_malloc(vmspath_len);
7290     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7291
7292     sts = SS$_NORMAL;
7293     nextslash = strchr(&unixptr[1],'/');
7294     seg_len = 0;
7295     if (nextslash != NULL) {
7296     int cmp;
7297       seg_len = nextslash - &unixptr[1];
7298       strncpy(vmspath, unixptr, seg_len + 1);
7299       vmspath[seg_len+1] = 0;
7300       cmp = 1;
7301       if (seg_len == 3) {
7302         cmp = strncmp(vmspath, "dev", 4);
7303         if (cmp == 0) {
7304             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7305             if (sts = SS$_NORMAL)
7306                 return SS$_NORMAL;
7307         }
7308       }
7309       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
7310     }
7311
7312     if ($VMS_STATUS_SUCCESS(sts)) {
7313       /* This is verified to be a real path */
7314
7315       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7316       if ($VMS_STATUS_SUCCESS(sts)) {
7317         strcpy(vmspath, esa);
7318         vmslen = strlen(vmspath);
7319         vmsptr = vmspath + vmslen;
7320         unixptr++;
7321         if (unixptr < lastslash) {
7322         char * rptr;
7323           vmsptr--;
7324           *vmsptr++ = '.';
7325           dir_start = 1;
7326           dir_dot = 1;
7327           if (vmslen > 7) {
7328           int cmp;
7329             rptr = vmsptr - 7;
7330             cmp = strcmp(rptr,"000000.");
7331             if (cmp == 0) {
7332               vmslen -= 7;
7333               vmsptr -= 7;
7334               vmsptr[1] = '\0';
7335             } /* removing 6 zeros */
7336           } /* vmslen < 7, no 6 zeros possible */
7337         } /* Not in a directory */
7338       } /* Posix root found */
7339       else {
7340         /* No posix root, fall back to default directory */
7341         strcpy(vmspath, "SYS$DISK:[");
7342         vmsptr = &vmspath[10];
7343         vmslen = 10;
7344         if (unixptr > lastslash) {
7345            *vmsptr = ']';
7346            vmsptr++;
7347            vmslen++;
7348         }
7349         else {
7350            dir_start = 1;
7351         }
7352       }
7353     } /* end of verified real path handling */
7354     else {
7355     int add_6zero;
7356     int islnm;
7357
7358       /* Ok, we have a device or a concealed root that is not in POSIX
7359        * or we have garbage.  Make the best of it.
7360        */
7361
7362       /* Posix to VMS destroyed this, so copy it again */
7363       strncpy(vmspath, &unixptr[1], seg_len);
7364       vmspath[seg_len] = 0;
7365       vmslen = seg_len;
7366       vmsptr = &vmsptr[vmslen];
7367       islnm = 0;
7368
7369       /* Now do we need to add the fake 6 zero directory to it? */
7370       add_6zero = 1;
7371       if ((*lastslash == '/') && (nextslash < lastslash)) {
7372         /* No there is another directory */
7373         add_6zero = 0;
7374       }
7375       else {
7376       int trnend;
7377       int cmp;
7378
7379         /* now we have foo:bar or foo:[000000]bar to decide from */
7380         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
7381
7382         if (!islnm && !decc_posix_compliant_pathnames) {
7383
7384             cmp = strncmp("bin", vmspath, 4);
7385             if (cmp == 0) {
7386                 /* bin => SYS$SYSTEM: */
7387                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7388             }
7389             else {
7390                 /* tmp => SYS$SCRATCH: */
7391                 cmp = strncmp("tmp", vmspath, 4);
7392                 if (cmp == 0) {
7393                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
7394                 }
7395             }
7396         }
7397
7398         trnend = islnm ? islnm - 1 : 0;
7399
7400         /* if this was a logical name, ']' or '>' must be present */
7401         /* if not a logical name, then assume a device and hope. */
7402         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
7403
7404         /* if log name and trailing '.' then rooted - treat as device */
7405         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
7406
7407         /* Fix me, if not a logical name, a device lookup should be
7408          * done to see if the device is file structured.  If the device
7409          * is not file structured, the 6 zeros should not be put on.
7410          *
7411          * As it is, perl is occasionally looking for dev:[000000]tty.
7412          * which looks a little strange.
7413          *
7414          * Not that easy to detect as "/dev" may be file structured with
7415          * special device files.
7416          */
7417
7418         if ((add_6zero == 0) && (*nextslash == '/') &&
7419             (&nextslash[1] == unixend)) {
7420           /* No real directory present */
7421           add_6zero = 1;
7422         }
7423       }
7424
7425       /* Put the device delimiter on */
7426       *vmsptr++ = ':';
7427       vmslen++;
7428       unixptr = nextslash;
7429       unixptr++;
7430
7431       /* Start directory if needed */
7432       if (!islnm || add_6zero) {
7433         *vmsptr++ = '[';
7434         vmslen++;
7435         dir_start = 1;
7436       }
7437
7438       /* add fake 000000] if needed */
7439       if (add_6zero) {
7440         *vmsptr++ = '0';
7441         *vmsptr++ = '0';
7442         *vmsptr++ = '0';
7443         *vmsptr++ = '0';
7444         *vmsptr++ = '0';
7445         *vmsptr++ = '0';
7446         *vmsptr++ = ']';
7447         vmslen += 7;
7448         dir_start = 0;
7449       }
7450
7451     } /* non-POSIX translation */
7452     PerlMem_free(esa);
7453   } /* End of relative/absolute path handling */
7454
7455   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
7456   int dash_flag;
7457   int in_cnt;
7458   int out_cnt;
7459
7460     dash_flag = 0;
7461
7462     if (dir_start != 0) {
7463
7464       /* First characters in a directory are handled special */
7465       while ((*unixptr == '/') ||
7466              ((*unixptr == '.') &&
7467               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
7468                 (&unixptr[1]==unixend)))) {
7469       int loop_flag;
7470
7471         loop_flag = 0;
7472
7473         /* Skip redundant / in specification */
7474         while ((*unixptr == '/') && (dir_start != 0)) {
7475           loop_flag = 1;
7476           unixptr++;
7477           if (unixptr == lastslash)
7478             break;
7479         }
7480         if (unixptr == lastslash)
7481           break;
7482
7483         /* Skip redundant ./ characters */
7484         while ((*unixptr == '.') &&
7485                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
7486           loop_flag = 1;
7487           unixptr++;
7488           if (unixptr == lastslash)
7489             break;
7490           if (*unixptr == '/')
7491             unixptr++;
7492         }
7493         if (unixptr == lastslash)
7494           break;
7495
7496         /* Skip redundant ../ characters */
7497         while ((*unixptr == '.') && (unixptr[1] == '.') &&
7498              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
7499           /* Set the backing up flag */
7500           loop_flag = 1;
7501           dir_dot = 0;
7502           dash_flag = 1;
7503           *vmsptr++ = '-';
7504           vmslen++;
7505           unixptr++; /* first . */
7506           unixptr++; /* second . */
7507           if (unixptr == lastslash)
7508             break;
7509           if (*unixptr == '/') /* The slash */
7510             unixptr++;
7511         }
7512         if (unixptr == lastslash)
7513           break;
7514
7515         /* To do: Perl expects /.../ to be translated to [...] on VMS */
7516         /* Not needed when VMS is pretending to be UNIX. */
7517
7518         /* Is this loop stuck because of too many dots? */
7519         if (loop_flag == 0) {
7520           /* Exit the loop and pass the rest through */
7521           break;
7522         }
7523       }
7524
7525       /* Are we done with directories yet? */
7526       if (unixptr >= lastslash) {
7527
7528         /* Watch out for trailing dots */
7529         if (dir_dot != 0) {
7530             vmslen --;
7531             vmsptr--;
7532         }
7533         *vmsptr++ = ']';
7534         vmslen++;
7535         dash_flag = 0;
7536         dir_start = 0;
7537         if (*unixptr == '/')
7538           unixptr++;
7539       }
7540       else {
7541         /* Have we stopped backing up? */
7542         if (dash_flag) {
7543           *vmsptr++ = '.';
7544           vmslen++;
7545           dash_flag = 0;
7546           /* dir_start continues to be = 1 */
7547         }
7548         if (*unixptr == '-') {
7549           *vmsptr++ = '^';
7550           *vmsptr++ = *unixptr++;
7551           vmslen += 2;
7552           dir_start = 0;
7553
7554           /* Now are we done with directories yet? */
7555           if (unixptr >= lastslash) {
7556
7557             /* Watch out for trailing dots */
7558             if (dir_dot != 0) {
7559               vmslen --;
7560               vmsptr--;
7561             }
7562
7563             *vmsptr++ = ']';
7564             vmslen++;
7565             dash_flag = 0;
7566             dir_start = 0;
7567           }
7568         }
7569       }
7570     }
7571
7572     /* All done? */
7573     if (unixptr >= unixend)
7574       break;
7575
7576     /* Normal characters - More EFS work probably needed */
7577     dir_start = 0;
7578     dir_dot = 0;
7579
7580     switch(*unixptr) {
7581     case '/':
7582         /* remove multiple / */
7583         while (unixptr[1] == '/') {
7584            unixptr++;
7585         }
7586         if (unixptr == lastslash) {
7587           /* Watch out for trailing dots */
7588           if (dir_dot != 0) {
7589             vmslen --;
7590             vmsptr--;
7591           }
7592           *vmsptr++ = ']';
7593         }
7594         else {
7595           dir_start = 1;
7596           *vmsptr++ = '.';
7597           dir_dot = 1;
7598
7599           /* To do: Perl expects /.../ to be translated to [...] on VMS */
7600           /* Not needed when VMS is pretending to be UNIX. */
7601
7602         }
7603         dash_flag = 0;
7604         if (unixptr != unixend)
7605           unixptr++;
7606         vmslen++;
7607         break;
7608     case '.':
7609         if ((unixptr < lastdot) || (unixptr < lastslash) ||
7610             (&unixptr[1] == unixend)) {
7611           *vmsptr++ = '^';
7612           *vmsptr++ = '.';
7613           vmslen += 2;
7614           unixptr++;
7615
7616           /* trailing dot ==> '^..' on VMS */
7617           if (unixptr == unixend) {
7618             *vmsptr++ = '.';
7619             vmslen++;
7620             unixptr++;
7621           }
7622           break;
7623         }
7624
7625         *vmsptr++ = *unixptr++;
7626         vmslen ++;
7627         break;
7628     case '"':
7629         if (quoted && (&unixptr[1] == unixend)) {
7630             unixptr++;
7631             break;
7632         }
7633         in_cnt = copy_expand_unix_filename_escape
7634                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7635         vmsptr += out_cnt;
7636         unixptr += in_cnt;
7637         break;
7638     case '~':
7639     case ';':
7640     case '\\':
7641     case '?':
7642     case ' ':
7643     default:
7644         in_cnt = copy_expand_unix_filename_escape
7645                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7646         vmsptr += out_cnt;
7647         unixptr += in_cnt;
7648         break;
7649     }
7650   }
7651
7652   /* Make sure directory is closed */
7653   if (unixptr == lastslash) {
7654     char *vmsptr2;
7655     vmsptr2 = vmsptr - 1;
7656
7657     if (*vmsptr2 != ']') {
7658       *vmsptr2--;
7659
7660       /* directories do not end in a dot bracket */
7661       if (*vmsptr2 == '.') {
7662         vmsptr2--;
7663
7664         /* ^. is allowed */
7665         if (*vmsptr2 != '^') {
7666           vmsptr--; /* back up over the dot */
7667         }
7668       }
7669       *vmsptr++ = ']';
7670     }
7671   }
7672   else {
7673     char *vmsptr2;
7674     /* Add a trailing dot if a file with no extension */
7675     vmsptr2 = vmsptr - 1;
7676     if ((vmslen > 1) &&
7677         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
7678         (*vmsptr2 != ')') && (*lastdot != '.')) {
7679         *vmsptr++ = '.';
7680         vmslen++;
7681     }
7682   }
7683
7684   *vmsptr = '\0';
7685   return SS$_NORMAL;
7686 }
7687 #endif
7688
7689  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
7690 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
7691 {
7692 char * result;
7693 int utf8_flag;
7694
7695    /* If a UTF8 flag is being passed, honor it */
7696    utf8_flag = 0;
7697    if (utf8_fl != NULL) {
7698      utf8_flag = *utf8_fl;
7699     *utf8_fl = 0;
7700    }
7701
7702    if (utf8_flag) {
7703      /* If there is a possibility of UTF8, then if any UTF8 characters
7704         are present, then they must be converted to VTF-7
7705       */
7706      result = strcpy(rslt, path); /* FIX-ME */
7707    }
7708    else
7709      result = strcpy(rslt, path);
7710
7711    return result;
7712 }
7713
7714
7715 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
7716 static char *mp_do_tovmsspec
7717    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
7718   static char __tovmsspec_retbuf[VMS_MAXRSS];
7719   char *rslt, *dirend;
7720   char *lastdot;
7721   char *vms_delim;
7722   register char *cp1;
7723   const char *cp2;
7724   unsigned long int infront = 0, hasdir = 1;
7725   int rslt_len;
7726   int no_type_seen;
7727   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7728   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7729
7730   if (path == NULL) return NULL;
7731   rslt_len = VMS_MAXRSS-1;
7732   if (buf) rslt = buf;
7733   else if (ts) Newx(rslt, VMS_MAXRSS, char);
7734   else rslt = __tovmsspec_retbuf;
7735
7736   /* '.' and '..' are "[]" and "[-]" for a quick check */
7737   if (path[0] == '.') {
7738     if (path[1] == '\0') {
7739       strcpy(rslt,"[]");
7740       if (utf8_flag != NULL)
7741         *utf8_flag = 0;
7742       return rslt;
7743     }
7744     else {
7745       if (path[1] == '.' && path[2] == '\0') {
7746         strcpy(rslt,"[-]");
7747         if (utf8_flag != NULL)
7748            *utf8_flag = 0;
7749         return rslt;
7750       }
7751     }
7752   }
7753
7754    /* Posix specifications are now a native VMS format */
7755   /*--------------------------------------------------*/
7756 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7757   if (decc_posix_compliant_pathnames) {
7758     if (strncmp(path,"\"^UP^",5) == 0) {
7759       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7760       return rslt;
7761     }
7762   }
7763 #endif
7764
7765   /* This is really the only way to see if this is already in VMS format */
7766   sts = vms_split_path
7767        (path,
7768         &v_spec,
7769         &v_len,
7770         &r_spec,
7771         &r_len,
7772         &d_spec,
7773         &d_len,
7774         &n_spec,
7775         &n_len,
7776         &e_spec,
7777         &e_len,
7778         &vs_spec,
7779         &vs_len);
7780   if (sts == 0) {
7781     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
7782        replacement, because the above parse just took care of most of
7783        what is needed to do vmspath when the specification is already
7784        in VMS format.
7785
7786        And if it is not already, it is easier to do the conversion as
7787        part of this routine than to call this routine and then work on
7788        the result.
7789      */
7790
7791     /* If VMS punctuation was found, it is already VMS format */
7792     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
7793       if (utf8_flag != NULL)
7794         *utf8_flag = 0;
7795       strcpy(rslt, path);
7796       return rslt;
7797     }
7798     /* Now, what to do with trailing "." cases where there is no
7799        extension?  If this is a UNIX specification, and EFS characters
7800        are enabled, then the trailing "." should be converted to a "^.".
7801        But if this was already a VMS specification, then it should be
7802        left alone.
7803
7804        So in the case of ambiguity, leave the specification alone.
7805      */
7806
7807
7808     /* If there is a possibility of UTF8, then if any UTF8 characters
7809         are present, then they must be converted to VTF-7
7810      */
7811     if (utf8_flag != NULL)
7812       *utf8_flag = 0;
7813     strcpy(rslt, path);
7814     return rslt;
7815   }
7816
7817   dirend = strrchr(path,'/');
7818
7819   if (dirend == NULL) {
7820      /* If we get here with no UNIX directory delimiters, then this is
7821         not a complete file specification, either garbage a UNIX glob
7822         specification that can not be converted to a VMS wildcard, or
7823         it a UNIX shell macro.  MakeMaker wants these passed through AS-IS,
7824         so apparently other programs expect this also.
7825
7826         utf8 flag setting needs to be preserved.
7827       */
7828       strcpy(rslt, path);
7829       return rslt;
7830   }
7831
7832 /* If POSIX mode active, handle the conversion */
7833 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7834   if (decc_efs_charset) {
7835     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7836     return rslt;
7837   }
7838 #endif
7839
7840   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
7841     if (!*(dirend+2)) dirend +=2;
7842     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7843     if (decc_efs_charset == 0) {
7844       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7845     }
7846   }
7847
7848   cp1 = rslt;
7849   cp2 = path;
7850   lastdot = strrchr(cp2,'.');
7851   if (*cp2 == '/') {
7852     char *trndev;
7853     int islnm, rooted;
7854     STRLEN trnend;
7855
7856     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7857     if (!*(cp2+1)) {
7858       if (decc_disable_posix_root) {
7859         strcpy(rslt,"sys$disk:[000000]");
7860       }
7861       else {
7862         strcpy(rslt,"sys$posix_root:[000000]");
7863       }
7864       if (utf8_flag != NULL)
7865         *utf8_flag = 0;
7866       return rslt;
7867     }
7868     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7869     *cp1 = '\0';
7870     trndev = PerlMem_malloc(VMS_MAXRSS);
7871     if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7872     islnm =  my_trnlnm(rslt,trndev,0);
7873
7874      /* DECC special handling */
7875     if (!islnm) {
7876       if (strcmp(rslt,"bin") == 0) {
7877         strcpy(rslt,"sys$system");
7878         cp1 = rslt + 10;
7879         *cp1 = 0;
7880         islnm =  my_trnlnm(rslt,trndev,0);
7881       }
7882       else if (strcmp(rslt,"tmp") == 0) {
7883         strcpy(rslt,"sys$scratch");
7884         cp1 = rslt + 11;
7885         *cp1 = 0;
7886         islnm =  my_trnlnm(rslt,trndev,0);
7887       }
7888       else if (!decc_disable_posix_root) {
7889         strcpy(rslt, "sys$posix_root");
7890         cp1 = rslt + 13;
7891         *cp1 = 0;
7892         cp2 = path;
7893         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7894         islnm =  my_trnlnm(rslt,trndev,0);
7895       }
7896       else if (strcmp(rslt,"dev") == 0) {
7897         if (strncmp(cp2,"/null", 5) == 0) {
7898           if ((cp2[5] == 0) || (cp2[5] == '/')) {
7899             strcpy(rslt,"NLA0");
7900             cp1 = rslt + 4;
7901             *cp1 = 0;
7902             cp2 = cp2 + 5;
7903             islnm =  my_trnlnm(rslt,trndev,0);
7904           }
7905         }
7906       }
7907     }
7908
7909     trnend = islnm ? strlen(trndev) - 1 : 0;
7910     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
7911     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
7912     /* If the first element of the path is a logical name, determine
7913      * whether it has to be translated so we can add more directories. */
7914     if (!islnm || rooted) {
7915       *(cp1++) = ':';
7916       *(cp1++) = '[';
7917       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
7918       else cp2++;
7919     }
7920     else {
7921       if (cp2 != dirend) {
7922         strcpy(rslt,trndev);
7923         cp1 = rslt + trnend;
7924         if (*cp2 != 0) {
7925           *(cp1++) = '.';
7926           cp2++;
7927         }
7928       }
7929       else {
7930         if (decc_disable_posix_root) {
7931           *(cp1++) = ':';
7932           hasdir = 0;
7933         }
7934       }
7935     }
7936     PerlMem_free(trndev);
7937   }
7938   else {
7939     *(cp1++) = '[';
7940     if (*cp2 == '.') {
7941       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
7942         cp2 += 2;         /* skip over "./" - it's redundant */
7943         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
7944       }
7945       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7946         *(cp1++) = '-';                                 /* "../" --> "-" */
7947         cp2 += 3;
7948       }
7949       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
7950                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
7951         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7952         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
7953         cp2 += 4;
7954       }
7955       else if ((cp2 != lastdot) || (lastdot < dirend)) {
7956         /* Escape the extra dots in EFS file specifications */
7957         *(cp1++) = '^';
7958       }
7959       if (cp2 > dirend) cp2 = dirend;
7960     }
7961     else *(cp1++) = '.';
7962   }
7963   for (; cp2 < dirend; cp2++) {
7964     if (*cp2 == '/') {
7965       if (*(cp2-1) == '/') continue;
7966       if (*(cp1-1) != '.') *(cp1++) = '.';
7967       infront = 0;
7968     }
7969     else if (!infront && *cp2 == '.') {
7970       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
7971       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
7972       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7973         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
7974         else if (*(cp1-2) == '[') *(cp1-1) = '-';
7975         else {  /* back up over previous directory name */
7976           cp1--;
7977           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
7978           if (*(cp1-1) == '[') {
7979             memcpy(cp1,"000000.",7);
7980             cp1 += 7;
7981           }
7982         }
7983         cp2 += 2;
7984         if (cp2 == dirend) break;
7985       }
7986       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
7987                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
7988         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
7989         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7990         if (!*(cp2+3)) {
7991           *(cp1++) = '.';  /* Simulate trailing '/' */
7992           cp2 += 2;  /* for loop will incr this to == dirend */
7993         }
7994         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
7995       }
7996       else {
7997         if (decc_efs_charset == 0)
7998           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
7999         else {
8000           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
8001           *(cp1++) = '.';
8002         }
8003       }
8004     }
8005     else {
8006       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
8007       if (*cp2 == '.') {
8008         if (decc_efs_charset == 0)
8009           *(cp1++) = '_';
8010         else {
8011           *(cp1++) = '^';
8012           *(cp1++) = '.';
8013         }
8014       }
8015       else                  *(cp1++) =  *cp2;
8016       infront = 1;
8017     }
8018   }
8019   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8020   if (hasdir) *(cp1++) = ']';
8021   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
8022   /* fixme for ODS5 */
8023   no_type_seen = 0;
8024   if (cp2 > lastdot)
8025     no_type_seen = 1;
8026   while (*cp2) {
8027     switch(*cp2) {
8028     case '?':
8029         if (decc_efs_charset == 0)
8030           *(cp1++) = '%';
8031         else
8032           *(cp1++) = '?';
8033         cp2++;
8034     case ' ':
8035         *(cp1)++ = '^';
8036         *(cp1)++ = '_';
8037         cp2++;
8038         break;
8039     case '.':
8040         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8041             decc_readdir_dropdotnotype) {
8042           *(cp1)++ = '^';
8043           *(cp1)++ = '.';
8044           cp2++;
8045
8046           /* trailing dot ==> '^..' on VMS */
8047           if (*cp2 == '\0') {
8048             *(cp1++) = '.';
8049             no_type_seen = 0;
8050           }
8051         }
8052         else {
8053           *(cp1++) = *(cp2++);
8054           no_type_seen = 0;
8055         }
8056         break;
8057     case '$':
8058          /* This could be a macro to be passed through */
8059         *(cp1++) = *(cp2++);
8060         if (*cp2 == '(') {
8061         const char * save_cp2;
8062         char * save_cp1;
8063         int is_macro;
8064
8065             /* paranoid check */
8066             save_cp2 = cp2;
8067             save_cp1 = cp1;
8068             is_macro = 0;
8069
8070             /* Test through */
8071             *(cp1++) = *(cp2++);
8072             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8073                 *(cp1++) = *(cp2++);
8074                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8075                     *(cp1++) = *(cp2++);
8076                 }
8077                 if (*cp2 == ')') {
8078                     *(cp1++) = *(cp2++);
8079                     is_macro = 1;
8080                 }
8081             }
8082             if (is_macro == 0) {
8083                 /* Not really a macro - never mind */
8084                 cp2 = save_cp2;
8085                 cp1 = save_cp1;
8086             }
8087         }
8088         break;
8089     case '\"':
8090     case '~':
8091     case '`':
8092     case '!':
8093     case '#':
8094     case '%':
8095     case '^':
8096         /* Don't escape again if following character is
8097          * already something we escape.
8098          */
8099         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8100             *(cp1++) = *(cp2++);
8101             break;
8102         }
8103         /* But otherwise fall through and escape it. */
8104     case '&':
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         *(cp1++) = '^';
8121         *(cp1++) = *(cp2++);
8122         break;
8123     case ';':
8124         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8125          * which is wrong.  UNIX notation should be ".dir." unless
8126          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8127          * changing this behavior could break more things at this time.
8128          * efs character set effectively does not allow "." to be a version
8129          * delimiter as a further complication about changing this.
8130          */
8131         if (decc_filename_unix_report != 0) {
8132           *(cp1++) = '^';
8133         }
8134         *(cp1++) = *(cp2++);
8135         break;
8136     default:
8137         *(cp1++) = *(cp2++);
8138     }
8139   }
8140   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8141   char *lcp1;
8142     lcp1 = cp1;
8143     lcp1--;
8144      /* Fix me for "^]", but that requires making sure that you do
8145       * not back up past the start of the filename
8146       */
8147     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8148       *cp1++ = '.';
8149   }
8150   *cp1 = '\0';
8151
8152   if (utf8_flag != NULL)
8153     *utf8_flag = 0;
8154   return rslt;
8155
8156 }  /* end of do_tovmsspec() */
8157 /*}}}*/
8158 /* External entry points */
8159 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8160   { return do_tovmsspec(path,buf,0,NULL); }
8161 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8162   { return do_tovmsspec(path,buf,1,NULL); }
8163 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8164   { return do_tovmsspec(path,buf,0,utf8_fl); }
8165 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8166   { return do_tovmsspec(path,buf,1,utf8_fl); }
8167
8168 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8169 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8170   static char __tovmspath_retbuf[VMS_MAXRSS];
8171   int vmslen;
8172   char *pathified, *vmsified, *cp;
8173
8174   if (path == NULL) return NULL;
8175   pathified = PerlMem_malloc(VMS_MAXRSS);
8176   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8177   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
8178     PerlMem_free(pathified);
8179     return NULL;
8180   }
8181
8182   vmsified = NULL;
8183   if (buf == NULL)
8184      Newx(vmsified, VMS_MAXRSS, char);
8185   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8186     PerlMem_free(pathified);
8187     if (vmsified) Safefree(vmsified);
8188     return NULL;
8189   }
8190   PerlMem_free(pathified);
8191   if (buf) {
8192     return buf;
8193   }
8194   else if (ts) {
8195     vmslen = strlen(vmsified);
8196     Newx(cp,vmslen+1,char);
8197     memcpy(cp,vmsified,vmslen);
8198     cp[vmslen] = '\0';
8199     Safefree(vmsified);
8200     return cp;
8201   }
8202   else {
8203     strcpy(__tovmspath_retbuf,vmsified);
8204     Safefree(vmsified);
8205     return __tovmspath_retbuf;
8206   }
8207
8208 }  /* end of do_tovmspath() */
8209 /*}}}*/
8210 /* External entry points */
8211 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8212   { return do_tovmspath(path,buf,0, NULL); }
8213 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8214   { return do_tovmspath(path,buf,1, NULL); }
8215 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8216   { return do_tovmspath(path,buf,0,utf8_fl); }
8217 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8218   { return do_tovmspath(path,buf,1,utf8_fl); }
8219
8220
8221 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8222 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8223   static char __tounixpath_retbuf[VMS_MAXRSS];
8224   int unixlen;
8225   char *pathified, *unixified, *cp;
8226
8227   if (path == NULL) return NULL;
8228   pathified = PerlMem_malloc(VMS_MAXRSS);
8229   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8230   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
8231     PerlMem_free(pathified);
8232     return NULL;
8233   }
8234
8235   unixified = NULL;
8236   if (buf == NULL) {
8237       Newx(unixified, VMS_MAXRSS, char);
8238   }
8239   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
8240     PerlMem_free(pathified);
8241     if (unixified) Safefree(unixified);
8242     return NULL;
8243   }
8244   PerlMem_free(pathified);
8245   if (buf) {
8246     return buf;
8247   }
8248   else if (ts) {
8249     unixlen = strlen(unixified);
8250     Newx(cp,unixlen+1,char);
8251     memcpy(cp,unixified,unixlen);
8252     cp[unixlen] = '\0';
8253     Safefree(unixified);
8254     return cp;
8255   }
8256   else {
8257     strcpy(__tounixpath_retbuf,unixified);
8258     Safefree(unixified);
8259     return __tounixpath_retbuf;
8260   }
8261
8262 }  /* end of do_tounixpath() */
8263 /*}}}*/
8264 /* External entry points */
8265 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8266   { return do_tounixpath(path,buf,0,NULL); }
8267 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8268   { return do_tounixpath(path,buf,1,NULL); }
8269 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8270   { return do_tounixpath(path,buf,0,utf8_fl); }
8271 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8272   { return do_tounixpath(path,buf,1,utf8_fl); }
8273
8274 /*
8275  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
8276  *
8277  *****************************************************************************
8278  *                                                                           *
8279  *  Copyright (C) 1989-1994, 2007 by                                         *
8280  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
8281  *                                                                           *
8282  *  Permission is hereby granted for the reproduction of this software       *
8283  *  on condition that this copyright notice is included in source            *
8284  *  distributions of the software.  The code may be modified and             *
8285  *  distributed under the same terms as Perl itself.                         *
8286  *                                                                           *
8287  *  27-Aug-1994 Modified for inclusion in perl5                              *
8288  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
8289  *****************************************************************************
8290  */
8291
8292 /*
8293  * getredirection() is intended to aid in porting C programs
8294  * to VMS (Vax-11 C).  The native VMS environment does not support
8295  * '>' and '<' I/O redirection, or command line wild card expansion,
8296  * or a command line pipe mechanism using the '|' AND background
8297  * command execution '&'.  All of these capabilities are provided to any
8298  * C program which calls this procedure as the first thing in the
8299  * main program.
8300  * The piping mechanism will probably work with almost any 'filter' type
8301  * of program.  With suitable modification, it may useful for other
8302  * portability problems as well.
8303  *
8304  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
8305  */
8306 struct list_item
8307     {
8308     struct list_item *next;
8309     char *value;
8310     };
8311
8312 static void add_item(struct list_item **head,
8313                      struct list_item **tail,
8314                      char *value,
8315                      int *count);
8316
8317 static void mp_expand_wild_cards(pTHX_ char *item,
8318                                 struct list_item **head,
8319                                 struct list_item **tail,
8320                                 int *count);
8321
8322 static int background_process(pTHX_ int argc, char **argv);
8323
8324 static void pipe_and_fork(pTHX_ char **cmargv);
8325
8326 /*{{{ void getredirection(int *ac, char ***av)*/
8327 static void
8328 mp_getredirection(pTHX_ int *ac, char ***av)
8329 /*
8330  * Process vms redirection arg's.  Exit if any error is seen.
8331  * If getredirection() processes an argument, it is erased
8332  * from the vector.  getredirection() returns a new argc and argv value.
8333  * In the event that a background command is requested (by a trailing "&"),
8334  * this routine creates a background subprocess, and simply exits the program.
8335  *
8336  * Warning: do not try to simplify the code for vms.  The code
8337  * presupposes that getredirection() is called before any data is
8338  * read from stdin or written to stdout.
8339  *
8340  * Normal usage is as follows:
8341  *
8342  *      main(argc, argv)
8343  *      int             argc;
8344  *      char            *argv[];
8345  *      {
8346  *              getredirection(&argc, &argv);
8347  *      }
8348  */
8349 {
8350     int                 argc = *ac;     /* Argument Count         */
8351     char                **argv = *av;   /* Argument Vector        */
8352     char                *ap;            /* Argument pointer       */
8353     int                 j;              /* argv[] index           */
8354     int                 item_count = 0; /* Count of Items in List */
8355     struct list_item    *list_head = 0; /* First Item in List       */
8356     struct list_item    *list_tail;     /* Last Item in List        */
8357     char                *in = NULL;     /* Input File Name          */
8358     char                *out = NULL;    /* Output File Name         */
8359     char                *outmode = "w"; /* Mode to Open Output File */
8360     char                *err = NULL;    /* Error File Name          */
8361     char                *errmode = "w"; /* Mode to Open Error File  */
8362     int                 cmargc = 0;     /* Piped Command Arg Count  */
8363     char                **cmargv = NULL;/* Piped Command Arg Vector */
8364
8365     /*
8366      * First handle the case where the last thing on the line ends with
8367      * a '&'.  This indicates the desire for the command to be run in a
8368      * subprocess, so we satisfy that desire.
8369      */
8370     ap = argv[argc-1];
8371     if (0 == strcmp("&", ap))
8372        exit(background_process(aTHX_ --argc, argv));
8373     if (*ap && '&' == ap[strlen(ap)-1])
8374         {
8375         ap[strlen(ap)-1] = '\0';
8376        exit(background_process(aTHX_ argc, argv));
8377         }
8378     /*
8379      * Now we handle the general redirection cases that involve '>', '>>',
8380      * '<', and pipes '|'.
8381      */
8382     for (j = 0; j < argc; ++j)
8383         {
8384         if (0 == strcmp("<", argv[j]))
8385             {
8386             if (j+1 >= argc)
8387                 {
8388                 fprintf(stderr,"No input file after < on command line");
8389                 exit(LIB$_WRONUMARG);
8390                 }
8391             in = argv[++j];
8392             continue;
8393             }
8394         if ('<' == *(ap = argv[j]))
8395             {
8396             in = 1 + ap;
8397             continue;
8398             }
8399         if (0 == strcmp(">", ap))
8400             {
8401             if (j+1 >= argc)
8402                 {
8403                 fprintf(stderr,"No output file after > on command line");
8404                 exit(LIB$_WRONUMARG);
8405                 }
8406             out = argv[++j];
8407             continue;
8408             }
8409         if ('>' == *ap)
8410             {
8411             if ('>' == ap[1])
8412                 {
8413                 outmode = "a";
8414                 if ('\0' == ap[2])
8415                     out = argv[++j];
8416                 else
8417                     out = 2 + ap;
8418                 }
8419             else
8420                 out = 1 + ap;
8421             if (j >= argc)
8422                 {
8423                 fprintf(stderr,"No output file after > or >> on command line");
8424                 exit(LIB$_WRONUMARG);
8425                 }
8426             continue;
8427             }
8428         if (('2' == *ap) && ('>' == ap[1]))
8429             {
8430             if ('>' == ap[2])
8431                 {
8432                 errmode = "a";
8433                 if ('\0' == ap[3])
8434                     err = argv[++j];
8435                 else
8436                     err = 3 + ap;
8437                 }
8438             else
8439                 if ('\0' == ap[2])
8440                     err = argv[++j];
8441                 else
8442                     err = 2 + ap;
8443             if (j >= argc)
8444                 {
8445                 fprintf(stderr,"No output file after 2> or 2>> on command line");
8446                 exit(LIB$_WRONUMARG);
8447                 }
8448             continue;
8449             }
8450         if (0 == strcmp("|", argv[j]))
8451             {
8452             if (j+1 >= argc)
8453                 {
8454                 fprintf(stderr,"No command into which to pipe on command line");
8455                 exit(LIB$_WRONUMARG);
8456                 }
8457             cmargc = argc-(j+1);
8458             cmargv = &argv[j+1];
8459             argc = j;
8460             continue;
8461             }
8462         if ('|' == *(ap = argv[j]))
8463             {
8464             ++argv[j];
8465             cmargc = argc-j;
8466             cmargv = &argv[j];
8467             argc = j;
8468             continue;
8469             }
8470         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
8471         }
8472     /*
8473      * Allocate and fill in the new argument vector, Some Unix's terminate
8474      * the list with an extra null pointer.
8475      */
8476     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
8477     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8478     *av = argv;
8479     for (j = 0; j < item_count; ++j, list_head = list_head->next)
8480         argv[j] = list_head->value;
8481     *ac = item_count;
8482     if (cmargv != NULL)
8483         {
8484         if (out != NULL)
8485             {
8486             fprintf(stderr,"'|' and '>' may not both be specified on command line");
8487             exit(LIB$_INVARGORD);
8488             }
8489         pipe_and_fork(aTHX_ cmargv);
8490         }
8491
8492     /* Check for input from a pipe (mailbox) */
8493
8494     if (in == NULL && 1 == isapipe(0))
8495         {
8496         char mbxname[L_tmpnam];
8497         long int bufsize;
8498         long int dvi_item = DVI$_DEVBUFSIZ;
8499         $DESCRIPTOR(mbxnam, "");
8500         $DESCRIPTOR(mbxdevnam, "");
8501
8502         /* Input from a pipe, reopen it in binary mode to disable       */
8503         /* carriage control processing.                                 */
8504
8505         fgetname(stdin, mbxname);
8506         mbxnam.dsc$a_pointer = mbxname;
8507         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
8508         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
8509         mbxdevnam.dsc$a_pointer = mbxname;
8510         mbxdevnam.dsc$w_length = sizeof(mbxname);
8511         dvi_item = DVI$_DEVNAM;
8512         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
8513         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
8514         set_errno(0);
8515         set_vaxc_errno(1);
8516         freopen(mbxname, "rb", stdin);
8517         if (errno != 0)
8518             {
8519             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
8520             exit(vaxc$errno);
8521             }
8522         }
8523     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
8524         {
8525         fprintf(stderr,"Can't open input file %s as stdin",in);
8526         exit(vaxc$errno);
8527         }
8528     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
8529         {
8530         fprintf(stderr,"Can't open output file %s as stdout",out);
8531         exit(vaxc$errno);
8532         }
8533         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
8534
8535     if (err != NULL) {
8536         if (strcmp(err,"&1") == 0) {
8537             dup2(fileno(stdout), fileno(stderr));
8538             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
8539         } else {
8540         FILE *tmperr;
8541         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
8542             {
8543             fprintf(stderr,"Can't open error file %s as stderr",err);
8544             exit(vaxc$errno);
8545             }
8546             fclose(tmperr);
8547            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
8548                 {
8549                 exit(vaxc$errno);
8550                 }
8551             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
8552         }
8553         }
8554 #ifdef ARGPROC_DEBUG
8555     PerlIO_printf(Perl_debug_log, "Arglist:\n");
8556     for (j = 0; j < *ac;  ++j)
8557         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
8558 #endif
8559    /* Clear errors we may have hit expanding wildcards, so they don't
8560       show up in Perl's $! later */
8561    set_errno(0); set_vaxc_errno(1);
8562 }  /* end of getredirection() */
8563 /*}}}*/
8564
8565 static void add_item(struct list_item **head,
8566                      struct list_item **tail,
8567                      char *value,
8568                      int *count)
8569 {
8570     if (*head == 0)
8571         {
8572         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8573         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8574         *tail = *head;
8575         }
8576     else {
8577         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8578         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8579         *tail = (*tail)->next;
8580         }
8581     (*tail)->value = value;
8582     ++(*count);
8583 }
8584
8585 static void mp_expand_wild_cards(pTHX_ char *item,
8586                               struct list_item **head,
8587                               struct list_item **tail,
8588                               int *count)
8589 {
8590 int expcount = 0;
8591 unsigned long int context = 0;
8592 int isunix = 0;
8593 int item_len = 0;
8594 char *had_version;
8595 char *had_device;
8596 int had_directory;
8597 char *devdir,*cp;
8598 char *vmsspec;
8599 $DESCRIPTOR(filespec, "");
8600 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
8601 $DESCRIPTOR(resultspec, "");
8602 unsigned long int lff_flags = 0;
8603 int sts;
8604 int rms_sts;
8605
8606 #ifdef VMS_LONGNAME_SUPPORT
8607     lff_flags = LIB$M_FIL_LONG_NAMES;
8608 #endif
8609
8610     for (cp = item; *cp; cp++) {
8611         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
8612         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
8613     }
8614     if (!*cp || isspace(*cp))
8615         {
8616         add_item(head, tail, item, count);
8617         return;
8618         }
8619     else
8620         {
8621      /* "double quoted" wild card expressions pass as is */
8622      /* From DCL that means using e.g.:                  */
8623      /* perl program """perl.*"""                        */
8624      item_len = strlen(item);
8625      if ( '"' == *item && '"' == item[item_len-1] )
8626        {
8627        item++;
8628        item[item_len-2] = '\0';
8629        add_item(head, tail, item, count);
8630        return;
8631        }
8632      }
8633     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
8634     resultspec.dsc$b_class = DSC$K_CLASS_D;
8635     resultspec.dsc$a_pointer = NULL;
8636     vmsspec = PerlMem_malloc(VMS_MAXRSS);
8637     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8638     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
8639       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
8640     if (!isunix || !filespec.dsc$a_pointer)
8641       filespec.dsc$a_pointer = item;
8642     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
8643     /*
8644      * Only return version specs, if the caller specified a version
8645      */
8646     had_version = strchr(item, ';');
8647     /*
8648      * Only return device and directory specs, if the caller specifed either.
8649      */
8650     had_device = strchr(item, ':');
8651     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
8652
8653     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
8654                                  (&filespec, &resultspec, &context,
8655                                   &defaultspec, 0, &rms_sts, &lff_flags)))
8656         {
8657         char *string;
8658         char *c;
8659
8660         string = PerlMem_malloc(resultspec.dsc$w_length+1);
8661         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8662         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
8663         string[resultspec.dsc$w_length] = '\0';
8664         if (NULL == had_version)
8665             *(strrchr(string, ';')) = '\0';
8666         if ((!had_directory) && (had_device == NULL))
8667             {
8668             if (NULL == (devdir = strrchr(string, ']')))
8669                 devdir = strrchr(string, '>');
8670             strcpy(string, devdir + 1);
8671             }
8672         /*
8673          * Be consistent with what the C RTL has already done to the rest of
8674          * the argv items and lowercase all of these names.
8675          */
8676         if (!decc_efs_case_preserve) {
8677             for (c = string; *c; ++c)
8678             if (isupper(*c))
8679                 *c = tolower(*c);
8680         }
8681         if (isunix) trim_unixpath(string,item,1);
8682         add_item(head, tail, string, count);
8683         ++expcount;
8684     }
8685     PerlMem_free(vmsspec);
8686     if (sts != RMS$_NMF)
8687         {
8688         set_vaxc_errno(sts);
8689         switch (sts)
8690             {
8691             case RMS$_FNF: case RMS$_DNF:
8692                 set_errno(ENOENT); break;
8693             case RMS$_DIR:
8694                 set_errno(ENOTDIR); break;
8695             case RMS$_DEV:
8696                 set_errno(ENODEV); break;
8697             case RMS$_FNM: case RMS$_SYN:
8698                 set_errno(EINVAL); break;
8699             case RMS$_PRV:
8700                 set_errno(EACCES); break;
8701             default:
8702                 _ckvmssts_noperl(sts);
8703             }
8704         }
8705     if (expcount == 0)
8706         add_item(head, tail, item, count);
8707     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
8708     _ckvmssts_noperl(lib$find_file_end(&context));
8709 }
8710
8711 static int child_st[2];/* Event Flag set when child process completes   */
8712
8713 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
8714
8715 static unsigned long int exit_handler(int *status)
8716 {
8717 short iosb[4];
8718
8719     if (0 == child_st[0])
8720         {
8721 #ifdef ARGPROC_DEBUG
8722         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
8723 #endif
8724         fflush(stdout);     /* Have to flush pipe for binary data to    */
8725                             /* terminate properly -- <tp@mccall.com>    */
8726         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
8727         sys$dassgn(child_chan);
8728         fclose(stdout);
8729         sys$synch(0, child_st);
8730         }
8731     return(1);
8732 }
8733
8734 static void sig_child(int chan)
8735 {
8736 #ifdef ARGPROC_DEBUG
8737     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
8738 #endif
8739     if (child_st[0] == 0)
8740         child_st[0] = 1;
8741 }
8742
8743 static struct exit_control_block exit_block =
8744     {
8745     0,
8746     exit_handler,
8747     1,
8748     &exit_block.exit_status,
8749     0
8750     };
8751
8752 static void
8753 pipe_and_fork(pTHX_ char **cmargv)
8754 {
8755     PerlIO *fp;
8756     struct dsc$descriptor_s *vmscmd;
8757     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
8758     int sts, j, l, ismcr, quote, tquote = 0;
8759
8760     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
8761     vms_execfree(vmscmd);
8762
8763     j = l = 0;
8764     p = subcmd;
8765     q = cmargv[0];
8766     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
8767               && toupper(*(q+2)) == 'R' && !*(q+3);
8768
8769     while (q && l < MAX_DCL_LINE_LENGTH) {
8770         if (!*q) {
8771             if (j > 0 && quote) {
8772                 *p++ = '"';
8773                 l++;
8774             }
8775             q = cmargv[++j];
8776             if (q) {
8777                 if (ismcr && j > 1) quote = 1;
8778                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
8779                 *p++ = ' ';
8780                 l++;
8781                 if (quote || tquote) {
8782                     *p++ = '"';
8783                     l++;
8784                 }
8785             }
8786         } else {
8787             if ((quote||tquote) && *q == '"') {
8788                 *p++ = '"';
8789                 l++;
8790             }
8791             *p++ = *q++;
8792             l++;
8793         }
8794     }
8795     *p = '\0';
8796
8797     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
8798     if (fp == Nullfp) {
8799         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
8800     }
8801 }
8802
8803 static int background_process(pTHX_ int argc, char **argv)
8804 {
8805 char command[MAX_DCL_SYMBOL + 1] = "$";
8806 $DESCRIPTOR(value, "");
8807 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
8808 static $DESCRIPTOR(null, "NLA0:");
8809 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
8810 char pidstring[80];
8811 $DESCRIPTOR(pidstr, "");
8812 int pid;
8813 unsigned long int flags = 17, one = 1, retsts;
8814 int len;
8815
8816     strcat(command, argv[0]);
8817     len = strlen(command);
8818     while (--argc && (len < MAX_DCL_SYMBOL))
8819         {
8820         strcat(command, " \"");
8821         strcat(command, *(++argv));
8822         strcat(command, "\"");
8823         len = strlen(command);
8824         }
8825     value.dsc$a_pointer = command;
8826     value.dsc$w_length = strlen(value.dsc$a_pointer);
8827     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
8828     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
8829     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
8830         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8831     }
8832     else {
8833         _ckvmssts_noperl(retsts);
8834     }
8835 #ifdef ARGPROC_DEBUG
8836     PerlIO_printf(Perl_debug_log, "%s\n", command);
8837 #endif
8838     sprintf(pidstring, "%08X", pid);
8839     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8840     pidstr.dsc$a_pointer = pidstring;
8841     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8842     lib$set_symbol(&pidsymbol, &pidstr);
8843     return(SS$_NORMAL);
8844 }
8845 /*}}}*/
8846 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8847
8848
8849 /* OS-specific initialization at image activation (not thread startup) */
8850 /* Older VAXC header files lack these constants */
8851 #ifndef JPI$_RIGHTS_SIZE
8852 #  define JPI$_RIGHTS_SIZE 817
8853 #endif
8854 #ifndef KGB$M_SUBSYSTEM
8855 #  define KGB$M_SUBSYSTEM 0x8
8856 #endif
8857
8858 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8859
8860 /*{{{void vms_image_init(int *, char ***)*/
8861 void
8862 vms_image_init(int *argcp, char ***argvp)
8863 {
8864   char eqv[LNM$C_NAMLENGTH+1] = "";
8865   unsigned int len, tabct = 8, tabidx = 0;
8866   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8867   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8868   unsigned short int dummy, rlen;
8869   struct dsc$descriptor_s **tabvec;
8870 #if defined(PERL_IMPLICIT_CONTEXT)
8871   pTHX = NULL;
8872 #endif
8873   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
8874                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
8875                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8876                                  {          0,                0,    0,      0} };
8877
8878 #ifdef KILL_BY_SIGPRC
8879     Perl_csighandler_init();
8880 #endif
8881
8882   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8883   _ckvmssts_noperl(iosb[0]);
8884   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8885     if (iprv[i]) {           /* Running image installed with privs? */
8886       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
8887       will_taint = TRUE;
8888       break;
8889     }
8890   }
8891   /* Rights identifiers might trigger tainting as well. */
8892   if (!will_taint && (rlen || rsz)) {
8893     while (rlen < rsz) {
8894       /* We didn't get all the identifiers on the first pass.  Allocate a
8895        * buffer much larger than $GETJPI wants (rsz is size in bytes that
8896        * were needed to hold all identifiers at time of last call; we'll
8897        * allocate that many unsigned long ints), and go back and get 'em.
8898        * If it gave us less than it wanted to despite ample buffer space,
8899        * something's broken.  Is your system missing a system identifier?
8900        */
8901       if (rsz <= jpilist[1].buflen) {
8902          /* Perl_croak accvios when used this early in startup. */
8903          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
8904                          rsz, (unsigned long) jpilist[1].buflen,
8905                          "Check your rights database for corruption.\n");
8906          exit(SS$_ABORT);
8907       }
8908       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
8909       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
8910       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8911       jpilist[1].buflen = rsz * sizeof(unsigned long int);
8912       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
8913       _ckvmssts_noperl(iosb[0]);
8914     }
8915     mask = jpilist[1].bufadr;
8916     /* Check attribute flags for each identifier (2nd longword); protected
8917      * subsystem identifiers trigger tainting.
8918      */
8919     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
8920       if (mask[i] & KGB$M_SUBSYSTEM) {
8921         will_taint = TRUE;
8922         break;
8923       }
8924     }
8925     if (mask != rlst) PerlMem_free(mask);
8926   }
8927
8928   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
8929    * logical, some versions of the CRTL will add a phanthom /000000/
8930    * directory.  This needs to be removed.
8931    */
8932   if (decc_filename_unix_report) {
8933   char * zeros;
8934   int ulen;
8935     ulen = strlen(argvp[0][0]);
8936     if (ulen > 7) {
8937       zeros = strstr(argvp[0][0], "/000000/");
8938       if (zeros != NULL) {
8939         int mlen;
8940         mlen = ulen - (zeros - argvp[0][0]) - 7;
8941         memmove(zeros, &zeros[7], mlen);
8942         ulen = ulen - 7;
8943         argvp[0][0][ulen] = '\0';
8944       }
8945     }
8946     /* It also may have a trailing dot that needs to be removed otherwise
8947      * it will be converted to VMS mode incorrectly.
8948      */
8949     ulen--;
8950     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
8951       argvp[0][0][ulen] = '\0';
8952   }
8953
8954   /* We need to use this hack to tell Perl it should run with tainting,
8955    * since its tainting flag may be part of the PL_curinterp struct, which
8956    * hasn't been allocated when vms_image_init() is called.
8957    */
8958   if (will_taint) {
8959     char **newargv, **oldargv;
8960     oldargv = *argvp;
8961     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
8962     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8963     newargv[0] = oldargv[0];
8964     newargv[1] = PerlMem_malloc(3 * sizeof(char));
8965     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8966     strcpy(newargv[1], "-T");
8967     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
8968     (*argcp)++;
8969     newargv[*argcp] = NULL;
8970     /* We orphan the old argv, since we don't know where it's come from,
8971      * so we don't know how to free it.
8972      */
8973     *argvp = newargv;
8974   }
8975   else {  /* Did user explicitly request tainting? */
8976     int i;
8977     char *cp, **av = *argvp;
8978     for (i = 1; i < *argcp; i++) {
8979       if (*av[i] != '-') break;
8980       for (cp = av[i]+1; *cp; cp++) {
8981         if (*cp == 'T') { will_taint = 1; break; }
8982         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
8983                   strchr("DFIiMmx",*cp)) break;
8984       }
8985       if (will_taint) break;
8986     }
8987   }
8988
8989   for (tabidx = 0;
8990        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
8991        tabidx++) {
8992     if (!tabidx) {
8993       tabvec = (struct dsc$descriptor_s **)
8994             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
8995       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8996     }
8997     else if (tabidx >= tabct) {
8998       tabct += 8;
8999       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9000       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9001     }
9002     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9003     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9004     tabvec[tabidx]->dsc$w_length  = 0;
9005     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9006     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
9007     tabvec[tabidx]->dsc$a_pointer = NULL;
9008     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9009   }
9010   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9011
9012   getredirection(argcp,argvp);
9013 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9014   {
9015 # include <reentrancy.h>
9016   decc$set_reentrancy(C$C_MULTITHREAD);
9017   }
9018 #endif
9019   return;
9020 }
9021 /*}}}*/
9022
9023
9024 /* trim_unixpath()
9025  * Trim Unix-style prefix off filespec, so it looks like what a shell
9026  * glob expansion would return (i.e. from specified prefix on, not
9027  * full path).  Note that returned filespec is Unix-style, regardless
9028  * of whether input filespec was VMS-style or Unix-style.
9029  *
9030  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9031  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9032  * vector of options; at present, only bit 0 is used, and if set tells
9033  * trim unixpath to try the current default directory as a prefix when
9034  * presented with a possibly ambiguous ... wildcard.
9035  *
9036  * Returns !=0 on success, with trimmed filespec replacing contents of
9037  * fspec, and 0 on failure, with contents of fpsec unchanged.
9038  */
9039 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9040 int
9041 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9042 {
9043   char *unixified, *unixwild,
9044        *template, *base, *end, *cp1, *cp2;
9045   register int tmplen, reslen = 0, dirs = 0;
9046
9047   unixwild = PerlMem_malloc(VMS_MAXRSS);
9048   if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
9049   if (!wildspec || !fspec) return 0;
9050   template = unixwild;
9051   if (strpbrk(wildspec,"]>:") != NULL) {
9052     if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
9053         PerlMem_free(unixwild);
9054         return 0;
9055     }
9056   }
9057   else {
9058     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
9059     unixwild[VMS_MAXRSS-1] = 0;
9060   }
9061   unixified = PerlMem_malloc(VMS_MAXRSS);
9062   if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
9063   if (strpbrk(fspec,"]>:") != NULL) {
9064     if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
9065         PerlMem_free(unixwild);
9066         PerlMem_free(unixified);
9067         return 0;
9068     }
9069     else base = unixified;
9070     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9071      * check to see that final result fits into (isn't longer than) fspec */
9072     reslen = strlen(fspec);
9073   }
9074   else base = fspec;
9075
9076   /* No prefix or absolute path on wildcard, so nothing to remove */
9077   if (!*template || *template == '/') {
9078     PerlMem_free(unixwild);
9079     if (base == fspec) {
9080         PerlMem_free(unixified);
9081         return 1;
9082     }
9083     tmplen = strlen(unixified);
9084     if (tmplen > reslen) {
9085         PerlMem_free(unixified);
9086         return 0;  /* not enough space */
9087     }
9088     /* Copy unixified resultant, including trailing NUL */
9089     memmove(fspec,unixified,tmplen+1);
9090     PerlMem_free(unixified);
9091     return 1;
9092   }
9093
9094   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
9095   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
9096     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
9097     for (cp1 = end ;cp1 >= base; cp1--)
9098       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9099         { cp1++; break; }
9100     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9101     PerlMem_free(unixified);
9102     PerlMem_free(unixwild);
9103     return 1;
9104   }
9105   else {
9106     char *tpl, *lcres;
9107     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9108     int ells = 1, totells, segdirs, match;
9109     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9110                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9111
9112     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9113     totells = ells;
9114     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9115     tpl = PerlMem_malloc(VMS_MAXRSS);
9116     if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
9117     if (ellipsis == template && opts & 1) {
9118       /* Template begins with an ellipsis.  Since we can't tell how many
9119        * directory names at the front of the resultant to keep for an
9120        * arbitrary starting point, we arbitrarily choose the current
9121        * default directory as a starting point.  If it's there as a prefix,
9122        * clip it off.  If not, fall through and act as if the leading
9123        * ellipsis weren't there (i.e. return shortest possible path that
9124        * could match template).
9125        */
9126       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9127           PerlMem_free(tpl);
9128           PerlMem_free(unixified);
9129           PerlMem_free(unixwild);
9130           return 0;
9131       }
9132       if (!decc_efs_case_preserve) {
9133         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9134           if (_tolower(*cp1) != _tolower(*cp2)) break;
9135       }
9136       segdirs = dirs - totells;  /* Min # of dirs we must have left */
9137       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9138       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9139         memmove(fspec,cp2+1,end - cp2);
9140         PerlMem_free(tpl);
9141         PerlMem_free(unixified);
9142         PerlMem_free(unixwild);
9143         return 1;
9144       }
9145     }
9146     /* First off, back up over constant elements at end of path */
9147     if (dirs) {
9148       for (front = end ; front >= base; front--)
9149          if (*front == '/' && !dirs--) { front++; break; }
9150     }
9151     lcres = PerlMem_malloc(VMS_MAXRSS);
9152     if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
9153     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9154          cp1++,cp2++) {
9155             if (!decc_efs_case_preserve) {
9156                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
9157             }
9158             else {
9159                 *cp2 = *cp1;
9160             }
9161     }
9162     if (cp1 != '\0') {
9163         PerlMem_free(tpl);
9164         PerlMem_free(unixified);
9165         PerlMem_free(unixwild);
9166         PerlMem_free(lcres);
9167         return 0;  /* Path too long. */
9168     }
9169     lcend = cp2;
9170     *cp2 = '\0';  /* Pick up with memcpy later */
9171     lcfront = lcres + (front - base);
9172     /* Now skip over each ellipsis and try to match the path in front of it. */
9173     while (ells--) {
9174       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
9175         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
9176             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
9177       if (cp1 < template) break; /* template started with an ellipsis */
9178       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9179         ellipsis = cp1; continue;
9180       }
9181       wilddsc.dsc$a_pointer = tpl;
9182       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9183       nextell = cp1;
9184       for (segdirs = 0, cp2 = tpl;
9185            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9186            cp1++, cp2++) {
9187          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9188          else {
9189             if (!decc_efs_case_preserve) {
9190               *cp2 = _tolower(*cp1);  /* else lowercase for match */
9191             }
9192             else {
9193               *cp2 = *cp1;  /* else preserve case for match */
9194             }
9195          }
9196          if (*cp2 == '/') segdirs++;
9197       }
9198       if (cp1 != ellipsis - 1) {
9199           PerlMem_free(tpl);
9200           PerlMem_free(unixified);
9201           PerlMem_free(unixwild);
9202           PerlMem_free(lcres);
9203           return 0; /* Path too long */
9204       }
9205       /* Back up at least as many dirs as in template before matching */
9206       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9207         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9208       for (match = 0; cp1 > lcres;) {
9209         resdsc.dsc$a_pointer = cp1;
9210         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9211           match++;
9212           if (match == 1) lcfront = cp1;
9213         }
9214         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9215       }
9216       if (!match) {
9217         PerlMem_free(tpl);
9218         PerlMem_free(unixified);
9219         PerlMem_free(unixwild);
9220         PerlMem_free(lcres);
9221         return 0;  /* Can't find prefix ??? */
9222       }
9223       if (match > 1 && opts & 1) {
9224         /* This ... wildcard could cover more than one set of dirs (i.e.
9225          * a set of similar dir names is repeated).  If the template
9226          * contains more than 1 ..., upstream elements could resolve the
9227          * ambiguity, but it's not worth a full backtracking setup here.
9228          * As a quick heuristic, clip off the current default directory
9229          * if it's present to find the trimmed spec, else use the
9230          * shortest string that this ... could cover.
9231          */
9232         char def[NAM$C_MAXRSS+1], *st;
9233
9234         if (getcwd(def, sizeof def,0) == NULL) {
9235             Safefree(unixified);
9236             Safefree(unixwild);
9237             Safefree(lcres);
9238             Safefree(tpl);
9239             return 0;
9240         }
9241         if (!decc_efs_case_preserve) {
9242           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9243             if (_tolower(*cp1) != _tolower(*cp2)) break;
9244         }
9245         segdirs = dirs - totells;  /* Min # of dirs we must have left */
9246         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9247         if (*cp1 == '\0' && *cp2 == '/') {
9248           memmove(fspec,cp2+1,end - cp2);
9249           PerlMem_free(tpl);
9250           PerlMem_free(unixified);
9251           PerlMem_free(unixwild);
9252           PerlMem_free(lcres);
9253           return 1;
9254         }
9255         /* Nope -- stick with lcfront from above and keep going. */
9256       }
9257     }
9258     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
9259     PerlMem_free(tpl);
9260     PerlMem_free(unixified);
9261     PerlMem_free(unixwild);
9262     PerlMem_free(lcres);
9263     return 1;
9264     ellipsis = nextell;
9265   }
9266
9267 }  /* end of trim_unixpath() */
9268 /*}}}*/
9269
9270
9271 /*
9272  *  VMS readdir() routines.
9273  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
9274  *
9275  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
9276  *  Minor modifications to original routines.
9277  */
9278
9279 /* readdir may have been redefined by reentr.h, so make sure we get
9280  * the local version for what we do here.
9281  */
9282 #ifdef readdir
9283 # undef readdir
9284 #endif
9285 #if !defined(PERL_IMPLICIT_CONTEXT)
9286 # define readdir Perl_readdir
9287 #else
9288 # define readdir(a) Perl_readdir(aTHX_ a)
9289 #endif
9290
9291     /* Number of elements in vms_versions array */
9292 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
9293
9294 /*
9295  *  Open a directory, return a handle for later use.
9296  */
9297 /*{{{ DIR *opendir(char*name) */
9298 DIR *
9299 Perl_opendir(pTHX_ const char *name)
9300 {
9301     DIR *dd;
9302     char *dir;
9303     Stat_t sb;
9304
9305     Newx(dir, VMS_MAXRSS, char);
9306     if (do_tovmspath(name,dir,0,NULL) == NULL) {
9307       Safefree(dir);
9308       return NULL;
9309     }
9310     /* Check access before stat; otherwise stat does not
9311      * accurately report whether it's a directory.
9312      */
9313     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
9314       /* cando_by_name has already set errno */
9315       Safefree(dir);
9316       return NULL;
9317     }
9318     if (flex_stat(dir,&sb) == -1) return NULL;
9319     if (!S_ISDIR(sb.st_mode)) {
9320       Safefree(dir);
9321       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
9322       return NULL;
9323     }
9324     /* Get memory for the handle, and the pattern. */
9325     Newx(dd,1,DIR);
9326     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
9327
9328     /* Fill in the fields; mainly playing with the descriptor. */
9329     sprintf(dd->pattern, "%s*.*",dir);
9330     Safefree(dir);
9331     dd->context = 0;
9332     dd->count = 0;
9333     dd->flags = 0;
9334     /* By saying we always want the result of readdir() in unix format, we
9335      * are really saying we want all the escapes removed.  Otherwise the caller,
9336      * having no way to know whether it's already in VMS format, might send it
9337      * through tovmsspec again, thus double escaping.
9338      */
9339     dd->flags = PERL_VMSDIR_M_UNIXSPECS;
9340     dd->pat.dsc$a_pointer = dd->pattern;
9341     dd->pat.dsc$w_length = strlen(dd->pattern);
9342     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
9343     dd->pat.dsc$b_class = DSC$K_CLASS_S;
9344 #if defined(USE_ITHREADS)
9345     Newx(dd->mutex,1,perl_mutex);
9346     MUTEX_INIT( (perl_mutex *) dd->mutex );
9347 #else
9348     dd->mutex = NULL;
9349 #endif
9350
9351     return dd;
9352 }  /* end of opendir() */
9353 /*}}}*/
9354
9355 /*
9356  *  Set the flag to indicate we want versions or not.
9357  */
9358 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
9359 void
9360 vmsreaddirversions(DIR *dd, int flag)
9361 {
9362     if (flag)
9363         dd->flags |= PERL_VMSDIR_M_VERSIONS;
9364     else
9365         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9366 }
9367 /*}}}*/
9368
9369 /*
9370  *  Free up an opened directory.
9371  */
9372 /*{{{ void closedir(DIR *dd)*/
9373 void
9374 Perl_closedir(DIR *dd)
9375 {
9376     int sts;
9377
9378     sts = lib$find_file_end(&dd->context);
9379     Safefree(dd->pattern);
9380 #if defined(USE_ITHREADS)
9381     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
9382     Safefree(dd->mutex);
9383 #endif
9384     Safefree(dd);
9385 }
9386 /*}}}*/
9387
9388 /*
9389  *  Collect all the version numbers for the current file.
9390  */
9391 static void
9392 collectversions(pTHX_ DIR *dd)
9393 {
9394     struct dsc$descriptor_s     pat;
9395     struct dsc$descriptor_s     res;
9396     struct dirent *e;
9397     char *p, *text, *buff;
9398     int i;
9399     unsigned long context, tmpsts;
9400
9401     /* Convenient shorthand. */
9402     e = &dd->entry;
9403
9404     /* Add the version wildcard, ignoring the "*.*" put on before */
9405     i = strlen(dd->pattern);
9406     Newx(text,i + e->d_namlen + 3,char);
9407     strcpy(text, dd->pattern);
9408     sprintf(&text[i - 3], "%s;*", e->d_name);
9409
9410     /* Set up the pattern descriptor. */
9411     pat.dsc$a_pointer = text;
9412     pat.dsc$w_length = i + e->d_namlen - 1;
9413     pat.dsc$b_dtype = DSC$K_DTYPE_T;
9414     pat.dsc$b_class = DSC$K_CLASS_S;
9415
9416     /* Set up result descriptor. */
9417     Newx(buff, VMS_MAXRSS, char);
9418     res.dsc$a_pointer = buff;
9419     res.dsc$w_length = VMS_MAXRSS - 1;
9420     res.dsc$b_dtype = DSC$K_DTYPE_T;
9421     res.dsc$b_class = DSC$K_CLASS_S;
9422
9423     /* Read files, collecting versions. */
9424     for (context = 0, e->vms_verscount = 0;
9425          e->vms_verscount < VERSIZE(e);
9426          e->vms_verscount++) {
9427         unsigned long rsts;
9428         unsigned long flags = 0;
9429
9430 #ifdef VMS_LONGNAME_SUPPORT
9431         flags = LIB$M_FIL_LONG_NAMES;
9432 #endif
9433         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
9434         if (tmpsts == RMS$_NMF || context == 0) break;
9435         _ckvmssts(tmpsts);
9436         buff[VMS_MAXRSS - 1] = '\0';
9437         if ((p = strchr(buff, ';')))
9438             e->vms_versions[e->vms_verscount] = atoi(p + 1);
9439         else
9440             e->vms_versions[e->vms_verscount] = -1;
9441     }
9442
9443     _ckvmssts(lib$find_file_end(&context));
9444     Safefree(text);
9445     Safefree(buff);
9446
9447 }  /* end of collectversions() */
9448
9449 /*
9450  *  Read the next entry from the directory.
9451  */
9452 /*{{{ struct dirent *readdir(DIR *dd)*/
9453 struct dirent *
9454 Perl_readdir(pTHX_ DIR *dd)
9455 {
9456     struct dsc$descriptor_s     res;
9457     char *p, *buff;
9458     unsigned long int tmpsts;
9459     unsigned long rsts;
9460     unsigned long flags = 0;
9461     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
9462     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
9463
9464     /* Set up result descriptor, and get next file. */
9465     Newx(buff, VMS_MAXRSS, char);
9466     res.dsc$a_pointer = buff;
9467     res.dsc$w_length = VMS_MAXRSS - 1;
9468     res.dsc$b_dtype = DSC$K_DTYPE_T;
9469     res.dsc$b_class = DSC$K_CLASS_S;
9470
9471 #ifdef VMS_LONGNAME_SUPPORT
9472     flags = LIB$M_FIL_LONG_NAMES;
9473 #endif
9474
9475     tmpsts = lib$find_file
9476         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
9477     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
9478     if (!(tmpsts & 1)) {
9479       set_vaxc_errno(tmpsts);
9480       switch (tmpsts) {
9481         case RMS$_PRV:
9482           set_errno(EACCES); break;
9483         case RMS$_DEV:
9484           set_errno(ENODEV); break;
9485         case RMS$_DIR:
9486           set_errno(ENOTDIR); break;
9487         case RMS$_FNF: case RMS$_DNF:
9488           set_errno(ENOENT); break;
9489         default:
9490           set_errno(EVMSERR);
9491       }
9492       Safefree(buff);
9493       return NULL;
9494     }
9495     dd->count++;
9496     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
9497     if (!decc_efs_case_preserve) {
9498       buff[VMS_MAXRSS - 1] = '\0';
9499       for (p = buff; *p; p++) *p = _tolower(*p);
9500     }
9501     else {
9502       /* we don't want to force to lowercase, just null terminate */
9503       buff[res.dsc$w_length] = '\0';
9504     }
9505     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
9506     *p = '\0';
9507
9508     /* Skip any directory component and just copy the name. */
9509     sts = vms_split_path
9510        (buff,
9511         &v_spec,
9512         &v_len,
9513         &r_spec,
9514         &r_len,
9515         &d_spec,
9516         &d_len,
9517         &n_spec,
9518         &n_len,
9519         &e_spec,
9520         &e_len,
9521         &vs_spec,
9522         &vs_len);
9523
9524     /* Drop NULL extensions on UNIX file specification */
9525     if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
9526         (e_len == 1) && decc_readdir_dropdotnotype)) {
9527         e_len = 0;
9528         e_spec[0] = '\0';
9529     }
9530
9531     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
9532     dd->entry.d_name[n_len + e_len] = '\0';
9533     dd->entry.d_namlen = strlen(dd->entry.d_name);
9534
9535     /* Convert the filename to UNIX format if needed */
9536     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
9537
9538         /* Translate the encoded characters. */
9539         /* Fixme: Unicode handling could result in embedded 0 characters */
9540         if (strchr(dd->entry.d_name, '^') != NULL) {
9541             char new_name[256];
9542             char * q;
9543             p = dd->entry.d_name;
9544             q = new_name;
9545             while (*p != 0) {
9546                 int inchars_read, outchars_added;
9547                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
9548                 p += inchars_read;
9549                 q += outchars_added;
9550                 /* fix-me */
9551                 /* if outchars_added > 1, then this is a wide file specification */
9552                 /* Wide file specifications need to be passed in Perl */
9553                 /* counted strings apparently with a Unicode flag */
9554             }
9555             *q = 0;
9556             strcpy(dd->entry.d_name, new_name);
9557             dd->entry.d_namlen = strlen(dd->entry.d_name);
9558         }
9559     }
9560
9561     dd->entry.vms_verscount = 0;
9562     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
9563     Safefree(buff);
9564     return &dd->entry;
9565
9566 }  /* end of readdir() */
9567 /*}}}*/
9568
9569 /*
9570  *  Read the next entry from the directory -- thread-safe version.
9571  */
9572 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
9573 int
9574 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
9575 {
9576     int retval;
9577
9578     MUTEX_LOCK( (perl_mutex *) dd->mutex );
9579
9580     entry = readdir(dd);
9581     *result = entry;
9582     retval = ( *result == NULL ? errno : 0 );
9583
9584     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
9585
9586     return retval;
9587
9588 }  /* end of readdir_r() */
9589 /*}}}*/
9590
9591 /*
9592  *  Return something that can be used in a seekdir later.
9593  */
9594 /*{{{ long telldir(DIR *dd)*/
9595 long
9596 Perl_telldir(DIR *dd)
9597 {
9598     return dd->count;
9599 }
9600 /*}}}*/
9601
9602 /*
9603  *  Return to a spot where we used to be.  Brute force.
9604  */
9605 /*{{{ void seekdir(DIR *dd,long count)*/
9606 void
9607 Perl_seekdir(pTHX_ DIR *dd, long count)
9608 {
9609     int old_flags;
9610
9611     /* If we haven't done anything yet... */
9612     if (dd->count == 0)
9613         return;
9614
9615     /* Remember some state, and clear it. */
9616     old_flags = dd->flags;
9617     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9618     _ckvmssts(lib$find_file_end(&dd->context));
9619     dd->context = 0;
9620
9621     /* The increment is in readdir(). */
9622     for (dd->count = 0; dd->count < count; )
9623         readdir(dd);
9624
9625     dd->flags = old_flags;
9626
9627 }  /* end of seekdir() */
9628 /*}}}*/
9629
9630 /* VMS subprocess management
9631  *
9632  * my_vfork() - just a vfork(), after setting a flag to record that
9633  * the current script is trying a Unix-style fork/exec.
9634  *
9635  * vms_do_aexec() and vms_do_exec() are called in response to the
9636  * perl 'exec' function.  If this follows a vfork call, then they
9637  * call out the regular perl routines in doio.c which do an
9638  * execvp (for those who really want to try this under VMS).
9639  * Otherwise, they do exactly what the perl docs say exec should
9640  * do - terminate the current script and invoke a new command
9641  * (See below for notes on command syntax.)
9642  *
9643  * do_aspawn() and do_spawn() implement the VMS side of the perl
9644  * 'system' function.
9645  *
9646  * Note on command arguments to perl 'exec' and 'system': When handled
9647  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
9648  * are concatenated to form a DCL command string.  If the first arg
9649  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
9650  * the command string is handed off to DCL directly.  Otherwise,
9651  * the first token of the command is taken as the filespec of an image
9652  * to run.  The filespec is expanded using a default type of '.EXE' and
9653  * the process defaults for device, directory, etc., and if found, the resultant
9654  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
9655  * the command string as parameters.  This is perhaps a bit complicated,
9656  * but I hope it will form a happy medium between what VMS folks expect
9657  * from lib$spawn and what Unix folks expect from exec.
9658  */
9659
9660 static int vfork_called;
9661
9662 /*{{{int my_vfork()*/
9663 int
9664 my_vfork()
9665 {
9666   vfork_called++;
9667   return vfork();
9668 }
9669 /*}}}*/
9670
9671
9672 static void
9673 vms_execfree(struct dsc$descriptor_s *vmscmd)
9674 {
9675   if (vmscmd) {
9676       if (vmscmd->dsc$a_pointer) {
9677           PerlMem_free(vmscmd->dsc$a_pointer);
9678       }
9679       PerlMem_free(vmscmd);
9680   }
9681 }
9682
9683 static char *
9684 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
9685 {
9686   char *junk, *tmps = Nullch;
9687   register size_t cmdlen = 0;
9688   size_t rlen;
9689   register SV **idx;
9690   STRLEN n_a;
9691
9692   idx = mark;
9693   if (really) {
9694     tmps = SvPV(really,rlen);
9695     if (*tmps) {
9696       cmdlen += rlen + 1;
9697       idx++;
9698     }
9699   }
9700
9701   for (idx++; idx <= sp; idx++) {
9702     if (*idx) {
9703       junk = SvPVx(*idx,rlen);
9704       cmdlen += rlen ? rlen + 1 : 0;
9705     }
9706   }
9707   Newx(PL_Cmd, cmdlen+1, char);
9708
9709   if (tmps && *tmps) {
9710     strcpy(PL_Cmd,tmps);
9711     mark++;
9712   }
9713   else *PL_Cmd = '\0';
9714   while (++mark <= sp) {
9715     if (*mark) {
9716       char *s = SvPVx(*mark,n_a);
9717       if (!*s) continue;
9718       if (*PL_Cmd) strcat(PL_Cmd," ");
9719       strcat(PL_Cmd,s);
9720     }
9721   }
9722   return PL_Cmd;
9723
9724 }  /* end of setup_argstr() */
9725
9726
9727 static unsigned long int
9728 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
9729                    struct dsc$descriptor_s **pvmscmd)
9730 {
9731   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
9732   char image_name[NAM$C_MAXRSS+1];
9733   char image_argv[NAM$C_MAXRSS+1];
9734   $DESCRIPTOR(defdsc,".EXE");
9735   $DESCRIPTOR(defdsc2,".");
9736   $DESCRIPTOR(resdsc,resspec);
9737   struct dsc$descriptor_s *vmscmd;
9738   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9739   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
9740   register char *s, *rest, *cp, *wordbreak;
9741   char * cmd;
9742   int cmdlen;
9743   register int isdcl;
9744
9745   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9746   if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
9747
9748   /* Make a copy for modification */
9749   cmdlen = strlen(incmd);
9750   cmd = PerlMem_malloc(cmdlen+1);
9751   if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
9752   strncpy(cmd, incmd, cmdlen);
9753   cmd[cmdlen] = 0;
9754   image_name[0] = 0;
9755   image_argv[0] = 0;
9756
9757   vmscmd->dsc$a_pointer = NULL;
9758   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
9759   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
9760   vmscmd->dsc$w_length = 0;
9761   if (pvmscmd) *pvmscmd = vmscmd;
9762
9763   if (suggest_quote) *suggest_quote = 0;
9764
9765   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
9766     PerlMem_free(cmd);
9767     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
9768   }
9769
9770   s = cmd;
9771
9772   while (*s && isspace(*s)) s++;
9773
9774   if (*s == '@' || *s == '$') {
9775     vmsspec[0] = *s;  rest = s + 1;
9776     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
9777   }
9778   else { cp = vmsspec; rest = s; }
9779   if (*rest == '.' || *rest == '/') {
9780     char *cp2;
9781     for (cp2 = resspec;
9782          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
9783          rest++, cp2++) *cp2 = *rest;
9784     *cp2 = '\0';
9785     if (do_tovmsspec(resspec,cp,0,NULL)) {
9786       s = vmsspec;
9787       if (*rest) {
9788         for (cp2 = vmsspec + strlen(vmsspec);
9789              *rest && cp2 - vmsspec < sizeof vmsspec;
9790              rest++, cp2++) *cp2 = *rest;
9791         *cp2 = '\0';
9792       }
9793     }
9794   }
9795   /* Intuit whether verb (first word of cmd) is a DCL command:
9796    *   - if first nonspace char is '@', it's a DCL indirection
9797    * otherwise
9798    *   - if verb contains a filespec separator, it's not a DCL command
9799    *   - if it doesn't, caller tells us whether to default to a DCL
9800    *     command, or to a local image unless told it's DCL (by leading '$')
9801    */
9802   if (*s == '@') {
9803       isdcl = 1;
9804       if (suggest_quote) *suggest_quote = 1;
9805   } else {
9806     register char *filespec = strpbrk(s,":<[.;");
9807     rest = wordbreak = strpbrk(s," \"\t/");
9808     if (!wordbreak) wordbreak = s + strlen(s);
9809     if (*s == '$') check_img = 0;
9810     if (filespec && (filespec < wordbreak)) isdcl = 0;
9811     else isdcl = !check_img;
9812   }
9813
9814   if (!isdcl) {
9815     int rsts;
9816     imgdsc.dsc$a_pointer = s;
9817     imgdsc.dsc$w_length = wordbreak - s;
9818     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9819     if (!(retsts&1)) {
9820         _ckvmssts(lib$find_file_end(&cxt));
9821         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9822       if (!(retsts & 1) && *s == '$') {
9823         _ckvmssts(lib$find_file_end(&cxt));
9824         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
9825         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9826         if (!(retsts&1)) {
9827           _ckvmssts(lib$find_file_end(&cxt));
9828           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9829         }
9830       }
9831     }
9832     _ckvmssts(lib$find_file_end(&cxt));
9833
9834     if (retsts & 1) {
9835       FILE *fp;
9836       s = resspec;
9837       while (*s && !isspace(*s)) s++;
9838       *s = '\0';
9839
9840       /* check that it's really not DCL with no file extension */
9841       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9842       if (fp) {
9843         char b[256] = {0,0,0,0};
9844         read(fileno(fp), b, 256);
9845         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9846         if (isdcl) {
9847           int shebang_len;
9848
9849           /* Check for script */
9850           shebang_len = 0;
9851           if ((b[0] == '#') && (b[1] == '!'))
9852              shebang_len = 2;
9853 #ifdef ALTERNATE_SHEBANG
9854           else {
9855             shebang_len = strlen(ALTERNATE_SHEBANG);
9856             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9857               char * perlstr;
9858                 perlstr = strstr("perl",b);
9859                 if (perlstr == NULL)
9860                   shebang_len = 0;
9861             }
9862             else
9863               shebang_len = 0;
9864           }
9865 #endif
9866
9867           if (shebang_len > 0) {
9868           int i;
9869           int j;
9870           char tmpspec[NAM$C_MAXRSS + 1];
9871
9872             i = shebang_len;
9873              /* Image is following after white space */
9874             /*--------------------------------------*/
9875             while (isprint(b[i]) && isspace(b[i]))
9876                 i++;
9877
9878             j = 0;
9879             while (isprint(b[i]) && !isspace(b[i])) {
9880                 tmpspec[j++] = b[i++];
9881                 if (j >= NAM$C_MAXRSS)
9882                    break;
9883             }
9884             tmpspec[j] = '\0';
9885
9886              /* There may be some default parameters to the image */
9887             /*---------------------------------------------------*/
9888             j = 0;
9889             while (isprint(b[i])) {
9890                 image_argv[j++] = b[i++];
9891                 if (j >= NAM$C_MAXRSS)
9892                    break;
9893             }
9894             while ((j > 0) && !isprint(image_argv[j-1]))
9895                 j--;
9896             image_argv[j] = 0;
9897
9898             /* It will need to be converted to VMS format and validated */
9899             if (tmpspec[0] != '\0') {
9900               char * iname;
9901
9902                /* Try to find the exact program requested to be run */
9903               /*---------------------------------------------------*/
9904               iname = do_rmsexpand
9905                  (tmpspec, image_name, 0, ".exe",
9906                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
9907               if (iname != NULL) {
9908                 if (cando_by_name_int
9909                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
9910                   /* MCR prefix needed */
9911                   isdcl = 0;
9912                 }
9913                 else {
9914                    /* Try again with a null type */
9915                   /*----------------------------*/
9916                   iname = do_rmsexpand
9917                     (tmpspec, image_name, 0, ".",
9918                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
9919                   if (iname != NULL) {
9920                     if (cando_by_name_int
9921                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
9922                       /* MCR prefix needed */
9923                       isdcl = 0;
9924                     }
9925                   }
9926                 }
9927
9928                  /* Did we find the image to run the script? */
9929                 /*------------------------------------------*/
9930                 if (isdcl) {
9931                   char *tchr;
9932
9933                    /* Assume DCL or foreign command exists */
9934                   /*--------------------------------------*/
9935                   tchr = strrchr(tmpspec, '/');
9936                   if (tchr != NULL) {
9937                     tchr++;
9938                   }
9939                   else {
9940                     tchr = tmpspec;
9941                   }
9942                   strcpy(image_name, tchr);
9943                 }
9944               }
9945             }
9946           }
9947         }
9948         fclose(fp);
9949       }
9950       if (check_img && isdcl) return RMS$_FNF;
9951
9952       if (cando_by_name(S_IXUSR,0,resspec)) {
9953         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
9954         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
9955         if (!isdcl) {
9956             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
9957             if (image_name[0] != 0) {
9958                 strcat(vmscmd->dsc$a_pointer, image_name);
9959                 strcat(vmscmd->dsc$a_pointer, " ");
9960             }
9961         } else if (image_name[0] != 0) {
9962             strcpy(vmscmd->dsc$a_pointer, image_name);
9963             strcat(vmscmd->dsc$a_pointer, " ");
9964         } else {
9965             strcpy(vmscmd->dsc$a_pointer,"@");
9966         }
9967         if (suggest_quote) *suggest_quote = 1;
9968
9969         /* If there is an image name, use original command */
9970         if (image_name[0] == 0)
9971             strcat(vmscmd->dsc$a_pointer,resspec);
9972         else {
9973             rest = cmd;
9974             while (*rest && isspace(*rest)) rest++;
9975         }
9976
9977         if (image_argv[0] != 0) {
9978           strcat(vmscmd->dsc$a_pointer,image_argv);
9979           strcat(vmscmd->dsc$a_pointer, " ");
9980         }
9981         if (rest) {
9982            int rest_len;
9983            int vmscmd_len;
9984
9985            rest_len = strlen(rest);
9986            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
9987            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
9988               strcat(vmscmd->dsc$a_pointer,rest);
9989            else
9990              retsts = CLI$_BUFOVF;
9991         }
9992         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
9993         PerlMem_free(cmd);
9994         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9995       }
9996       else
9997         retsts = RMS$_PRV;
9998     }
9999   }
10000   /* It's either a DCL command or we couldn't find a suitable image */
10001   vmscmd->dsc$w_length = strlen(cmd);
10002
10003   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
10004   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
10005   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
10006
10007   PerlMem_free(cmd);
10008
10009   /* check if it's a symbol (for quoting purposes) */
10010   if (suggest_quote && !*suggest_quote) {
10011     int iss;
10012     char equiv[LNM$C_NAMLENGTH];
10013     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10014     eqvdsc.dsc$a_pointer = equiv;
10015
10016     iss = lib$get_symbol(vmscmd,&eqvdsc);
10017     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10018   }
10019   if (!(retsts & 1)) {
10020     /* just hand off status values likely to be due to user error */
10021     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10022         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10023        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10024     else { _ckvmssts(retsts); }
10025   }
10026
10027   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10028
10029 }  /* end of setup_cmddsc() */
10030
10031
10032 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10033 bool
10034 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10035 {
10036 bool exec_sts;
10037 char * cmd;
10038
10039   if (sp > mark) {
10040     if (vfork_called) {           /* this follows a vfork - act Unixish */
10041       vfork_called--;
10042       if (vfork_called < 0) {
10043         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10044         vfork_called = 0;
10045       }
10046       else return do_aexec(really,mark,sp);
10047     }
10048                                            /* no vfork - act VMSish */
10049     cmd = setup_argstr(aTHX_ really,mark,sp);
10050     exec_sts = vms_do_exec(cmd);
10051     Safefree(cmd);  /* Clean up from setup_argstr() */
10052     return exec_sts;
10053   }
10054
10055   return FALSE;
10056 }  /* end of vms_do_aexec() */
10057 /*}}}*/
10058
10059 /* {{{bool vms_do_exec(char *cmd) */
10060 bool
10061 Perl_vms_do_exec(pTHX_ const char *cmd)
10062 {
10063   struct dsc$descriptor_s *vmscmd;
10064
10065   if (vfork_called) {             /* this follows a vfork - act Unixish */
10066     vfork_called--;
10067     if (vfork_called < 0) {
10068       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10069       vfork_called = 0;
10070     }
10071     else return do_exec(cmd);
10072   }
10073
10074   {                               /* no vfork - act VMSish */
10075     unsigned long int retsts;
10076
10077     TAINT_ENV();
10078     TAINT_PROPER("exec");
10079     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10080       retsts = lib$do_command(vmscmd);
10081
10082     switch (retsts) {
10083       case RMS$_FNF: case RMS$_DNF:
10084         set_errno(ENOENT); break;
10085       case RMS$_DIR:
10086         set_errno(ENOTDIR); break;
10087       case RMS$_DEV:
10088         set_errno(ENODEV); break;
10089       case RMS$_PRV:
10090         set_errno(EACCES); break;
10091       case RMS$_SYN:
10092         set_errno(EINVAL); break;
10093       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10094         set_errno(E2BIG); break;
10095       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10096         _ckvmssts(retsts); /* fall through */
10097       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10098         set_errno(EVMSERR);
10099     }
10100     set_vaxc_errno(retsts);
10101     if (ckWARN(WARN_EXEC)) {
10102       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10103              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10104     }
10105     vms_execfree(vmscmd);
10106   }
10107
10108   return FALSE;
10109
10110 }  /* end of vms_do_exec() */
10111 /*}}}*/
10112
10113 unsigned long int Perl_do_spawn(pTHX_ const char *);
10114
10115 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
10116 unsigned long int
10117 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
10118 {
10119 unsigned long int sts;
10120 char * cmd;
10121
10122   if (sp > mark) {
10123     cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
10124     sts = do_spawn(cmd);
10125     /* pp_sys will clean up cmd */
10126     return sts;
10127   }
10128   return SS$_ABORT;
10129 }  /* end of do_aspawn() */
10130 /*}}}*/
10131
10132 /* {{{unsigned long int do_spawn(char *cmd) */
10133 unsigned long int
10134 Perl_do_spawn(pTHX_ const char *cmd)
10135 {
10136   unsigned long int sts, substs;
10137
10138   /* The caller of this routine expects to Safefree(PL_Cmd) */
10139   Newx(PL_Cmd,10,char);
10140
10141   TAINT_ENV();
10142   TAINT_PROPER("spawn");
10143   if (!cmd || !*cmd) {
10144     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
10145     if (!(sts & 1)) {
10146       switch (sts) {
10147         case RMS$_FNF:  case RMS$_DNF:
10148           set_errno(ENOENT); break;
10149         case RMS$_DIR:
10150           set_errno(ENOTDIR); break;
10151         case RMS$_DEV:
10152           set_errno(ENODEV); break;
10153         case RMS$_PRV:
10154           set_errno(EACCES); break;
10155         case RMS$_SYN:
10156           set_errno(EINVAL); break;
10157         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10158           set_errno(E2BIG); break;
10159         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10160           _ckvmssts(sts); /* fall through */
10161         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10162           set_errno(EVMSERR);
10163       }
10164       set_vaxc_errno(sts);
10165       if (ckWARN(WARN_EXEC)) {
10166         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
10167                     Strerror(errno));
10168       }
10169     }
10170     sts = substs;
10171   }
10172   else {
10173     PerlIO * fp;
10174     fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
10175     if (fp != NULL)
10176       my_pclose(fp);
10177   }
10178   return sts;
10179 }  /* end of do_spawn() */
10180 /*}}}*/
10181
10182
10183 static unsigned int *sockflags, sockflagsize;
10184
10185 /*
10186  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
10187  * routines found in some versions of the CRTL can't deal with sockets.
10188  * We don't shim the other file open routines since a socket isn't
10189  * likely to be opened by a name.
10190  */
10191 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
10192 FILE *my_fdopen(int fd, const char *mode)
10193 {
10194   FILE *fp = fdopen(fd, mode);
10195
10196   if (fp) {
10197     unsigned int fdoff = fd / sizeof(unsigned int);
10198     Stat_t sbuf; /* native stat; we don't need flex_stat */
10199     if (!sockflagsize || fdoff > sockflagsize) {
10200       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
10201       else           Newx  (sockflags,fdoff+2,unsigned int);
10202       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
10203       sockflagsize = fdoff + 2;
10204     }
10205     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
10206       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
10207   }
10208   return fp;
10209
10210 }
10211 /*}}}*/
10212
10213
10214 /*
10215  * Clear the corresponding bit when the (possibly) socket stream is closed.
10216  * There still a small hole: we miss an implicit close which might occur
10217  * via freopen().  >> Todo
10218  */
10219 /*{{{ int my_fclose(FILE *fp)*/
10220 int my_fclose(FILE *fp) {
10221   if (fp) {
10222     unsigned int fd = fileno(fp);
10223     unsigned int fdoff = fd / sizeof(unsigned int);
10224
10225     if (sockflagsize && fdoff <= sockflagsize)
10226       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
10227   }
10228   return fclose(fp);
10229 }
10230 /*}}}*/
10231
10232
10233 /*
10234  * A simple fwrite replacement which outputs itmsz*nitm chars without
10235  * introducing record boundaries every itmsz chars.
10236  * We are using fputs, which depends on a terminating null.  We may
10237  * well be writing binary data, so we need to accommodate not only
10238  * data with nulls sprinkled in the middle but also data with no null
10239  * byte at the end.
10240  */
10241 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
10242 int
10243 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
10244 {
10245   register char *cp, *end, *cpd, *data;
10246   register unsigned int fd = fileno(dest);
10247   register unsigned int fdoff = fd / sizeof(unsigned int);
10248   int retval;
10249   int bufsize = itmsz * nitm + 1;
10250
10251   if (fdoff < sockflagsize &&
10252       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
10253     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
10254     return nitm;
10255   }
10256
10257   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
10258   memcpy( data, src, itmsz*nitm );
10259   data[itmsz*nitm] = '\0';
10260
10261   end = data + itmsz * nitm;
10262   retval = (int) nitm; /* on success return # items written */
10263
10264   cpd = data;
10265   while (cpd <= end) {
10266     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
10267     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
10268     if (cp < end)
10269       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
10270     cpd = cp + 1;
10271   }
10272
10273   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
10274   return retval;
10275
10276 }  /* end of my_fwrite() */
10277 /*}}}*/
10278
10279 /*{{{ int my_flush(FILE *fp)*/
10280 int
10281 Perl_my_flush(pTHX_ FILE *fp)
10282 {
10283     int res;
10284     if ((res = fflush(fp)) == 0 && fp) {
10285 #ifdef VMS_DO_SOCKETS
10286         Stat_t s;
10287         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
10288 #endif
10289             res = fsync(fileno(fp));
10290     }
10291 /*
10292  * If the flush succeeded but set end-of-file, we need to clear
10293  * the error because our caller may check ferror().  BTW, this
10294  * probably means we just flushed an empty file.
10295  */
10296     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
10297
10298     return res;
10299 }
10300 /*}}}*/
10301
10302 /*
10303  * Here are replacements for the following Unix routines in the VMS environment:
10304  *      getpwuid    Get information for a particular UIC or UID
10305  *      getpwnam    Get information for a named user
10306  *      getpwent    Get information for each user in the rights database
10307  *      setpwent    Reset search to the start of the rights database
10308  *      endpwent    Finish searching for users in the rights database
10309  *
10310  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
10311  * (defined in pwd.h), which contains the following fields:-
10312  *      struct passwd {
10313  *              char        *pw_name;    Username (in lower case)
10314  *              char        *pw_passwd;  Hashed password
10315  *              unsigned int pw_uid;     UIC
10316  *              unsigned int pw_gid;     UIC group  number
10317  *              char        *pw_unixdir; Default device/directory (VMS-style)
10318  *              char        *pw_gecos;   Owner name
10319  *              char        *pw_dir;     Default device/directory (Unix-style)
10320  *              char        *pw_shell;   Default CLI name (eg. DCL)
10321  *      };
10322  * If the specified user does not exist, getpwuid and getpwnam return NULL.
10323  *
10324  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
10325  * not the UIC member number (eg. what's returned by getuid()),
10326  * getpwuid() can accept either as input (if uid is specified, the caller's
10327  * UIC group is used), though it won't recognise gid=0.
10328  *
10329  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
10330  * information about other users in your group or in other groups, respectively.
10331  * If the required privilege is not available, then these routines fill only
10332  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
10333  * string).
10334  *
10335  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
10336  */
10337
10338 /* sizes of various UAF record fields */
10339 #define UAI$S_USERNAME 12
10340 #define UAI$S_IDENT    31
10341 #define UAI$S_OWNER    31
10342 #define UAI$S_DEFDEV   31
10343 #define UAI$S_DEFDIR   63
10344 #define UAI$S_DEFCLI   31
10345 #define UAI$S_PWD       8
10346
10347 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
10348                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
10349                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
10350
10351 static char __empty[]= "";
10352 static struct passwd __passwd_empty=
10353     {(char *) __empty, (char *) __empty, 0, 0,
10354      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
10355 static int contxt= 0;
10356 static struct passwd __pwdcache;
10357 static char __pw_namecache[UAI$S_IDENT+1];
10358
10359 /*
10360  * This routine does most of the work extracting the user information.
10361  */
10362 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
10363 {
10364     static struct {
10365         unsigned char length;
10366         char pw_gecos[UAI$S_OWNER+1];
10367     } owner;
10368     static union uicdef uic;
10369     static struct {
10370         unsigned char length;
10371         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
10372     } defdev;
10373     static struct {
10374         unsigned char length;
10375         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
10376     } defdir;
10377     static struct {
10378         unsigned char length;
10379         char pw_shell[UAI$S_DEFCLI+1];
10380     } defcli;
10381     static char pw_passwd[UAI$S_PWD+1];
10382
10383     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
10384     struct dsc$descriptor_s name_desc;
10385     unsigned long int sts;
10386
10387     static struct itmlst_3 itmlst[]= {
10388         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
10389         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
10390         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
10391         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
10392         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
10393         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
10394         {0,                0,           NULL,    NULL}};
10395
10396     name_desc.dsc$w_length=  strlen(name);
10397     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
10398     name_desc.dsc$b_class=   DSC$K_CLASS_S;
10399     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
10400
10401 /*  Note that sys$getuai returns many fields as counted strings. */
10402     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
10403     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
10404       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
10405     }
10406     else { _ckvmssts(sts); }
10407     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
10408
10409     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
10410     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
10411     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
10412     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
10413     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
10414     owner.pw_gecos[lowner]=            '\0';
10415     defdev.pw_dir[ldefdev+ldefdir]= '\0';
10416     defcli.pw_shell[ldefcli]=          '\0';
10417     if (valid_uic(uic)) {
10418         pwd->pw_uid= uic.uic$l_uic;
10419         pwd->pw_gid= uic.uic$v_group;
10420     }
10421     else
10422       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
10423     pwd->pw_passwd=  pw_passwd;
10424     pwd->pw_gecos=   owner.pw_gecos;
10425     pwd->pw_dir=     defdev.pw_dir;
10426     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
10427     pwd->pw_shell=   defcli.pw_shell;
10428     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
10429         int ldir;
10430         ldir= strlen(pwd->pw_unixdir) - 1;
10431         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
10432     }
10433     else
10434         strcpy(pwd->pw_unixdir, pwd->pw_dir);
10435     if (!decc_efs_case_preserve)
10436         __mystrtolower(pwd->pw_unixdir);
10437     return 1;
10438 }
10439
10440 /*
10441  * Get information for a named user.
10442 */
10443 /*{{{struct passwd *getpwnam(char *name)*/
10444 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
10445 {
10446     struct dsc$descriptor_s name_desc;
10447     union uicdef uic;
10448     unsigned long int status, sts;
10449
10450     __pwdcache = __passwd_empty;
10451     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
10452       /* We still may be able to determine pw_uid and pw_gid */
10453       name_desc.dsc$w_length=  strlen(name);
10454       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
10455       name_desc.dsc$b_class=   DSC$K_CLASS_S;
10456       name_desc.dsc$a_pointer= (char *) name;
10457       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
10458         __pwdcache.pw_uid= uic.uic$l_uic;
10459         __pwdcache.pw_gid= uic.uic$v_group;
10460       }
10461       else {
10462         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
10463           set_vaxc_errno(sts);
10464           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
10465           return NULL;
10466         }
10467         else { _ckvmssts(sts); }
10468       }
10469     }
10470     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
10471     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
10472     __pwdcache.pw_name= __pw_namecache;
10473     return &__pwdcache;
10474 }  /* end of my_getpwnam() */
10475 /*}}}*/
10476
10477 /*
10478  * Get information for a particular UIC or UID.
10479  * Called by my_getpwent with uid=-1 to list all users.
10480 */
10481 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
10482 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
10483 {
10484     const $DESCRIPTOR(name_desc,__pw_namecache);
10485     unsigned short lname;
10486     union uicdef uic;
10487     unsigned long int status;
10488
10489     if (uid == (unsigned int) -1) {
10490       do {
10491         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
10492         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
10493           set_vaxc_errno(status);
10494           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10495           my_endpwent();
10496           return NULL;
10497         }
10498         else { _ckvmssts(status); }
10499       } while (!valid_uic (uic));
10500     }
10501     else {
10502       uic.uic$l_uic= uid;
10503       if (!uic.uic$v_group)
10504         uic.uic$v_group= PerlProc_getgid();
10505       if (valid_uic(uic))
10506         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
10507       else status = SS$_IVIDENT;
10508       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
10509           status == RMS$_PRV) {
10510         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10511         return NULL;
10512       }
10513       else { _ckvmssts(status); }
10514     }
10515     __pw_namecache[lname]= '\0';
10516     __mystrtolower(__pw_namecache);
10517
10518     __pwdcache = __passwd_empty;
10519     __pwdcache.pw_name = __pw_namecache;
10520
10521 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
10522     The identifier's value is usually the UIC, but it doesn't have to be,
10523     so if we can, we let fillpasswd update this. */
10524     __pwdcache.pw_uid =  uic.uic$l_uic;
10525     __pwdcache.pw_gid =  uic.uic$v_group;
10526
10527     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
10528     return &__pwdcache;
10529
10530 }  /* end of my_getpwuid() */
10531 /*}}}*/
10532
10533 /*
10534  * Get information for next user.
10535 */
10536 /*{{{struct passwd *my_getpwent()*/
10537 struct passwd *Perl_my_getpwent(pTHX)
10538 {
10539     return (my_getpwuid((unsigned int) -1));
10540 }
10541 /*}}}*/
10542
10543 /*
10544  * Finish searching rights database for users.
10545 */
10546 /*{{{void my_endpwent()*/
10547 void Perl_my_endpwent(pTHX)
10548 {
10549     if (contxt) {
10550       _ckvmssts(sys$finish_rdb(&contxt));
10551       contxt= 0;
10552     }
10553 }
10554 /*}}}*/
10555
10556 #ifdef HOMEGROWN_POSIX_SIGNALS
10557   /* Signal handling routines, pulled into the core from POSIX.xs.
10558    *
10559    * We need these for threads, so they've been rolled into the core,
10560    * rather than left in POSIX.xs.
10561    *
10562    * (DRS, Oct 23, 1997)
10563    */
10564
10565   /* sigset_t is atomic under VMS, so these routines are easy */
10566 /*{{{int my_sigemptyset(sigset_t *) */
10567 int my_sigemptyset(sigset_t *set) {
10568     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10569     *set = 0; return 0;
10570 }
10571 /*}}}*/
10572
10573
10574 /*{{{int my_sigfillset(sigset_t *)*/
10575 int my_sigfillset(sigset_t *set) {
10576     int i;
10577     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10578     for (i = 0; i < NSIG; i++) *set |= (1 << i);
10579     return 0;
10580 }
10581 /*}}}*/
10582
10583
10584 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
10585 int my_sigaddset(sigset_t *set, int sig) {
10586     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10587     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10588     *set |= (1 << (sig - 1));
10589     return 0;
10590 }
10591 /*}}}*/
10592
10593
10594 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
10595 int my_sigdelset(sigset_t *set, int sig) {
10596     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10597     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10598     *set &= ~(1 << (sig - 1));
10599     return 0;
10600 }
10601 /*}}}*/
10602
10603
10604 /*{{{int my_sigismember(sigset_t *set, int sig)*/
10605 int my_sigismember(sigset_t *set, int sig) {
10606     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10607     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10608     return *set & (1 << (sig - 1));
10609 }
10610 /*}}}*/
10611
10612
10613 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10614 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10615     sigset_t tempmask;
10616
10617     /* If set and oset are both null, then things are badly wrong. Bail out. */
10618     if ((oset == NULL) && (set == NULL)) {
10619       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
10620       return -1;
10621     }
10622
10623     /* If set's null, then we're just handling a fetch. */
10624     if (set == NULL) {
10625         tempmask = sigblock(0);
10626     }
10627     else {
10628       switch (how) {
10629       case SIG_SETMASK:
10630         tempmask = sigsetmask(*set);
10631         break;
10632       case SIG_BLOCK:
10633         tempmask = sigblock(*set);
10634         break;
10635       case SIG_UNBLOCK:
10636         tempmask = sigblock(0);
10637         sigsetmask(*oset & ~tempmask);
10638         break;
10639       default:
10640         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10641         return -1;
10642       }
10643     }
10644
10645     /* Did they pass us an oset? If so, stick our holding mask into it */
10646     if (oset)
10647       *oset = tempmask;
10648
10649     return 0;
10650 }
10651 /*}}}*/
10652 #endif  /* HOMEGROWN_POSIX_SIGNALS */
10653
10654
10655 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
10656  * my_utime(), and flex_stat(), all of which operate on UTC unless
10657  * VMSISH_TIMES is true.
10658  */
10659 /* method used to handle UTC conversions:
10660  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
10661  */
10662 static int gmtime_emulation_type;
10663 /* number of secs to add to UTC POSIX-style time to get local time */
10664 static long int utc_offset_secs;
10665
10666 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
10667  * in vmsish.h.  #undef them here so we can call the CRTL routines
10668  * directly.
10669  */
10670 #undef gmtime
10671 #undef localtime
10672 #undef time
10673
10674
10675 /*
10676  * DEC C previous to 6.0 corrupts the behavior of the /prefix
10677  * qualifier with the extern prefix pragma.  This provisional
10678  * hack circumvents this prefix pragma problem in previous
10679  * precompilers.
10680  */
10681 #if defined(__VMS_VER) && __VMS_VER >= 70000000
10682 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
10683 #    pragma __extern_prefix save
10684 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
10685 #    define gmtime decc$__utctz_gmtime
10686 #    define localtime decc$__utctz_localtime
10687 #    define time decc$__utc_time
10688 #    pragma __extern_prefix restore
10689
10690      struct tm *gmtime(), *localtime();
10691
10692 #  endif
10693 #endif
10694
10695
10696 static time_t toutc_dst(time_t loc) {
10697   struct tm *rsltmp;
10698
10699   if ((rsltmp = localtime(&loc)) == NULL) return -1;
10700   loc -= utc_offset_secs;
10701   if (rsltmp->tm_isdst) loc -= 3600;
10702   return loc;
10703 }
10704 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10705        ((gmtime_emulation_type || my_time(NULL)), \
10706        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
10707        ((secs) - utc_offset_secs))))
10708
10709 static time_t toloc_dst(time_t utc) {
10710   struct tm *rsltmp;
10711
10712   utc += utc_offset_secs;
10713   if ((rsltmp = localtime(&utc)) == NULL) return -1;
10714   if (rsltmp->tm_isdst) utc += 3600;
10715   return utc;
10716 }
10717 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10718        ((gmtime_emulation_type || my_time(NULL)), \
10719        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
10720        ((secs) + utc_offset_secs))))
10721
10722 #ifndef RTL_USES_UTC
10723 /*
10724
10725     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
10726         DST starts on 1st sun of april      at 02:00  std time
10727             ends on last sun of october     at 02:00  dst time
10728     see the UCX management command reference, SET CONFIG TIMEZONE
10729     for formatting info.
10730
10731     No, it's not as general as it should be, but then again, NOTHING
10732     will handle UK times in a sensible way.
10733 */
10734
10735
10736 /*
10737     parse the DST start/end info:
10738     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
10739 */
10740
10741 static char *
10742 tz_parse_startend(char *s, struct tm *w, int *past)
10743 {
10744     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
10745     int ly, dozjd, d, m, n, hour, min, sec, j, k;
10746     time_t g;
10747
10748     if (!s)    return 0;
10749     if (!w) return 0;
10750     if (!past) return 0;
10751
10752     ly = 0;
10753     if (w->tm_year % 4        == 0) ly = 1;
10754     if (w->tm_year % 100      == 0) ly = 0;
10755     if (w->tm_year+1900 % 400 == 0) ly = 1;
10756     if (ly) dinm[1]++;
10757
10758     dozjd = isdigit(*s);
10759     if (*s == 'J' || *s == 'j' || dozjd) {
10760         if (!dozjd && !isdigit(*++s)) return 0;
10761         d = *s++ - '0';
10762         if (isdigit(*s)) {
10763             d = d*10 + *s++ - '0';
10764             if (isdigit(*s)) {
10765                 d = d*10 + *s++ - '0';
10766             }
10767         }
10768         if (d == 0) return 0;
10769         if (d > 366) return 0;
10770         d--;
10771         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
10772         g = d * 86400;
10773         dozjd = 1;
10774     } else if (*s == 'M' || *s == 'm') {
10775         if (!isdigit(*++s)) return 0;
10776         m = *s++ - '0';
10777         if (isdigit(*s)) m = 10*m + *s++ - '0';
10778         if (*s != '.') return 0;
10779         if (!isdigit(*++s)) return 0;
10780         n = *s++ - '0';
10781         if (n < 1 || n > 5) return 0;
10782         if (*s != '.') return 0;
10783         if (!isdigit(*++s)) return 0;
10784         d = *s++ - '0';
10785         if (d > 6) return 0;
10786     }
10787
10788     if (*s == '/') {
10789         if (!isdigit(*++s)) return 0;
10790         hour = *s++ - '0';
10791         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
10792         if (*s == ':') {
10793             if (!isdigit(*++s)) return 0;
10794             min = *s++ - '0';
10795             if (isdigit(*s)) min = 10*min + *s++ - '0';
10796             if (*s == ':') {
10797                 if (!isdigit(*++s)) return 0;
10798                 sec = *s++ - '0';
10799                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
10800             }
10801         }
10802     } else {
10803         hour = 2;
10804         min = 0;
10805         sec = 0;
10806     }
10807
10808     if (dozjd) {
10809         if (w->tm_yday < d) goto before;
10810         if (w->tm_yday > d) goto after;
10811     } else {
10812         if (w->tm_mon+1 < m) goto before;
10813         if (w->tm_mon+1 > m) goto after;
10814
10815         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
10816         k = d - j; /* mday of first d */
10817         if (k <= 0) k += 7;
10818         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
10819         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
10820         if (w->tm_mday < k) goto before;
10821         if (w->tm_mday > k) goto after;
10822     }
10823
10824     if (w->tm_hour < hour) goto before;
10825     if (w->tm_hour > hour) goto after;
10826     if (w->tm_min  < min)  goto before;
10827     if (w->tm_min  > min)  goto after;
10828     if (w->tm_sec  < sec)  goto before;
10829     goto after;
10830
10831 before:
10832     *past = 0;
10833     return s;
10834 after:
10835     *past = 1;
10836     return s;
10837 }
10838
10839
10840
10841
10842 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
10843
10844 static char *
10845 tz_parse_offset(char *s, int *offset)
10846 {
10847     int hour = 0, min = 0, sec = 0;
10848     int neg = 0;
10849     if (!s) return 0;
10850     if (!offset) return 0;
10851
10852     if (*s == '-') {neg++; s++;}
10853     if (*s == '+') s++;
10854     if (!isdigit(*s)) return 0;
10855     hour = *s++ - '0';
10856     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10857     if (hour > 24) return 0;
10858     if (*s == ':') {
10859         if (!isdigit(*++s)) return 0;
10860         min = *s++ - '0';
10861         if (isdigit(*s)) min = min*10 + (*s++ - '0');
10862         if (min > 59) return 0;
10863         if (*s == ':') {
10864             if (!isdigit(*++s)) return 0;
10865             sec = *s++ - '0';
10866             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10867             if (sec > 59) return 0;
10868         }
10869     }
10870
10871     *offset = (hour*60+min)*60 + sec;
10872     if (neg) *offset = -*offset;
10873     return s;
10874 }
10875
10876 /*
10877     input time is w, whatever type of time the CRTL localtime() uses.
10878     sets dst, the zone, and the gmtoff (seconds)
10879
10880     caches the value of TZ and UCX$TZ env variables; note that
10881     my_setenv looks for these and sets a flag if they're changed
10882     for efficiency.
10883
10884     We have to watch out for the "australian" case (dst starts in
10885     october, ends in april)...flagged by "reverse" and checked by
10886     scanning through the months of the previous year.
10887
10888 */
10889
10890 static int
10891 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
10892 {
10893     time_t when;
10894     struct tm *w2;
10895     char *s,*s2;
10896     char *dstzone, *tz, *s_start, *s_end;
10897     int std_off, dst_off, isdst;
10898     int y, dststart, dstend;
10899     static char envtz[1025];  /* longer than any logical, symbol, ... */
10900     static char ucxtz[1025];
10901     static char reversed = 0;
10902
10903     if (!w) return 0;
10904
10905     if (tz_updated) {
10906         tz_updated = 0;
10907         reversed = -1;  /* flag need to check  */
10908         envtz[0] = ucxtz[0] = '\0';
10909         tz = my_getenv("TZ",0);
10910         if (tz) strcpy(envtz, tz);
10911         tz = my_getenv("UCX$TZ",0);
10912         if (tz) strcpy(ucxtz, tz);
10913         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
10914     }
10915     tz = envtz;
10916     if (!*tz) tz = ucxtz;
10917
10918     s = tz;
10919     while (isalpha(*s)) s++;
10920     s = tz_parse_offset(s, &std_off);
10921     if (!s) return 0;
10922     if (!*s) {                  /* no DST, hurray we're done! */
10923         isdst = 0;
10924         goto done;
10925     }
10926
10927     dstzone = s;
10928     while (isalpha(*s)) s++;
10929     s2 = tz_parse_offset(s, &dst_off);
10930     if (s2) {
10931         s = s2;
10932     } else {
10933         dst_off = std_off - 3600;
10934     }
10935
10936     if (!*s) {      /* default dst start/end?? */
10937         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
10938             s = strchr(ucxtz,',');
10939         }
10940         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
10941     }
10942     if (*s != ',') return 0;
10943
10944     when = *w;
10945     when = _toutc(when);      /* convert to utc */
10946     when = when - std_off;    /* convert to pseudolocal time*/
10947
10948     w2 = localtime(&when);
10949     y = w2->tm_year;
10950     s_start = s+1;
10951     s = tz_parse_startend(s_start,w2,&dststart);
10952     if (!s) return 0;
10953     if (*s != ',') return 0;
10954
10955     when = *w;
10956     when = _toutc(when);      /* convert to utc */
10957     when = when - dst_off;    /* convert to pseudolocal time*/
10958     w2 = localtime(&when);
10959     if (w2->tm_year != y) {   /* spans a year, just check one time */
10960         when += dst_off - std_off;
10961         w2 = localtime(&when);
10962     }
10963     s_end = s+1;
10964     s = tz_parse_startend(s_end,w2,&dstend);
10965     if (!s) return 0;
10966
10967     if (reversed == -1) {  /* need to check if start later than end */
10968         int j, ds, de;
10969
10970         when = *w;
10971         if (when < 2*365*86400) {
10972             when += 2*365*86400;
10973         } else {
10974             when -= 365*86400;
10975         }
10976         w2 =localtime(&when);
10977         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
10978
10979         for (j = 0; j < 12; j++) {
10980             w2 =localtime(&when);
10981             tz_parse_startend(s_start,w2,&ds);
10982             tz_parse_startend(s_end,w2,&de);
10983             if (ds != de) break;
10984             when += 30*86400;
10985         }
10986         reversed = 0;
10987         if (de && !ds) reversed = 1;
10988     }
10989
10990     isdst = dststart && !dstend;
10991     if (reversed) isdst = dststart  || !dstend;
10992
10993 done:
10994     if (dst)    *dst = isdst;
10995     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
10996     if (isdst)  tz = dstzone;
10997     if (zone) {
10998         while(isalpha(*tz))  *zone++ = *tz++;
10999         *zone = '\0';
11000     }
11001     return 1;
11002 }
11003
11004 #endif /* !RTL_USES_UTC */
11005
11006 /* my_time(), my_localtime(), my_gmtime()
11007  * By default traffic in UTC time values, using CRTL gmtime() or
11008  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11009  * Note: We need to use these functions even when the CRTL has working
11010  * UTC support, since they also handle C<use vmsish qw(times);>
11011  *
11012  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
11013  * Modified by Charles Bailey <bailey@newman.upenn.edu>
11014  */
11015
11016 /*{{{time_t my_time(time_t *timep)*/
11017 time_t Perl_my_time(pTHX_ time_t *timep)
11018 {
11019   time_t when;
11020   struct tm *tm_p;
11021
11022   if (gmtime_emulation_type == 0) {
11023     int dstnow;
11024     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
11025                               /* results of calls to gmtime() and localtime() */
11026                               /* for same &base */
11027
11028     gmtime_emulation_type++;
11029     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11030       char off[LNM$C_NAMLENGTH+1];;
11031
11032       gmtime_emulation_type++;
11033       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11034         gmtime_emulation_type++;
11035         utc_offset_secs = 0;
11036         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11037       }
11038       else { utc_offset_secs = atol(off); }
11039     }
11040     else { /* We've got a working gmtime() */
11041       struct tm gmt, local;
11042
11043       gmt = *tm_p;
11044       tm_p = localtime(&base);
11045       local = *tm_p;
11046       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
11047       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11048       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
11049       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
11050     }
11051   }
11052
11053   when = time(NULL);
11054 # ifdef VMSISH_TIME
11055 # ifdef RTL_USES_UTC
11056   if (VMSISH_TIME) when = _toloc(when);
11057 # else
11058   if (!VMSISH_TIME) when = _toutc(when);
11059 # endif
11060 # endif
11061   if (timep != NULL) *timep = when;
11062   return when;
11063
11064 }  /* end of my_time() */
11065 /*}}}*/
11066
11067
11068 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11069 struct tm *
11070 Perl_my_gmtime(pTHX_ const time_t *timep)
11071 {
11072   char *p;
11073   time_t when;
11074   struct tm *rsltmp;
11075
11076   if (timep == NULL) {
11077     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11078     return NULL;
11079   }
11080   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11081
11082   when = *timep;
11083 # ifdef VMSISH_TIME
11084   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11085 #  endif
11086 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
11087   return gmtime(&when);
11088 # else
11089   /* CRTL localtime() wants local time as input, so does no tz correction */
11090   rsltmp = localtime(&when);
11091   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
11092   return rsltmp;
11093 #endif
11094 }  /* end of my_gmtime() */
11095 /*}}}*/
11096
11097
11098 /*{{{struct tm *my_localtime(const time_t *timep)*/
11099 struct tm *
11100 Perl_my_localtime(pTHX_ const time_t *timep)
11101 {
11102   time_t when, whenutc;
11103   struct tm *rsltmp;
11104   int dst, offset;
11105
11106   if (timep == NULL) {
11107     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11108     return NULL;
11109   }
11110   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11111   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11112
11113   when = *timep;
11114 # ifdef RTL_USES_UTC
11115 # ifdef VMSISH_TIME
11116   if (VMSISH_TIME) when = _toutc(when);
11117 # endif
11118   /* CRTL localtime() wants UTC as input, does tz correction itself */
11119   return localtime(&when);
11120
11121 # else /* !RTL_USES_UTC */
11122   whenutc = when;
11123 # ifdef VMSISH_TIME
11124   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
11125   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
11126 # endif
11127   dst = -1;
11128 #ifndef RTL_USES_UTC
11129   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
11130       when = whenutc - offset;                   /* pseudolocal time*/
11131   }
11132 # endif
11133   /* CRTL localtime() wants local time as input, so does no tz correction */
11134   rsltmp = localtime(&when);
11135   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
11136   return rsltmp;
11137 # endif
11138
11139 } /*  end of my_localtime() */
11140 /*}}}*/
11141
11142 /* Reset definitions for later calls */
11143 #define gmtime(t)    my_gmtime(t)
11144 #define localtime(t) my_localtime(t)
11145 #define time(t)      my_time(t)
11146
11147
11148 /* my_utime - update modification/access time of a file
11149  *
11150  * VMS 7.3 and later implementation
11151  * Only the UTC translation is home-grown. The rest is handled by the
11152  * CRTL utime(), which will take into account the relevant feature
11153  * logicals and ODS-5 volume characteristics for true access times.
11154  *
11155  * pre VMS 7.3 implementation:
11156  * The calling sequence is identical to POSIX utime(), but under
11157  * VMS with ODS-2, only the modification time is changed; ODS-2 does
11158  * not maintain access times.  Restrictions differ from the POSIX
11159  * definition in that the time can be changed as long as the
11160  * caller has permission to execute the necessary IO$_MODIFY $QIO;
11161  * no separate checks are made to insure that the caller is the
11162  * owner of the file or has special privs enabled.
11163  * Code here is based on Joe Meadows' FILE utility.
11164  *
11165  */
11166
11167 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11168  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
11169  * in 100 ns intervals.
11170  */
11171 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11172
11173 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11174 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11175 {
11176 #if __CRTL_VER >= 70300000
11177   struct utimbuf utc_utimes, *utc_utimesp;
11178
11179   if (utimes != NULL) {
11180     utc_utimes.actime = utimes->actime;
11181     utc_utimes.modtime = utimes->modtime;
11182 # ifdef VMSISH_TIME
11183     /* If input was local; convert to UTC for sys svc */
11184     if (VMSISH_TIME) {
11185       utc_utimes.actime = _toutc(utimes->actime);
11186       utc_utimes.modtime = _toutc(utimes->modtime);
11187     }
11188 # endif
11189     utc_utimesp = &utc_utimes;
11190   }
11191   else {
11192     utc_utimesp = NULL;
11193   }
11194
11195   return utime(file, utc_utimesp);
11196
11197 #else /* __CRTL_VER < 70300000 */
11198
11199   register int i;
11200   int sts;
11201   long int bintime[2], len = 2, lowbit, unixtime,
11202            secscale = 10000000; /* seconds --> 100 ns intervals */
11203   unsigned long int chan, iosb[2], retsts;
11204   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11205   struct FAB myfab = cc$rms_fab;
11206   struct NAM mynam = cc$rms_nam;
11207 #if defined (__DECC) && defined (__VAX)
11208   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11209    * at least through VMS V6.1, which causes a type-conversion warning.
11210    */
11211 #  pragma message save
11212 #  pragma message disable cvtdiftypes
11213 #endif
11214   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11215   struct fibdef myfib;
11216 #if defined (__DECC) && defined (__VAX)
11217   /* This should be right after the declaration of myatr, but due
11218    * to a bug in VAX DEC C, this takes effect a statement early.
11219    */
11220 #  pragma message restore
11221 #endif
11222   /* cast ok for read only parameter */
11223   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11224                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11225                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
11226
11227   if (file == NULL || *file == '\0') {
11228     SETERRNO(ENOENT, LIB$_INVARG);
11229     return -1;
11230   }
11231
11232   /* Convert to VMS format ensuring that it will fit in 255 characters */
11233   if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
11234       SETERRNO(ENOENT, LIB$_INVARG);
11235       return -1;
11236   }
11237   if (utimes != NULL) {
11238     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
11239      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11240      * Since time_t is unsigned long int, and lib$emul takes a signed long int
11241      * as input, we force the sign bit to be clear by shifting unixtime right
11242      * one bit, then multiplying by an extra factor of 2 in lib$emul().
11243      */
11244     lowbit = (utimes->modtime & 1) ? secscale : 0;
11245     unixtime = (long int) utimes->modtime;
11246 #   ifdef VMSISH_TIME
11247     /* If input was UTC; convert to local for sys svc */
11248     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
11249 #   endif
11250     unixtime >>= 1;  secscale <<= 1;
11251     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11252     if (!(retsts & 1)) {
11253       SETERRNO(EVMSERR, retsts);
11254       return -1;
11255     }
11256     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11257     if (!(retsts & 1)) {
11258       SETERRNO(EVMSERR, retsts);
11259       return -1;
11260     }
11261   }
11262   else {
11263     /* Just get the current time in VMS format directly */
11264     retsts = sys$gettim(bintime);
11265     if (!(retsts & 1)) {
11266       SETERRNO(EVMSERR, retsts);
11267       return -1;
11268     }
11269   }
11270
11271   myfab.fab$l_fna = vmsspec;
11272   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11273   myfab.fab$l_nam = &mynam;
11274   mynam.nam$l_esa = esa;
11275   mynam.nam$b_ess = (unsigned char) sizeof esa;
11276   mynam.nam$l_rsa = rsa;
11277   mynam.nam$b_rss = (unsigned char) sizeof rsa;
11278   if (decc_efs_case_preserve)
11279       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
11280
11281   /* Look for the file to be affected, letting RMS parse the file
11282    * specification for us as well.  I have set errno using only
11283    * values documented in the utime() man page for VMS POSIX.
11284    */
11285   retsts = sys$parse(&myfab,0,0);
11286   if (!(retsts & 1)) {
11287     set_vaxc_errno(retsts);
11288     if      (retsts == RMS$_PRV) set_errno(EACCES);
11289     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11290     else                         set_errno(EVMSERR);
11291     return -1;
11292   }
11293   retsts = sys$search(&myfab,0,0);
11294   if (!(retsts & 1)) {
11295     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11296     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11297     set_vaxc_errno(retsts);
11298     if      (retsts == RMS$_PRV) set_errno(EACCES);
11299     else if (retsts == RMS$_FNF) set_errno(ENOENT);
11300     else                         set_errno(EVMSERR);
11301     return -1;
11302   }
11303
11304   devdsc.dsc$w_length = mynam.nam$b_dev;
11305   /* cast ok for read only parameter */
11306   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11307
11308   retsts = sys$assign(&devdsc,&chan,0,0);
11309   if (!(retsts & 1)) {
11310     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11311     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11312     set_vaxc_errno(retsts);
11313     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
11314     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
11315     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
11316     else                               set_errno(EVMSERR);
11317     return -1;
11318   }
11319
11320   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11321   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11322
11323   memset((void *) &myfib, 0, sizeof myfib);
11324 #if defined(__DECC) || defined(__DECCXX)
11325   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11326   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11327   /* This prevents the revision time of the file being reset to the current
11328    * time as a result of our IO$_MODIFY $QIO. */
11329   myfib.fib$l_acctl = FIB$M_NORECORD;
11330 #else
11331   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11332   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11333   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11334 #endif
11335   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
11336   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11337   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11338   _ckvmssts(sys$dassgn(chan));
11339   if (retsts & 1) retsts = iosb[0];
11340   if (!(retsts & 1)) {
11341     set_vaxc_errno(retsts);
11342     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11343     else                      set_errno(EVMSERR);
11344     return -1;
11345   }
11346
11347   return 0;
11348
11349 #endif /* #if __CRTL_VER >= 70300000 */
11350
11351 }  /* end of my_utime() */
11352 /*}}}*/
11353
11354 /*
11355  * flex_stat, flex_lstat, flex_fstat
11356  * basic stat, but gets it right when asked to stat
11357  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11358  */
11359
11360 #ifndef _USE_STD_STAT
11361 /* encode_dev packs a VMS device name string into an integer to allow
11362  * simple comparisons. This can be used, for example, to check whether two
11363  * files are located on the same device, by comparing their encoded device
11364  * names. Even a string comparison would not do, because stat() reuses the
11365  * device name buffer for each call; so without encode_dev, it would be
11366  * necessary to save the buffer and use strcmp (this would mean a number of
11367  * changes to the standard Perl code, to say nothing of what a Perl script
11368  * would have to do.
11369  *
11370  * The device lock id, if it exists, should be unique (unless perhaps compared
11371  * with lock ids transferred from other nodes). We have a lock id if the disk is
11372  * mounted cluster-wide, which is when we tend to get long (host-qualified)
11373  * device names. Thus we use the lock id in preference, and only if that isn't
11374  * available, do we try to pack the device name into an integer (flagged by
11375  * the sign bit (LOCKID_MASK) being set).
11376  *
11377  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11378  * name and its encoded form, but it seems very unlikely that we will find
11379  * two files on different disks that share the same encoded device names,
11380  * and even more remote that they will share the same file id (if the test
11381  * is to check for the same file).
11382  *
11383  * A better method might be to use sys$device_scan on the first call, and to
11384  * search for the device, returning an index into the cached array.
11385  * The number returned would be more intelligible.
11386  * This is probably not worth it, and anyway would take quite a bit longer
11387  * on the first call.
11388  */
11389 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
11390 static mydev_t encode_dev (pTHX_ const char *dev)
11391 {
11392   int i;
11393   unsigned long int f;
11394   mydev_t enc;
11395   char c;
11396   const char *q;
11397
11398   if (!dev || !dev[0]) return 0;
11399
11400 #if LOCKID_MASK
11401   {
11402     struct dsc$descriptor_s dev_desc;
11403     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11404
11405     /* For cluster-mounted disks, the disk lock identifier is unique, so we
11406        can try that first. */
11407     dev_desc.dsc$w_length =  strlen (dev);
11408     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
11409     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
11410     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
11411     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11412     if (!$VMS_STATUS_SUCCESS(status)) {
11413       switch (status) {
11414         case SS$_NOSUCHDEV:
11415           SETERRNO(ENODEV, status);
11416           return 0;
11417         default:
11418           _ckvmssts(status);
11419       }
11420     }
11421     if (lockid) return (lockid & ~LOCKID_MASK);
11422   }
11423 #endif
11424
11425   /* Otherwise we try to encode the device name */
11426   enc = 0;
11427   f = 1;
11428   i = 0;
11429   for (q = dev + strlen(dev); q--; q >= dev) {
11430     if (*q == ':')
11431         break;
11432     if (isdigit (*q))
11433       c= (*q) - '0';
11434     else if (isalpha (toupper (*q)))
11435       c= toupper (*q) - 'A' + (char)10;
11436     else
11437       continue; /* Skip '$'s */
11438     i++;
11439     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
11440     if (i>1) f *= 36;
11441     enc += f * (unsigned long int) c;
11442   }
11443   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
11444
11445 }  /* end of encode_dev() */
11446 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11447         device_no = encode_dev(aTHX_ devname)
11448 #else
11449 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11450         device_no = new_dev_no
11451 #endif
11452
11453 static int
11454 is_null_device(name)
11455     const char *name;
11456 {
11457   if (decc_bug_devnull != 0) {
11458     if (strncmp("/dev/null", name, 9) == 0)
11459       return 1;
11460   }
11461     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11462        The underscore prefix, controller letter, and unit number are
11463        independently optional; for our purposes, the colon punctuation
11464        is not.  The colon can be trailed by optional directory and/or
11465        filename, but two consecutive colons indicates a nodename rather
11466        than a device.  [pr]  */
11467   if (*name == '_') ++name;
11468   if (tolower(*name++) != 'n') return 0;
11469   if (tolower(*name++) != 'l') return 0;
11470   if (tolower(*name) == 'a') ++name;
11471   if (*name == '0') ++name;
11472   return (*name++ == ':') && (*name != ':');
11473 }
11474
11475
11476 static I32
11477 Perl_cando_by_name_int
11478    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
11479 {
11480   char usrname[L_cuserid];
11481   struct dsc$descriptor_s usrdsc =
11482          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11483   char *vmsname = NULL, *fileified = NULL;
11484   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11485   unsigned short int retlen, trnlnm_iter_count;
11486   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11487   union prvdef curprv;
11488   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11489          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11490          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11491   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11492          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11493          {0,0,0,0}};
11494   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11495          {0,0,0,0}};
11496   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11497   Stat_t st;
11498   static int profile_context = -1;
11499
11500   if (!fname || !*fname) return FALSE;
11501
11502   /* Make sure we expand logical names, since sys$check_access doesn't */
11503   fileified = PerlMem_malloc(VMS_MAXRSS);
11504   if (fileified == NULL) _ckvmssts(SS$_INSFMEM);
11505   if (!strpbrk(fname,"/]>:")) {
11506       strcpy(fileified,fname);
11507       trnlnm_iter_count = 0;
11508       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11509         trnlnm_iter_count++;
11510         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11511       }
11512       fname = fileified;
11513   }
11514
11515   vmsname = PerlMem_malloc(VMS_MAXRSS);
11516   if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
11517   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11518     /* Don't know if already in VMS format, so make sure */
11519     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11520       PerlMem_free(fileified);
11521       PerlMem_free(vmsname);
11522       return FALSE;
11523     }
11524   }
11525   else {
11526     strcpy(vmsname,fname);
11527   }
11528
11529   /* sys$check_access needs a file spec, not a directory spec.
11530    * Don't use flex_stat here, as that depends on thread context
11531    * having been initialized, and we may get here during startup.
11532    */
11533
11534   retlen = namdsc.dsc$w_length = strlen(vmsname);
11535   if (vmsname[retlen-1] == ']'
11536       || vmsname[retlen-1] == '>'
11537       || vmsname[retlen-1] == ':'
11538       || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
11539
11540       if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) {
11541         PerlMem_free(fileified);
11542         PerlMem_free(vmsname);
11543         return FALSE;
11544       }
11545       fname = fileified;
11546   }
11547   else {
11548       fname = vmsname;
11549   }
11550
11551   retlen = namdsc.dsc$w_length = strlen(fname);
11552   namdsc.dsc$a_pointer = (char *)fname;
11553
11554   switch (bit) {
11555     case S_IXUSR: case S_IXGRP: case S_IXOTH:
11556       access = ARM$M_EXECUTE;
11557       flags = CHP$M_READ;
11558       break;
11559     case S_IRUSR: case S_IRGRP: case S_IROTH:
11560       access = ARM$M_READ;
11561       flags = CHP$M_READ | CHP$M_USEREADALL;
11562       break;
11563     case S_IWUSR: case S_IWGRP: case S_IWOTH:
11564       access = ARM$M_WRITE;
11565       flags = CHP$M_READ | CHP$M_WRITE;
11566       break;
11567     case S_IDUSR: case S_IDGRP: case S_IDOTH:
11568       access = ARM$M_DELETE;
11569       flags = CHP$M_READ | CHP$M_WRITE;
11570       break;
11571     default:
11572       if (fileified != NULL)
11573         PerlMem_free(fileified);
11574       if (vmsname != NULL)
11575         PerlMem_free(vmsname);
11576       return FALSE;
11577   }
11578
11579   /* Before we call $check_access, create a user profile with the current
11580    * process privs since otherwise it just uses the default privs from the
11581    * UAF and might give false positives or negatives.  This only works on
11582    * VMS versions v6.0 and later since that's when sys$create_user_profile
11583    * became available.
11584    */
11585
11586   /* get current process privs and username */
11587   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11588   _ckvmssts(iosb[0]);
11589
11590 #if defined(__VMS_VER) && __VMS_VER >= 60000000
11591
11592   /* find out the space required for the profile */
11593   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11594                                     &usrprodsc.dsc$w_length,&profile_context));
11595
11596   /* allocate space for the profile and get it filled in */
11597   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11598   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
11599   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11600                                     &usrprodsc.dsc$w_length,&profile_context));
11601
11602   /* use the profile to check access to the file; free profile & analyze results */
11603   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
11604   PerlMem_free(usrprodsc.dsc$a_pointer);
11605   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11606
11607 #else
11608
11609   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11610
11611 #endif
11612
11613   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
11614       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11615       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11616     set_vaxc_errno(retsts);
11617     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11618     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11619     else set_errno(ENOENT);
11620     if (fileified != NULL)
11621       PerlMem_free(fileified);
11622     if (vmsname != NULL)
11623       PerlMem_free(vmsname);
11624     return FALSE;
11625   }
11626   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11627     if (fileified != NULL)
11628       PerlMem_free(fileified);
11629     if (vmsname != NULL)
11630       PerlMem_free(vmsname);
11631     return TRUE;
11632   }
11633   _ckvmssts(retsts);
11634
11635   if (fileified != NULL)
11636     PerlMem_free(fileified);
11637   if (vmsname != NULL)
11638     PerlMem_free(vmsname);
11639   return FALSE;  /* Should never get here */
11640
11641 }
11642
11643 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
11644 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11645  * subset of the applicable information.
11646  */
11647 bool
11648 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11649 {
11650   return cando_by_name_int
11651         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11652 }  /* end of cando() */
11653 /*}}}*/
11654
11655
11656 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11657 I32
11658 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11659 {
11660    return cando_by_name_int(bit, effective, fname, 0);
11661
11662 }  /* end of cando_by_name() */
11663 /*}}}*/
11664
11665
11666 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
11667 int
11668 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
11669 {
11670   if (!fstat(fd,(stat_t *) statbufp)) {
11671     char *cptr;
11672     char *vms_filename;
11673     vms_filename = PerlMem_malloc(VMS_MAXRSS);
11674     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
11675
11676     /* Save name for cando by name in VMS format */
11677     cptr = getname(fd, vms_filename, 1);
11678
11679     /* This should not happen, but just in case */
11680     if (cptr == NULL) {
11681         statbufp->st_devnam[0] = 0;
11682     }
11683     else {
11684         /* Make sure that the saved name fits in 255 characters */
11685         cptr = do_rmsexpand
11686                        (vms_filename,
11687                         statbufp->st_devnam,
11688                         0,
11689                         NULL,
11690                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
11691                         NULL,
11692                         NULL);
11693         if (cptr == NULL)
11694             statbufp->st_devnam[0] = 0;
11695     }
11696     PerlMem_free(vms_filename);
11697
11698     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11699     VMS_DEVICE_ENCODE
11700         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11701
11702 #   ifdef RTL_USES_UTC
11703 #   ifdef VMSISH_TIME
11704     if (VMSISH_TIME) {
11705       statbufp->st_mtime = _toloc(statbufp->st_mtime);
11706       statbufp->st_atime = _toloc(statbufp->st_atime);
11707       statbufp->st_ctime = _toloc(statbufp->st_ctime);
11708     }
11709 #   endif
11710 #   else
11711 #   ifdef VMSISH_TIME
11712     if (!VMSISH_TIME) { /* Return UTC instead of local time */
11713 #   else
11714     if (1) {
11715 #   endif
11716       statbufp->st_mtime = _toutc(statbufp->st_mtime);
11717       statbufp->st_atime = _toutc(statbufp->st_atime);
11718       statbufp->st_ctime = _toutc(statbufp->st_ctime);
11719     }
11720 #endif
11721     return 0;
11722   }
11723   return -1;
11724
11725 }  /* end of flex_fstat() */
11726 /*}}}*/
11727
11728 #if !defined(__VAX) && __CRTL_VER >= 80200000
11729 #ifdef lstat
11730 #undef lstat
11731 #endif
11732 #else
11733 #ifdef lstat
11734 #undef lstat
11735 #endif
11736 #define lstat(_x, _y) stat(_x, _y)
11737 #endif
11738
11739 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11740
11741 static int
11742 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
11743 {
11744     char fileified[VMS_MAXRSS];
11745     char temp_fspec[VMS_MAXRSS];
11746     char *save_spec;
11747     int retval = -1;
11748     int saved_errno, saved_vaxc_errno;
11749
11750     if (!fspec) return retval;
11751     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
11752     strcpy(temp_fspec, fspec);
11753
11754     if (decc_bug_devnull != 0) {
11755       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
11756         memset(statbufp,0,sizeof *statbufp);
11757         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
11758         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
11759         statbufp->st_uid = 0x00010001;
11760         statbufp->st_gid = 0x0001;
11761         time((time_t *)&statbufp->st_mtime);
11762         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
11763         return 0;
11764       }
11765     }
11766
11767     /* Try for a directory name first.  If fspec contains a filename without
11768      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
11769      * and sea:[wine.dark]water. exist, we prefer the directory here.
11770      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
11771      * not sea:[wine.dark]., if the latter exists.  If the intended target is
11772      * the file with null type, specify this by calling flex_stat() with
11773      * a '.' at the end of fspec.
11774      *
11775      * If we are in Posix filespec mode, accept the filename as is.
11776      */
11777
11778
11779 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11780   /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
11781    * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
11782    */
11783   if (!decc_efs_charset)
11784     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
11785 #endif
11786
11787 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11788   if (decc_posix_compliant_pathnames == 0) {
11789 #endif
11790     if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
11791       if (lstat_flag == 0)
11792         retval = stat(fileified,(stat_t *) statbufp);
11793       else
11794         retval = lstat(fileified,(stat_t *) statbufp);
11795       save_spec = fileified;
11796     }
11797     if (retval) {
11798       if (lstat_flag == 0)
11799         retval = stat(temp_fspec,(stat_t *) statbufp);
11800       else
11801         retval = lstat(temp_fspec,(stat_t *) statbufp);
11802       save_spec = temp_fspec;
11803     }
11804 /*
11805  * In debugging, on 8.3 Alpha, I found a case where stat was returning a
11806  * file not found error for a directory named foo:[bar.t] or /foo/bar/t
11807  * and lstat was working correctly for the same file.
11808  * The only syntax that was working for stat was "foo:[bar]t.dir".
11809  *
11810  * Other directories with the same syntax worked fine.
11811  * So work around the problem when it shows up here.
11812  */
11813     if (retval) {
11814         int save_errno = errno;
11815         if (do_tovmsspec(fspec, temp_fspec, 0, NULL) != NULL) {
11816             if (do_fileify_dirspec(temp_fspec, fileified, 0, NULL) != NULL) {
11817                 retval = stat(fileified, (stat_t *) statbufp);
11818                 save_spec = fileified;
11819             }
11820         }
11821         /* Restore the errno value if third stat does not succeed */
11822         if (retval != 0)
11823             errno = save_errno;
11824     }
11825 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11826   } else {
11827     if (lstat_flag == 0)
11828       retval = stat(temp_fspec,(stat_t *) statbufp);
11829     else
11830       retval = lstat(temp_fspec,(stat_t *) statbufp);
11831       save_spec = temp_fspec;
11832   }
11833 #endif
11834
11835 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11836   /* As you were... */
11837   if (!decc_efs_charset)
11838     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
11839 #endif
11840
11841     if (!retval) {
11842     char * cptr;
11843       cptr = do_rmsexpand
11844        (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
11845       if (cptr == NULL)
11846         statbufp->st_devnam[0] = 0;
11847
11848       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11849       VMS_DEVICE_ENCODE
11850         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11851 #     ifdef RTL_USES_UTC
11852 #     ifdef VMSISH_TIME
11853       if (VMSISH_TIME) {
11854         statbufp->st_mtime = _toloc(statbufp->st_mtime);
11855         statbufp->st_atime = _toloc(statbufp->st_atime);
11856         statbufp->st_ctime = _toloc(statbufp->st_ctime);
11857       }
11858 #     endif
11859 #     else
11860 #     ifdef VMSISH_TIME
11861       if (!VMSISH_TIME) { /* Return UTC instead of local time */
11862 #     else
11863       if (1) {
11864 #     endif
11865         statbufp->st_mtime = _toutc(statbufp->st_mtime);
11866         statbufp->st_atime = _toutc(statbufp->st_atime);
11867         statbufp->st_ctime = _toutc(statbufp->st_ctime);
11868       }
11869 #     endif
11870     }
11871     /* If we were successful, leave errno where we found it */
11872     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
11873     return retval;
11874
11875 }  /* end of flex_stat_int() */
11876
11877
11878 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
11879 int
11880 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
11881 {
11882    return flex_stat_int(fspec, statbufp, 0);
11883 }
11884 /*}}}*/
11885
11886 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
11887 int
11888 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
11889 {
11890    return flex_stat_int(fspec, statbufp, 1);
11891 }
11892 /*}}}*/
11893
11894
11895 /*{{{char *my_getlogin()*/
11896 /* VMS cuserid == Unix getlogin, except calling sequence */
11897 char *
11898 my_getlogin(void)
11899 {
11900     static char user[L_cuserid];
11901     return cuserid(user);
11902 }
11903 /*}}}*/
11904
11905
11906 /*  rmscopy - copy a file using VMS RMS routines
11907  *
11908  *  Copies contents and attributes of spec_in to spec_out, except owner
11909  *  and protection information.  Name and type of spec_in are used as
11910  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
11911  *  should try to propagate timestamps from the input file to the output file.
11912  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
11913  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
11914  *  propagated to the output file at creation iff the output file specification
11915  *  did not contain an explicit name or type, and the revision date is always
11916  *  updated at the end of the copy operation.  If it is greater than 0, then
11917  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
11918  *  other than the revision date should be propagated, and bit 1 indicates
11919  *  that the revision date should be propagated.
11920  *
11921  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
11922  *
11923  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
11924  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
11925  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
11926  * as part of the Perl standard distribution under the terms of the
11927  * GNU General Public License or the Perl Artistic License.  Copies
11928  * of each may be found in the Perl standard distribution.
11929  */ /* FIXME */
11930 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
11931 int
11932 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
11933 {
11934     char *vmsin, * vmsout, *esa, *esa_out,
11935          *rsa, *ubf;
11936     unsigned long int i, sts, sts2;
11937     int dna_len;
11938     struct FAB fab_in, fab_out;
11939     struct RAB rab_in, rab_out;
11940     rms_setup_nam(nam);
11941     rms_setup_nam(nam_out);
11942     struct XABDAT xabdat;
11943     struct XABFHC xabfhc;
11944     struct XABRDT xabrdt;
11945     struct XABSUM xabsum;
11946
11947     vmsin = PerlMem_malloc(VMS_MAXRSS);
11948     if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
11949     vmsout = PerlMem_malloc(VMS_MAXRSS);
11950     if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
11951     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
11952         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
11953       PerlMem_free(vmsin);
11954       PerlMem_free(vmsout);
11955       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11956       return 0;
11957     }
11958
11959     esa = PerlMem_malloc(VMS_MAXRSS);
11960     if (esa == NULL) _ckvmssts(SS$_INSFMEM);
11961     fab_in = cc$rms_fab;
11962     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
11963     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
11964     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
11965     fab_in.fab$l_fop = FAB$M_SQO;
11966     rms_bind_fab_nam(fab_in, nam);
11967     fab_in.fab$l_xab = (void *) &xabdat;
11968
11969     rsa = PerlMem_malloc(VMS_MAXRSS);
11970     if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
11971     rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
11972     rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
11973     rms_nam_esl(nam) = 0;
11974     rms_nam_rsl(nam) = 0;
11975     rms_nam_esll(nam) = 0;
11976     rms_nam_rsll(nam) = 0;
11977 #ifdef NAM$M_NO_SHORT_UPCASE
11978     if (decc_efs_case_preserve)
11979         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
11980 #endif
11981
11982     xabdat = cc$rms_xabdat;        /* To get creation date */
11983     xabdat.xab$l_nxt = (void *) &xabfhc;
11984
11985     xabfhc = cc$rms_xabfhc;        /* To get record length */
11986     xabfhc.xab$l_nxt = (void *) &xabsum;
11987
11988     xabsum = cc$rms_xabsum;        /* To get key and area information */
11989
11990     if (!((sts = sys$open(&fab_in)) & 1)) {
11991       PerlMem_free(vmsin);
11992       PerlMem_free(vmsout);
11993       PerlMem_free(esa);
11994       PerlMem_free(rsa);
11995       set_vaxc_errno(sts);
11996       switch (sts) {
11997         case RMS$_FNF: case RMS$_DNF:
11998           set_errno(ENOENT); break;
11999         case RMS$_DIR:
12000           set_errno(ENOTDIR); break;
12001         case RMS$_DEV:
12002           set_errno(ENODEV); break;
12003         case RMS$_SYN:
12004           set_errno(EINVAL); break;
12005         case RMS$_PRV:
12006           set_errno(EACCES); break;
12007         default:
12008           set_errno(EVMSERR);
12009       }
12010       return 0;
12011     }
12012
12013     nam_out = nam;
12014     fab_out = fab_in;
12015     fab_out.fab$w_ifi = 0;
12016     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12017     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12018     fab_out.fab$l_fop = FAB$M_SQO;
12019     rms_bind_fab_nam(fab_out, nam_out);
12020     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12021     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12022     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12023     esa_out = PerlMem_malloc(VMS_MAXRSS);
12024     if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
12025     rms_set_rsa(nam_out, NULL, 0);
12026     rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
12027
12028     if (preserve_dates == 0) {  /* Act like DCL COPY */
12029       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12030       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
12031       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12032         PerlMem_free(vmsin);
12033         PerlMem_free(vmsout);
12034         PerlMem_free(esa);
12035         PerlMem_free(rsa);
12036         PerlMem_free(esa_out);
12037         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12038         set_vaxc_errno(sts);
12039         return 0;
12040       }
12041       fab_out.fab$l_xab = (void *) &xabdat;
12042       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12043         preserve_dates = 1;
12044     }
12045     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
12046       preserve_dates =0;      /* bitmask from this point forward   */
12047
12048     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12049     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12050       PerlMem_free(vmsin);
12051       PerlMem_free(vmsout);
12052       PerlMem_free(esa);
12053       PerlMem_free(rsa);
12054       PerlMem_free(esa_out);
12055       set_vaxc_errno(sts);
12056       switch (sts) {
12057         case RMS$_DNF:
12058           set_errno(ENOENT); break;
12059         case RMS$_DIR:
12060           set_errno(ENOTDIR); break;
12061         case RMS$_DEV:
12062           set_errno(ENODEV); break;
12063         case RMS$_SYN:
12064           set_errno(EINVAL); break;
12065         case RMS$_PRV:
12066           set_errno(EACCES); break;
12067         default:
12068           set_errno(EVMSERR);
12069       }
12070       return 0;
12071     }
12072     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
12073     if (preserve_dates & 2) {
12074       /* sys$close() will process xabrdt, not xabdat */
12075       xabrdt = cc$rms_xabrdt;
12076 #ifndef __GNUC__
12077       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12078 #else
12079       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12080        * is unsigned long[2], while DECC & VAXC use a struct */
12081       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12082 #endif
12083       fab_out.fab$l_xab = (void *) &xabrdt;
12084     }
12085
12086     ubf = PerlMem_malloc(32256);
12087     if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
12088     rab_in = cc$rms_rab;
12089     rab_in.rab$l_fab = &fab_in;
12090     rab_in.rab$l_rop = RAB$M_BIO;
12091     rab_in.rab$l_ubf = ubf;
12092     rab_in.rab$w_usz = 32256;
12093     if (!((sts = sys$connect(&rab_in)) & 1)) {
12094       sys$close(&fab_in); sys$close(&fab_out);
12095       PerlMem_free(vmsin);
12096       PerlMem_free(vmsout);
12097       PerlMem_free(esa);
12098       PerlMem_free(ubf);
12099       PerlMem_free(rsa);
12100       PerlMem_free(esa_out);
12101       set_errno(EVMSERR); set_vaxc_errno(sts);
12102       return 0;
12103     }
12104
12105     rab_out = cc$rms_rab;
12106     rab_out.rab$l_fab = &fab_out;
12107     rab_out.rab$l_rbf = ubf;
12108     if (!((sts = sys$connect(&rab_out)) & 1)) {
12109       sys$close(&fab_in); sys$close(&fab_out);
12110       PerlMem_free(vmsin);
12111       PerlMem_free(vmsout);
12112       PerlMem_free(esa);
12113       PerlMem_free(ubf);
12114       PerlMem_free(rsa);
12115       PerlMem_free(esa_out);
12116       set_errno(EVMSERR); set_vaxc_errno(sts);
12117       return 0;
12118     }
12119
12120     while ((sts = sys$read(&rab_in))) {  /* always true  */
12121       if (sts == RMS$_EOF) break;
12122       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12123       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12124         sys$close(&fab_in); sys$close(&fab_out);
12125         PerlMem_free(vmsin);
12126         PerlMem_free(vmsout);
12127         PerlMem_free(esa);
12128         PerlMem_free(ubf);
12129         PerlMem_free(rsa);
12130         PerlMem_free(esa_out);
12131         set_errno(EVMSERR); set_vaxc_errno(sts);
12132         return 0;
12133       }
12134     }
12135
12136
12137     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
12138     sys$close(&fab_in);  sys$close(&fab_out);
12139     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12140     if (!(sts & 1)) {
12141       PerlMem_free(vmsin);
12142       PerlMem_free(vmsout);
12143       PerlMem_free(esa);
12144       PerlMem_free(ubf);
12145       PerlMem_free(rsa);
12146       PerlMem_free(esa_out);
12147       set_errno(EVMSERR); set_vaxc_errno(sts);
12148       return 0;
12149     }
12150
12151     PerlMem_free(vmsin);
12152     PerlMem_free(vmsout);
12153     PerlMem_free(esa);
12154     PerlMem_free(ubf);
12155     PerlMem_free(rsa);
12156     PerlMem_free(esa_out);
12157     return 1;
12158
12159 }  /* end of rmscopy() */
12160 /*}}}*/
12161
12162
12163 /***  The following glue provides 'hooks' to make some of the routines
12164  * from this file available from Perl.  These routines are sufficiently
12165  * basic, and are required sufficiently early in the build process,
12166  * that's it's nice to have them available to miniperl as well as the
12167  * full Perl, so they're set up here instead of in an extension.  The
12168  * Perl code which handles importation of these names into a given
12169  * package lives in [.VMS]Filespec.pm in @INC.
12170  */
12171
12172 void
12173 rmsexpand_fromperl(pTHX_ CV *cv)
12174 {
12175   dXSARGS;
12176   char *fspec, *defspec = NULL, *rslt;
12177   STRLEN n_a;
12178   int fs_utf8, dfs_utf8;
12179
12180   fs_utf8 = 0;
12181   dfs_utf8 = 0;
12182   if (!items || items > 2)
12183     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12184   fspec = SvPV(ST(0),n_a);
12185   fs_utf8 = SvUTF8(ST(0));
12186   if (!fspec || !*fspec) XSRETURN_UNDEF;
12187   if (items == 2) {
12188     defspec = SvPV(ST(1),n_a);
12189     dfs_utf8 = SvUTF8(ST(1));
12190   }
12191   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12192   ST(0) = sv_newmortal();
12193   if (rslt != NULL) {
12194     sv_usepvn(ST(0),rslt,strlen(rslt));
12195     if (fs_utf8) {
12196         SvUTF8_on(ST(0));
12197     }
12198   }
12199   XSRETURN(1);
12200 }
12201
12202 void
12203 vmsify_fromperl(pTHX_ CV *cv)
12204 {
12205   dXSARGS;
12206   char *vmsified;
12207   STRLEN n_a;
12208   int utf8_fl;
12209
12210   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12211   utf8_fl = SvUTF8(ST(0));
12212   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12213   ST(0) = sv_newmortal();
12214   if (vmsified != NULL) {
12215     sv_usepvn(ST(0),vmsified,strlen(vmsified));
12216     if (utf8_fl) {
12217         SvUTF8_on(ST(0));
12218     }
12219   }
12220   XSRETURN(1);
12221 }
12222
12223 void
12224 unixify_fromperl(pTHX_ CV *cv)
12225 {
12226   dXSARGS;
12227   char *unixified;
12228   STRLEN n_a;
12229   int utf8_fl;
12230
12231   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12232   utf8_fl = SvUTF8(ST(0));
12233   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12234   ST(0) = sv_newmortal();
12235   if (unixified != NULL) {
12236     sv_usepvn(ST(0),unixified,strlen(unixified));
12237     if (utf8_fl) {
12238         SvUTF8_on(ST(0));
12239     }
12240   }
12241   XSRETURN(1);
12242 }
12243
12244 void
12245 fileify_fromperl(pTHX_ CV *cv)
12246 {
12247   dXSARGS;
12248   char *fileified;
12249   STRLEN n_a;
12250   int utf8_fl;
12251
12252   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12253   utf8_fl = SvUTF8(ST(0));
12254   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12255   ST(0) = sv_newmortal();
12256   if (fileified != NULL) {
12257     sv_usepvn(ST(0),fileified,strlen(fileified));
12258     if (utf8_fl) {
12259         SvUTF8_on(ST(0));
12260     }
12261   }
12262   XSRETURN(1);
12263 }
12264
12265 void
12266 pathify_fromperl(pTHX_ CV *cv)
12267 {
12268   dXSARGS;
12269   char *pathified;
12270   STRLEN n_a;
12271   int utf8_fl;
12272
12273   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12274   utf8_fl = SvUTF8(ST(0));
12275   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12276   ST(0) = sv_newmortal();
12277   if (pathified != NULL) {
12278     sv_usepvn(ST(0),pathified,strlen(pathified));
12279     if (utf8_fl) {
12280         SvUTF8_on(ST(0));
12281     }
12282   }
12283   XSRETURN(1);
12284 }
12285
12286 void
12287 vmspath_fromperl(pTHX_ CV *cv)
12288 {
12289   dXSARGS;
12290   char *vmspath;
12291   STRLEN n_a;
12292   int utf8_fl;
12293
12294   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12295   utf8_fl = SvUTF8(ST(0));
12296   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12297   ST(0) = sv_newmortal();
12298   if (vmspath != NULL) {
12299     sv_usepvn(ST(0),vmspath,strlen(vmspath));
12300     if (utf8_fl) {
12301         SvUTF8_on(ST(0));
12302     }
12303   }
12304   XSRETURN(1);
12305 }
12306
12307 void
12308 unixpath_fromperl(pTHX_ CV *cv)
12309 {
12310   dXSARGS;
12311   char *unixpath;
12312   STRLEN n_a;
12313   int utf8_fl;
12314
12315   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12316   utf8_fl = SvUTF8(ST(0));
12317   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12318   ST(0) = sv_newmortal();
12319   if (unixpath != NULL) {
12320     sv_usepvn(ST(0),unixpath,strlen(unixpath));
12321     if (utf8_fl) {
12322         SvUTF8_on(ST(0));
12323     }
12324   }
12325   XSRETURN(1);
12326 }
12327
12328 void
12329 candelete_fromperl(pTHX_ CV *cv)
12330 {
12331   dXSARGS;
12332   char *fspec, *fsp;
12333   SV *mysv;
12334   IO *io;
12335   STRLEN n_a;
12336
12337   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12338
12339   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12340   Newx(fspec, VMS_MAXRSS, char);
12341   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12342   if (SvTYPE(mysv) == SVt_PVGV) {
12343     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12344       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12345       ST(0) = &PL_sv_no;
12346       Safefree(fspec);
12347       XSRETURN(1);
12348     }
12349     fsp = fspec;
12350   }
12351   else {
12352     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12353       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12354       ST(0) = &PL_sv_no;
12355       Safefree(fspec);
12356       XSRETURN(1);
12357     }
12358   }
12359
12360   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12361   Safefree(fspec);
12362   XSRETURN(1);
12363 }
12364
12365 void
12366 rmscopy_fromperl(pTHX_ CV *cv)
12367 {
12368   dXSARGS;
12369   char *inspec, *outspec, *inp, *outp;
12370   int date_flag;
12371   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
12372                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12373   unsigned long int sts;
12374   SV *mysv;
12375   IO *io;
12376   STRLEN n_a;
12377
12378   if (items < 2 || items > 3)
12379     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12380
12381   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12382   Newx(inspec, VMS_MAXRSS, char);
12383   if (SvTYPE(mysv) == SVt_PVGV) {
12384     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12385       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12386       ST(0) = &PL_sv_no;
12387       Safefree(inspec);
12388       XSRETURN(1);
12389     }
12390     inp = inspec;
12391   }
12392   else {
12393     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12394       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12395       ST(0) = &PL_sv_no;
12396       Safefree(inspec);
12397       XSRETURN(1);
12398     }
12399   }
12400   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12401   Newx(outspec, VMS_MAXRSS, char);
12402   if (SvTYPE(mysv) == SVt_PVGV) {
12403     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12404       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12405       ST(0) = &PL_sv_no;
12406       Safefree(inspec);
12407       Safefree(outspec);
12408       XSRETURN(1);
12409     }
12410     outp = outspec;
12411   }
12412   else {
12413     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12414       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12415       ST(0) = &PL_sv_no;
12416       Safefree(inspec);
12417       Safefree(outspec);
12418       XSRETURN(1);
12419     }
12420   }
12421   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12422
12423   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
12424   Safefree(inspec);
12425   Safefree(outspec);
12426   XSRETURN(1);
12427 }
12428
12429 /* The mod2fname is limited to shorter filenames by design, so it should
12430  * not be modified to support longer EFS pathnames
12431  */
12432 void
12433 mod2fname(pTHX_ CV *cv)
12434 {
12435   dXSARGS;
12436   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12437        workbuff[NAM$C_MAXRSS*1 + 1];
12438   int total_namelen = 3, counter, num_entries;
12439   /* ODS-5 ups this, but we want to be consistent, so... */
12440   int max_name_len = 39;
12441   AV *in_array = (AV *)SvRV(ST(0));
12442
12443   num_entries = av_len(in_array);
12444
12445   /* All the names start with PL_. */
12446   strcpy(ultimate_name, "PL_");
12447
12448   /* Clean up our working buffer */
12449   Zero(work_name, sizeof(work_name), char);
12450
12451   /* Run through the entries and build up a working name */
12452   for(counter = 0; counter <= num_entries; counter++) {
12453     /* If it's not the first name then tack on a __ */
12454     if (counter) {
12455       strcat(work_name, "__");
12456     }
12457     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
12458                            PL_na));
12459   }
12460
12461   /* Check to see if we actually have to bother...*/
12462   if (strlen(work_name) + 3 <= max_name_len) {
12463     strcat(ultimate_name, work_name);
12464   } else {
12465     /* It's too darned big, so we need to go strip. We use the same */
12466     /* algorithm as xsubpp does. First, strip out doubled __ */
12467     char *source, *dest, last;
12468     dest = workbuff;
12469     last = 0;
12470     for (source = work_name; *source; source++) {
12471       if (last == *source && last == '_') {
12472         continue;
12473       }
12474       *dest++ = *source;
12475       last = *source;
12476     }
12477     /* Go put it back */
12478     strcpy(work_name, workbuff);
12479     /* Is it still too big? */
12480     if (strlen(work_name) + 3 > max_name_len) {
12481       /* Strip duplicate letters */
12482       last = 0;
12483       dest = workbuff;
12484       for (source = work_name; *source; source++) {
12485         if (last == toupper(*source)) {
12486         continue;
12487         }
12488         *dest++ = *source;
12489         last = toupper(*source);
12490       }
12491       strcpy(work_name, workbuff);
12492     }
12493
12494     /* Is it *still* too big? */
12495     if (strlen(work_name) + 3 > max_name_len) {
12496       /* Too bad, we truncate */
12497       work_name[max_name_len - 2] = 0;
12498     }
12499     strcat(ultimate_name, work_name);
12500   }
12501
12502   /* Okay, return it */
12503   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
12504   XSRETURN(1);
12505 }
12506
12507 void
12508 hushexit_fromperl(pTHX_ CV *cv)
12509 {
12510     dXSARGS;
12511
12512     if (items > 0) {
12513         VMSISH_HUSHED = SvTRUE(ST(0));
12514     }
12515     ST(0) = boolSV(VMSISH_HUSHED);
12516     XSRETURN(1);
12517 }
12518
12519
12520 PerlIO *
12521 Perl_vms_start_glob
12522    (pTHX_ SV *tmpglob,
12523     IO *io)
12524 {
12525     PerlIO *fp;
12526     struct vs_str_st *rslt;
12527     char *vmsspec;
12528     char *rstr;
12529     char *begin, *cp;
12530     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
12531     PerlIO *tmpfp;
12532     STRLEN i;
12533     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12534     struct dsc$descriptor_vs rsdsc;
12535     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
12536     unsigned long hasver = 0, isunix = 0;
12537     unsigned long int lff_flags = 0;
12538     int rms_sts;
12539
12540 #ifdef VMS_LONGNAME_SUPPORT
12541     lff_flags = LIB$M_FIL_LONG_NAMES;
12542 #endif
12543     /* The Newx macro will not allow me to assign a smaller array
12544      * to the rslt pointer, so we will assign it to the begin char pointer
12545      * and then copy the value into the rslt pointer.
12546      */
12547     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
12548     rslt = (struct vs_str_st *)begin;
12549     rslt->length = 0;
12550     rstr = &rslt->str[0];
12551     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
12552     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
12553     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
12554     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
12555
12556     Newx(vmsspec, VMS_MAXRSS, char);
12557
12558         /* We could find out if there's an explicit dev/dir or version
12559            by peeking into lib$find_file's internal context at
12560            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
12561            but that's unsupported, so I don't want to do it now and
12562            have it bite someone in the future. */
12563         /* Fix-me: vms_split_path() is the only way to do this, the
12564            existing method will fail with many legal EFS or UNIX specifications
12565          */
12566
12567     cp = SvPV(tmpglob,i);
12568
12569     for (; i; i--) {
12570         if (cp[i] == ';') hasver = 1;
12571         if (cp[i] == '.') {
12572             if (sts) hasver = 1;
12573             else sts = 1;
12574         }
12575         if (cp[i] == '/') {
12576             hasdir = isunix = 1;
12577             break;
12578         }
12579         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
12580             hasdir = 1;
12581             break;
12582         }
12583     }
12584     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
12585         int found = 0;
12586         Stat_t st;
12587         int stat_sts;
12588         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
12589         if (!stat_sts && S_ISDIR(st.st_mode)) {
12590             wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
12591             ok = (wilddsc.dsc$a_pointer != NULL);
12592             /* maybe passed 'foo' rather than '[.foo]', thus not detected above */
12593             hasdir = 1;
12594         }
12595         else {
12596             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
12597             ok = (wilddsc.dsc$a_pointer != NULL);
12598         }
12599         if (ok)
12600             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
12601
12602         /* If not extended character set, replace ? with % */
12603         /* With extended character set, ? is a wildcard single character */
12604         if (!decc_efs_case_preserve) {
12605             for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
12606                 if (*cp == '?') *cp = '%';
12607         }
12608         sts = SS$_NORMAL;
12609         while (ok && $VMS_STATUS_SUCCESS(sts)) {
12610          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
12611          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
12612
12613             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
12614                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
12615             if (!$VMS_STATUS_SUCCESS(sts))
12616                 break;
12617
12618             found++;
12619
12620             /* with varying string, 1st word of buffer contains result length */
12621             rstr[rslt->length] = '\0';
12622
12623              /* Find where all the components are */
12624              v_sts = vms_split_path
12625                        (rstr,
12626                         &v_spec,
12627                         &v_len,
12628                         &r_spec,
12629                         &r_len,
12630                         &d_spec,
12631                         &d_len,
12632                         &n_spec,
12633                         &n_len,
12634                         &e_spec,
12635                         &e_len,
12636                         &vs_spec,
12637                         &vs_len);
12638
12639             /* If no version on input, truncate the version on output */
12640             if (!hasver && (vs_len > 0)) {
12641                 *vs_spec = '\0';
12642                 vs_len = 0;
12643
12644                 /* No version & a null extension on UNIX handling */
12645                 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
12646                     e_len = 0;
12647                     *e_spec = '\0';
12648                 }
12649             }
12650
12651             if (!decc_efs_case_preserve) {
12652                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
12653             }
12654
12655             if (hasdir) {
12656                 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
12657                 begin = rstr;
12658             }
12659             else {
12660                 /* Start with the name */
12661                 begin = n_spec;
12662             }
12663             strcat(begin,"\n");
12664             ok = (PerlIO_puts(tmpfp,begin) != EOF);
12665         }
12666         if (cxt) (void)lib$find_file_end(&cxt);
12667
12668         if (!found) {
12669             /* Be POSIXish: return the input pattern when no matches */
12670             begin = SvPVX(tmpglob);
12671             strcat(begin,"\n");
12672             ok = (PerlIO_puts(tmpfp,begin) != EOF);
12673         }
12674
12675         if (ok && sts != RMS$_NMF &&
12676             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
12677         if (!ok) {
12678             if (!(sts & 1)) {
12679                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
12680             }
12681             PerlIO_close(tmpfp);
12682             fp = NULL;
12683         }
12684         else {
12685             PerlIO_rewind(tmpfp);
12686             IoTYPE(io) = IoTYPE_RDONLY;
12687             IoIFP(io) = fp = tmpfp;
12688             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
12689         }
12690     }
12691     Safefree(vmsspec);
12692     Safefree(rslt);
12693     return fp;
12694 }
12695
12696
12697 #ifdef HAS_SYMLINK
12698 static char *
12699 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
12700                    const int *utf8_fl);
12701
12702 void
12703 vms_realpath_fromperl(pTHX_ CV *cv)
12704 {
12705   dXSARGS;
12706   char *fspec, *rslt_spec, *rslt;
12707   STRLEN n_a;
12708
12709   if (!items || items != 1)
12710     Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
12711
12712   fspec = SvPV(ST(0),n_a);
12713   if (!fspec || !*fspec) XSRETURN_UNDEF;
12714
12715   Newx(rslt_spec, VMS_MAXRSS + 1, char);
12716   rslt = do_vms_realpath(fspec, rslt_spec, NULL);
12717   ST(0) = sv_newmortal();
12718   if (rslt != NULL)
12719     sv_usepvn(ST(0),rslt,strlen(rslt));
12720   else
12721     Safefree(rslt_spec);
12722   XSRETURN(1);
12723 }
12724 #endif
12725
12726 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12727 int do_vms_case_tolerant(void);
12728
12729 void
12730 vms_case_tolerant_fromperl(pTHX_ CV *cv)
12731 {
12732   dXSARGS;
12733   ST(0) = boolSV(do_vms_case_tolerant());
12734   XSRETURN(1);
12735 }
12736 #endif
12737
12738 void
12739 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
12740                           struct interp_intern *dst)
12741 {
12742     memcpy(dst,src,sizeof(struct interp_intern));
12743 }
12744
12745 void
12746 Perl_sys_intern_clear(pTHX)
12747 {
12748 }
12749
12750 void
12751 Perl_sys_intern_init(pTHX)
12752 {
12753     unsigned int ix = RAND_MAX;
12754     double x;
12755
12756     VMSISH_HUSHED = 0;
12757
12758     /* fix me later to track running under GNV */
12759     /* this allows some limited testing */
12760     MY_POSIX_EXIT = decc_filename_unix_report;
12761
12762     x = (float)ix;
12763     MY_INV_RAND_MAX = 1./x;
12764 }
12765
12766 void
12767 init_os_extras(void)
12768 {
12769   dTHX;
12770   char* file = __FILE__;
12771   if (decc_disable_to_vms_logname_translation) {
12772     no_translate_barewords = TRUE;
12773   } else {
12774     no_translate_barewords = FALSE;
12775   }
12776
12777   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
12778   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
12779   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
12780   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
12781   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
12782   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
12783   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
12784   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
12785   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
12786   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
12787   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
12788 #ifdef HAS_SYMLINK
12789   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
12790 #endif
12791 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12792   newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
12793 #endif
12794
12795   store_pipelocs(aTHX);         /* will redo any earlier attempts */
12796
12797   return;
12798 }
12799
12800 #ifdef HAS_SYMLINK
12801
12802 #if __CRTL_VER == 80200000
12803 /* This missed getting in to the DECC SDK for 8.2 */
12804 char *realpath(const char *file_name, char * resolved_name, ...);
12805 #endif
12806
12807 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
12808 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
12809  * The perl fallback routine to provide realpath() is not as efficient
12810  * on OpenVMS.
12811  */
12812 static char *
12813 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
12814                    const int *utf8_fl)
12815 {
12816     return realpath(filespec, outbuf);
12817 }
12818
12819 /*}}}*/
12820 /* External entry points */
12821 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12822 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
12823 #else
12824 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12825 { return NULL; }
12826 #endif
12827
12828
12829 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12830 /* case_tolerant */
12831
12832 /*{{{int do_vms_case_tolerant(void)*/
12833 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
12834  * controlled by a process setting.
12835  */
12836 int do_vms_case_tolerant(void)
12837 {
12838     return vms_process_case_tolerant;
12839 }
12840 /*}}}*/
12841 /* External entry points */
12842 int Perl_vms_case_tolerant(void)
12843 { return do_vms_case_tolerant(); }
12844 #else
12845 int Perl_vms_case_tolerant(void)
12846 { return vms_process_case_tolerant; }
12847 #endif
12848
12849
12850  /* Start of DECC RTL Feature handling */
12851
12852 static int sys_trnlnm
12853    (const char * logname,
12854     char * value,
12855     int value_len)
12856 {
12857     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
12858     const unsigned long attr = LNM$M_CASE_BLIND;
12859     struct dsc$descriptor_s name_dsc;
12860     int status;
12861     unsigned short result;
12862     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
12863                                 {0, 0, 0, 0}};
12864
12865     name_dsc.dsc$w_length = strlen(logname);
12866     name_dsc.dsc$a_pointer = (char *)logname;
12867     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12868     name_dsc.dsc$b_class = DSC$K_CLASS_S;
12869
12870     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
12871
12872     if ($VMS_STATUS_SUCCESS(status)) {
12873
12874          /* Null terminate and return the string */
12875         /*--------------------------------------*/
12876         value[result] = 0;
12877     }
12878
12879     return status;
12880 }
12881
12882 static int sys_crelnm
12883    (const char * logname,
12884     const char * value)
12885 {
12886     int ret_val;
12887     const char * proc_table = "LNM$PROCESS_TABLE";
12888     struct dsc$descriptor_s proc_table_dsc;
12889     struct dsc$descriptor_s logname_dsc;
12890     struct itmlst_3 item_list[2];
12891
12892     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
12893     proc_table_dsc.dsc$w_length = strlen(proc_table);
12894     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12895     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
12896
12897     logname_dsc.dsc$a_pointer = (char *) logname;
12898     logname_dsc.dsc$w_length = strlen(logname);
12899     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12900     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
12901
12902     item_list[0].buflen = strlen(value);
12903     item_list[0].itmcode = LNM$_STRING;
12904     item_list[0].bufadr = (char *)value;
12905     item_list[0].retlen = NULL;
12906
12907     item_list[1].buflen = 0;
12908     item_list[1].itmcode = 0;
12909
12910     ret_val = sys$crelnm
12911                        (NULL,
12912                         (const struct dsc$descriptor_s *)&proc_table_dsc,
12913                         (const struct dsc$descriptor_s *)&logname_dsc,
12914                         NULL,
12915                         (const struct item_list_3 *) item_list);
12916
12917     return ret_val;
12918 }
12919
12920 /* C RTL Feature settings */
12921
12922 static int set_features
12923    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
12924     int (* cli_routine)(void),  /* Not documented */
12925     void *image_info)           /* Not documented */
12926 {
12927     int status;
12928     int s;
12929     int dflt;
12930     char* str;
12931     char val_str[10];
12932 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12933     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
12934     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
12935     unsigned long case_perm;
12936     unsigned long case_image;
12937 #endif
12938
12939     /* Allow an exception to bring Perl into the VMS debugger */
12940     vms_debug_on_exception = 0;
12941     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
12942     if ($VMS_STATUS_SUCCESS(status)) {
12943        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12944          vms_debug_on_exception = 1;
12945        else
12946          vms_debug_on_exception = 0;
12947     }
12948
12949     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
12950     vms_vtf7_filenames = 0;
12951     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
12952     if ($VMS_STATUS_SUCCESS(status)) {
12953        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12954          vms_vtf7_filenames = 1;
12955        else
12956          vms_vtf7_filenames = 0;
12957     }
12958
12959
12960     /* unlink all versions on unlink() or rename() */
12961     vms_vtf7_filenames = 0;
12962     status = sys_trnlnm
12963         ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
12964     if ($VMS_STATUS_SUCCESS(status)) {
12965        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12966          vms_unlink_all_versions = 1;
12967        else
12968          vms_unlink_all_versions = 0;
12969     }
12970
12971     /* Dectect running under GNV Bash or other UNIX like shell */
12972 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12973     gnv_unix_shell = 0;
12974     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
12975     if ($VMS_STATUS_SUCCESS(status)) {
12976        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12977          gnv_unix_shell = 1;
12978          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
12979          set_feature_default("DECC$EFS_CHARSET", 1);
12980          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
12981          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
12982          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
12983          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
12984          vms_unlink_all_versions = 1;
12985        }
12986        else
12987          gnv_unix_shell = 0;
12988     }
12989 #endif
12990
12991     /* hacks to see if known bugs are still present for testing */
12992
12993     /* Readdir is returning filenames in VMS syntax always */
12994     decc_bug_readdir_efs1 = 1;
12995     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
12996     if ($VMS_STATUS_SUCCESS(status)) {
12997        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12998          decc_bug_readdir_efs1 = 1;
12999        else
13000          decc_bug_readdir_efs1 = 0;
13001     }
13002
13003     /* PCP mode requires creating /dev/null special device file */
13004     decc_bug_devnull = 0;
13005     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
13006     if ($VMS_STATUS_SUCCESS(status)) {
13007        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13008           decc_bug_devnull = 1;
13009        else
13010           decc_bug_devnull = 0;
13011     }
13012
13013     /* fgetname returning a VMS name in UNIX mode */
13014     decc_bug_fgetname = 1;
13015     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
13016     if ($VMS_STATUS_SUCCESS(status)) {
13017       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13018         decc_bug_fgetname = 1;
13019       else
13020         decc_bug_fgetname = 0;
13021     }
13022
13023     /* UNIX directory names with no paths are broken in a lot of places */
13024     decc_dir_barename = 1;
13025     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
13026     if ($VMS_STATUS_SUCCESS(status)) {
13027       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13028         decc_dir_barename = 1;
13029       else
13030         decc_dir_barename = 0;
13031     }
13032
13033 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13034     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
13035     if (s >= 0) {
13036         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
13037         if (decc_disable_to_vms_logname_translation < 0)
13038             decc_disable_to_vms_logname_translation = 0;
13039     }
13040
13041     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
13042     if (s >= 0) {
13043         decc_efs_case_preserve = decc$feature_get_value(s, 1);
13044         if (decc_efs_case_preserve < 0)
13045             decc_efs_case_preserve = 0;
13046     }
13047
13048     s = decc$feature_get_index("DECC$EFS_CHARSET");
13049     if (s >= 0) {
13050         decc_efs_charset = decc$feature_get_value(s, 1);
13051         if (decc_efs_charset < 0)
13052             decc_efs_charset = 0;
13053     }
13054
13055     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
13056     if (s >= 0) {
13057         decc_filename_unix_report = decc$feature_get_value(s, 1);
13058         if (decc_filename_unix_report > 0)
13059             decc_filename_unix_report = 1;
13060         else
13061             decc_filename_unix_report = 0;
13062     }
13063
13064     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
13065     if (s >= 0) {
13066         decc_filename_unix_only = decc$feature_get_value(s, 1);
13067         if (decc_filename_unix_only > 0) {
13068             decc_filename_unix_only = 1;
13069         }
13070         else {
13071             decc_filename_unix_only = 0;
13072         }
13073     }
13074
13075     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
13076     if (s >= 0) {
13077         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
13078         if (decc_filename_unix_no_version < 0)
13079             decc_filename_unix_no_version = 0;
13080     }
13081
13082     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
13083     if (s >= 0) {
13084         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
13085         if (decc_readdir_dropdotnotype < 0)
13086             decc_readdir_dropdotnotype = 0;
13087     }
13088
13089     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
13090     if ($VMS_STATUS_SUCCESS(status)) {
13091         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
13092         if (s >= 0) {
13093             dflt = decc$feature_get_value(s, 4);
13094             if (dflt > 0) {
13095                 decc_disable_posix_root = decc$feature_get_value(s, 1);
13096                 if (decc_disable_posix_root <= 0) {
13097                     decc$feature_set_value(s, 1, 1);
13098                     decc_disable_posix_root = 1;
13099                 }
13100             }
13101             else {
13102                 /* Traditionally Perl assumes this is off */
13103                 decc_disable_posix_root = 1;
13104                 decc$feature_set_value(s, 1, 1);
13105             }
13106         }
13107     }
13108
13109 #if __CRTL_VER >= 80200000
13110     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
13111     if (s >= 0) {
13112         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
13113         if (decc_posix_compliant_pathnames < 0)
13114             decc_posix_compliant_pathnames = 0;
13115         if (decc_posix_compliant_pathnames > 4)
13116             decc_posix_compliant_pathnames = 0;
13117     }
13118
13119 #endif
13120 #else
13121     status = sys_trnlnm
13122         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
13123     if ($VMS_STATUS_SUCCESS(status)) {
13124         val_str[0] = _toupper(val_str[0]);
13125         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13126            decc_disable_to_vms_logname_translation = 1;
13127         }
13128     }
13129
13130 #ifndef __VAX
13131     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
13132     if ($VMS_STATUS_SUCCESS(status)) {
13133         val_str[0] = _toupper(val_str[0]);
13134         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13135            decc_efs_case_preserve = 1;
13136         }
13137     }
13138 #endif
13139
13140     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
13141     if ($VMS_STATUS_SUCCESS(status)) {
13142         val_str[0] = _toupper(val_str[0]);
13143         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13144            decc_filename_unix_report = 1;
13145         }
13146     }
13147     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
13148     if ($VMS_STATUS_SUCCESS(status)) {
13149         val_str[0] = _toupper(val_str[0]);
13150         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13151            decc_filename_unix_only = 1;
13152            decc_filename_unix_report = 1;
13153         }
13154     }
13155     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
13156     if ($VMS_STATUS_SUCCESS(status)) {
13157         val_str[0] = _toupper(val_str[0]);
13158         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13159            decc_filename_unix_no_version = 1;
13160         }
13161     }
13162     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
13163     if ($VMS_STATUS_SUCCESS(status)) {
13164         val_str[0] = _toupper(val_str[0]);
13165         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13166            decc_readdir_dropdotnotype = 1;
13167         }
13168     }
13169 #endif
13170
13171 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13172
13173      /* Report true case tolerance */
13174     /*----------------------------*/
13175     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
13176     if (!$VMS_STATUS_SUCCESS(status))
13177         case_perm = PPROP$K_CASE_BLIND;
13178     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
13179     if (!$VMS_STATUS_SUCCESS(status))
13180         case_image = PPROP$K_CASE_BLIND;
13181     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
13182         (case_image == PPROP$K_CASE_SENSITIVE))
13183         vms_process_case_tolerant = 0;
13184
13185 #endif
13186
13187
13188     /* CRTL can be initialized past this point, but not before. */
13189 /*    DECC$CRTL_INIT(); */
13190
13191     return SS$_NORMAL;
13192 }
13193
13194 #ifdef __DECC
13195 #pragma nostandard
13196 #pragma extern_model save
13197 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
13198         const __align (LONGWORD) int spare[8] = {0};
13199
13200 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
13201 #if __DECC_VER >= 60560002
13202 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
13203 #else
13204 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
13205 #endif
13206 #endif /* __DECC */
13207
13208 const long vms_cc_features = (const long)set_features;
13209
13210 /*
13211 ** Force a reference to LIB$INITIALIZE to ensure it
13212 ** exists in the image.
13213 */
13214 int lib$initialize(void);
13215 #ifdef __DECC
13216 #pragma extern_model strict_refdef
13217 #endif
13218     int lib_init_ref = (int) lib$initialize;
13219
13220 #ifdef __DECC
13221 #pragma extern_model restore
13222 #pragma standard
13223 #endif
13224
13225 /*  End of vms.c */